3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if LONGSIZE > 4 && defined(_CRAY)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
85 /* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
89 #ifdef NEED_GETPID_PROTO
90 extern Pid_t getpid (void);
96 if (GIMME_V == G_SCALAR)
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
114 if (PL_op->op_flags & OPf_REF) {
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
123 if (GIMME == G_ARRAY) {
124 I32 maxarg = AvFILL((AV*)TARG) + 1;
126 if (SvMAGICAL(TARG)) {
128 for (i=0; i < maxarg; i++) {
129 SV **svp = av_fetch((AV*)TARG, i, FALSE);
130 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
134 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
139 SV* sv = sv_newmortal();
140 I32 maxarg = AvFILL((AV*)TARG) + 1;
141 sv_setiv(sv, maxarg);
153 if (PL_op->op_private & OPpLVAL_INTRO)
154 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
155 if (PL_op->op_flags & OPf_REF)
158 if (GIMME == G_SCALAR)
159 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
163 if (gimme == G_ARRAY) {
166 else if (gimme == G_SCALAR) {
167 SV* sv = sv_newmortal();
168 if (HvFILL((HV*)TARG))
169 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
170 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
180 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
191 tryAMAGICunDEREF(to_gv);
194 if (SvTYPE(sv) == SVt_PVIO) {
195 GV *gv = (GV*) sv_newmortal();
196 gv_init(gv, 0, "", 0, 0);
197 GvIOp(gv) = (IO *)sv;
198 (void)SvREFCNT_inc(sv);
201 else if (SvTYPE(sv) != SVt_PVGV)
202 DIE(aTHX_ "Not a GLOB reference");
205 if (SvTYPE(sv) != SVt_PVGV) {
209 if (SvGMAGICAL(sv)) {
214 if (!SvOK(sv) && sv != &PL_sv_undef) {
215 /* If this is a 'my' scalar and flag is set then vivify
218 if (PL_op->op_private & OPpDEREF) {
221 if (cUNOP->op_targ) {
223 SV *namesv = PL_curpad[cUNOP->op_targ];
224 name = SvPV(namesv, len);
225 gv = (GV*)NEWSV(0,0);
226 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
229 name = CopSTASHPV(PL_curcop);
232 if (SvTYPE(sv) < SVt_RV)
233 sv_upgrade(sv, SVt_RV);
239 if (PL_op->op_flags & OPf_REF ||
240 PL_op->op_private & HINT_STRICT_REFS)
241 DIE(aTHX_ PL_no_usym, "a symbol");
242 if (ckWARN(WARN_UNINITIALIZED))
247 if ((PL_op->op_flags & OPf_SPECIAL) &&
248 !(PL_op->op_flags & OPf_MOD))
250 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
252 && (!is_gv_magical(sym,len,0)
253 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
259 if (PL_op->op_private & HINT_STRICT_REFS)
260 DIE(aTHX_ PL_no_symref, sym, "a symbol");
261 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
265 if (PL_op->op_private & OPpLVAL_INTRO)
266 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
277 tryAMAGICunDEREF(to_sv);
280 switch (SvTYPE(sv)) {
284 DIE(aTHX_ "Not a SCALAR reference");
292 if (SvTYPE(gv) != SVt_PVGV) {
293 if (SvGMAGICAL(sv)) {
299 if (PL_op->op_flags & OPf_REF ||
300 PL_op->op_private & HINT_STRICT_REFS)
301 DIE(aTHX_ PL_no_usym, "a SCALAR");
302 if (ckWARN(WARN_UNINITIALIZED))
307 if ((PL_op->op_flags & OPf_SPECIAL) &&
308 !(PL_op->op_flags & OPf_MOD))
310 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
312 && (!is_gv_magical(sym,len,0)
313 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
319 if (PL_op->op_private & HINT_STRICT_REFS)
320 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
321 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
326 if (PL_op->op_flags & OPf_MOD) {
327 if (PL_op->op_private & OPpLVAL_INTRO)
328 sv = save_scalar((GV*)TOPs);
329 else if (PL_op->op_private & OPpDEREF)
330 vivify_ref(sv, PL_op->op_private & OPpDEREF);
340 SV *sv = AvARYLEN(av);
342 AvARYLEN(av) = sv = NEWSV(0,0);
343 sv_upgrade(sv, SVt_IV);
344 sv_magic(sv, (SV*)av, '#', Nullch, 0);
352 djSP; dTARGET; dPOPss;
354 if (PL_op->op_flags & OPf_MOD || LVRET) {
355 if (SvTYPE(TARG) < SVt_PVLV) {
356 sv_upgrade(TARG, SVt_PVLV);
357 sv_magic(TARG, Nullsv, '.', Nullch, 0);
361 if (LvTARG(TARG) != sv) {
363 SvREFCNT_dec(LvTARG(TARG));
364 LvTARG(TARG) = SvREFCNT_inc(sv);
366 PUSHs(TARG); /* no SvSETMAGIC */
372 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
373 mg = mg_find(sv, 'g');
374 if (mg && mg->mg_len >= 0) {
378 PUSHi(i + PL_curcop->cop_arybase);
392 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
393 /* (But not in defined().) */
394 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
397 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
398 if ((PL_op->op_private & OPpLVAL_INTRO)) {
399 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
402 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
406 cv = (CV*)&PL_sv_undef;
420 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
421 char *s = SvPVX(TOPs);
422 if (strnEQ(s, "CORE::", 6)) {
425 code = keyword(s + 6, SvCUR(TOPs) - 6);
426 if (code < 0) { /* Overridable. */
427 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
428 int i = 0, n = 0, seen_question = 0;
430 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
432 while (i < MAXO) { /* The slow way. */
433 if (strEQ(s + 6, PL_op_name[i])
434 || strEQ(s + 6, PL_op_desc[i]))
440 goto nonesuch; /* Should not happen... */
442 oa = PL_opargs[i] >> OASHIFT;
444 if (oa & OA_OPTIONAL && !seen_question) {
448 else if (n && str[0] == ';' && seen_question)
449 goto set; /* XXXX system, exec */
450 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
451 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
454 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
455 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
459 ret = sv_2mortal(newSVpvn(str, n - 1));
461 else if (code) /* Non-Overridable */
463 else { /* None such */
465 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
469 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
471 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
480 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
482 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
498 if (GIMME != G_ARRAY) {
502 *MARK = &PL_sv_undef;
503 *MARK = refto(*MARK);
507 EXTEND_MORTAL(SP - MARK);
509 *MARK = refto(*MARK);
514 S_refto(pTHX_ SV *sv)
518 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
521 if (!(sv = LvTARG(sv)))
524 (void)SvREFCNT_inc(sv);
526 else if (SvTYPE(sv) == SVt_PVAV) {
527 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
530 (void)SvREFCNT_inc(sv);
532 else if (SvPADTMP(sv))
536 (void)SvREFCNT_inc(sv);
539 sv_upgrade(rv, SVt_RV);
553 if (sv && SvGMAGICAL(sv))
556 if (!sv || !SvROK(sv))
560 pv = sv_reftype(sv,TRUE);
561 PUSHp(pv, strlen(pv));
571 stash = CopSTASH(PL_curcop);
577 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
578 Perl_croak(aTHX_ "Attempt to bless into a reference");
580 if (ckWARN(WARN_MISC) && len == 0)
581 Perl_warner(aTHX_ WARN_MISC,
582 "Explicit blessing to '' (assuming package main)");
583 stash = gv_stashpvn(ptr, len, TRUE);
586 (void)sv_bless(TOPs, stash);
600 elem = SvPV(sv, n_a);
604 switch (elem ? *elem : '\0')
607 if (strEQ(elem, "ARRAY"))
608 tmpRef = (SV*)GvAV(gv);
611 if (strEQ(elem, "CODE"))
612 tmpRef = (SV*)GvCVu(gv);
615 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
616 tmpRef = (SV*)GvIOp(gv);
618 if (strEQ(elem, "FORMAT"))
619 tmpRef = (SV*)GvFORM(gv);
622 if (strEQ(elem, "GLOB"))
626 if (strEQ(elem, "HASH"))
627 tmpRef = (SV*)GvHV(gv);
630 if (strEQ(elem, "IO"))
631 tmpRef = (SV*)GvIOp(gv);
634 if (strEQ(elem, "NAME"))
635 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
638 if (strEQ(elem, "PACKAGE"))
639 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
642 if (strEQ(elem, "SCALAR"))
656 /* Pattern matching */
661 register unsigned char *s;
664 register I32 *sfirst;
668 if (sv == PL_lastscream) {
674 SvSCREAM_off(PL_lastscream);
675 SvREFCNT_dec(PL_lastscream);
677 PL_lastscream = SvREFCNT_inc(sv);
680 s = (unsigned char*)(SvPV(sv, len));
684 if (pos > PL_maxscream) {
685 if (PL_maxscream < 0) {
686 PL_maxscream = pos + 80;
687 New(301, PL_screamfirst, 256, I32);
688 New(302, PL_screamnext, PL_maxscream, I32);
691 PL_maxscream = pos + pos / 4;
692 Renew(PL_screamnext, PL_maxscream, I32);
696 sfirst = PL_screamfirst;
697 snext = PL_screamnext;
699 if (!sfirst || !snext)
700 DIE(aTHX_ "do_study: out of memory");
702 for (ch = 256; ch; --ch)
709 snext[pos] = sfirst[ch] - pos;
716 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
725 if (PL_op->op_flags & OPf_STACKED)
731 TARG = sv_newmortal();
736 /* Lvalue operators. */
748 djSP; dMARK; dTARGET;
758 SETi(do_chomp(TOPs));
764 djSP; dMARK; dTARGET;
765 register I32 count = 0;
768 count += do_chomp(POPs);
779 if (!sv || !SvANY(sv))
781 switch (SvTYPE(sv)) {
783 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
787 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
791 if (CvROOT(sv) || CvXSUB(sv))
808 if (!PL_op->op_private) {
817 if (SvTHINKFIRST(sv))
820 switch (SvTYPE(sv)) {
830 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
831 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
832 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
836 /* let user-undef'd sub keep its identity */
837 GV* gv = CvGV((CV*)sv);
844 SvSetMagicSV(sv, &PL_sv_undef);
848 Newz(602, gp, 1, GP);
849 GvGP(sv) = gp_ref(gp);
850 GvSV(sv) = NEWSV(72,0);
851 GvLINE(sv) = CopLINE(PL_curcop);
857 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
860 SvPV_set(sv, Nullch);
873 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
874 DIE(aTHX_ PL_no_modify);
875 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
876 SvIVX(TOPs) != IV_MIN)
879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
890 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
891 DIE(aTHX_ PL_no_modify);
892 sv_setsv(TARG, TOPs);
893 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
894 SvIVX(TOPs) != IV_MAX)
897 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
911 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
912 DIE(aTHX_ PL_no_modify);
913 sv_setsv(TARG, TOPs);
914 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
915 SvIVX(TOPs) != IV_MIN)
918 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
927 /* Ordinary operators. */
931 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
934 SETn( Perl_pow( left, right) );
941 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
942 #ifdef PERL_PRESERVE_IVUV
945 /* Unless the left argument is integer in range we are going to have to
946 use NV maths. Hence only attempt to coerce the right argument if
947 we know the left is integer. */
948 /* Left operand is defined, so is it IV? */
951 bool auvok = SvUOK(TOPm1s);
952 bool buvok = SvUOK(TOPs);
953 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
954 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
961 alow = SvUVX(TOPm1s);
963 IV aiv = SvIVX(TOPm1s);
966 auvok = TRUE; /* effectively it's a UV now */
968 alow = -aiv; /* abs, auvok == false records sign */
974 IV biv = SvIVX(TOPs);
977 buvok = TRUE; /* effectively it's a UV now */
979 blow = -biv; /* abs, buvok == false records sign */
983 /* If this does sign extension on unsigned it's time for plan B */
984 ahigh = alow >> (4 * sizeof (UV));
986 bhigh = blow >> (4 * sizeof (UV));
988 if (ahigh && bhigh) {
989 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
990 which is overflow. Drop to NVs below. */
991 } else if (!ahigh && !bhigh) {
992 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
993 so the unsigned multiply cannot overflow. */
994 UV product = alow * blow;
995 if (auvok == buvok) {
996 /* -ve * -ve or +ve * +ve gives a +ve result. */
1000 } else if (product <= (UV)IV_MIN) {
1001 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1002 /* -ve result, which could overflow an IV */
1006 } /* else drop to NVs below. */
1008 /* One operand is large, 1 small */
1011 /* swap the operands */
1013 bhigh = blow; /* bhigh now the temp var for the swap */
1017 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1018 multiplies can't overflow. shift can, add can, -ve can. */
1019 product_middle = ahigh * blow;
1020 if (!(product_middle & topmask)) {
1021 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1023 product_middle <<= (4 * sizeof (UV));
1024 product_low = alow * blow;
1026 /* as for pp_add, UV + something mustn't get smaller.
1027 IIRC ANSI mandates this wrapping *behaviour* for
1028 unsigned whatever the actual representation*/
1029 product_low += product_middle;
1030 if (product_low >= product_middle) {
1031 /* didn't overflow */
1032 if (auvok == buvok) {
1033 /* -ve * -ve or +ve * +ve gives a +ve result. */
1035 SETu( product_low );
1037 } else if (product_low <= (UV)IV_MIN) {
1038 /* 2s complement assumption again */
1039 /* -ve result, which could overflow an IV */
1041 SETi( -product_low );
1043 } /* else drop to NVs below. */
1045 } /* product_middle too large */
1046 } /* ahigh && bhigh */
1047 } /* SvIOK(TOPm1s) */
1052 SETn( left * right );
1059 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1064 DIE(aTHX_ "Illegal division by zero");
1066 /* insure that 20./5. == 4. */
1069 if ((NV)I_V(left) == left &&
1070 (NV)I_V(right) == right &&
1071 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1075 value = left / right;
1079 value = left / right;
1088 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1094 bool use_double = 0;
1098 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1100 right = (right_neg = (i < 0)) ? -i : i;
1105 right_neg = dright < 0;
1110 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1112 left = (left_neg = (i < 0)) ? -i : i;
1120 left_neg = dleft < 0;
1129 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1131 # define CAST_D2UV(d) U_V(d)
1133 # define CAST_D2UV(d) ((UV)(d))
1135 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1136 * or, in other words, precision of UV more than of NV.
1137 * But in fact the approach below turned out to be an
1138 * optimization - floor() may be slow */
1139 if (dright <= UV_MAX && dleft <= UV_MAX) {
1140 right = CAST_D2UV(dright);
1141 left = CAST_D2UV(dleft);
1146 /* Backward-compatibility clause: */
1147 dright = Perl_floor(dright + 0.5);
1148 dleft = Perl_floor(dleft + 0.5);
1151 DIE(aTHX_ "Illegal modulus zero");
1153 dans = Perl_fmod(dleft, dright);
1154 if ((left_neg != right_neg) && dans)
1155 dans = dright - dans;
1158 sv_setnv(TARG, dans);
1165 DIE(aTHX_ "Illegal modulus zero");
1168 if ((left_neg != right_neg) && ans)
1171 /* XXX may warn: unary minus operator applied to unsigned type */
1172 /* could change -foo to be (~foo)+1 instead */
1173 if (ans <= ~((UV)IV_MAX)+1)
1174 sv_setiv(TARG, ~ans+1);
1176 sv_setnv(TARG, -(NV)ans);
1179 sv_setuv(TARG, ans);
1188 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1190 register IV count = POPi;
1191 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1193 I32 items = SP - MARK;
1196 max = items * count;
1205 repeatcpy((char*)(MARK + items), (char*)MARK,
1206 items * sizeof(SV*), count - 1);
1209 else if (count <= 0)
1212 else { /* Note: mark already snarfed by pp_list */
1217 SvSetSV(TARG, tmpstr);
1218 SvPV_force(TARG, len);
1219 isutf = DO_UTF8(TARG);
1224 SvGROW(TARG, (count * len) + 1);
1225 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1226 SvCUR(TARG) *= count;
1228 *SvEND(TARG) = '\0';
1231 (void)SvPOK_only_UTF8(TARG);
1233 (void)SvPOK_only(TARG);
1242 djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1243 useleft = USE_LEFT(TOPm1s);
1244 #ifdef PERL_PRESERVE_IVUV
1245 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1246 "bad things" happen if you rely on signed integers wrapping. */
1249 /* Unless the left argument is integer in range we are going to have to
1250 use NV maths. Hence only attempt to coerce the right argument if
1251 we know the left is integer. */
1258 a_valid = auvok = 1;
1259 /* left operand is undef, treat as zero. */
1261 /* Left operand is defined, so is it IV? */
1262 SvIV_please(TOPm1s);
1263 if (SvIOK(TOPm1s)) {
1264 if ((auvok = SvUOK(TOPm1s)))
1265 auv = SvUVX(TOPm1s);
1267 register IV aiv = SvIVX(TOPm1s);
1270 auvok = 1; /* Now acting as a sign flag. */
1271 } else { /* 2s complement assumption for IV_MIN */
1279 bool result_good = 0;
1282 bool buvok = SvUOK(TOPs);
1287 register IV biv = SvIVX(TOPs);
1294 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1295 else "IV" now, independant of how it came in.
1296 if a, b represents positive, A, B negative, a maps to -A etc
1301 all UV maths. negate result if A negative.
1302 subtract if signs same, add if signs differ. */
1304 if (auvok ^ buvok) {
1313 /* Must get smaller */
1318 if (result <= buv) {
1319 /* result really should be -(auv-buv). as its negation
1320 of true value, need to swap our result flag */
1332 if (result <= (UV)IV_MIN)
1333 SETi( -(IV)result );
1335 /* result valid, but out of range for IV. */
1336 SETn( -(NV)result );
1340 } /* Overflow, drop through to NVs. */
1344 useleft = USE_LEFT(TOPm1s);
1348 /* left operand is undef, treat as zero - value */
1352 SETn( TOPn - value );
1359 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1362 if (PL_op->op_private & HINT_INTEGER) {
1376 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1379 if (PL_op->op_private & HINT_INTEGER) {
1393 djSP; tryAMAGICbinSET(lt,0);
1394 #ifdef PERL_PRESERVE_IVUV
1397 SvIV_please(TOPm1s);
1398 if (SvIOK(TOPm1s)) {
1399 bool auvok = SvUOK(TOPm1s);
1400 bool buvok = SvUOK(TOPs);
1402 if (!auvok && !buvok) { /* ## IV < IV ## */
1403 IV aiv = SvIVX(TOPm1s);
1404 IV biv = SvIVX(TOPs);
1407 SETs(boolSV(aiv < biv));
1410 if (auvok && buvok) { /* ## UV < UV ## */
1411 UV auv = SvUVX(TOPm1s);
1412 UV buv = SvUVX(TOPs);
1415 SETs(boolSV(auv < buv));
1418 if (auvok) { /* ## UV < IV ## */
1425 /* As (a) is a UV, it's >=0, so it cannot be < */
1430 if (auv >= (UV) IV_MAX) {
1431 /* As (b) is an IV, it cannot be > IV_MAX */
1435 SETs(boolSV(auv < (UV)biv));
1438 { /* ## IV < UV ## */
1442 aiv = SvIVX(TOPm1s);
1444 /* As (b) is a UV, it's >=0, so it must be < */
1451 if (buv > (UV) IV_MAX) {
1452 /* As (a) is an IV, it cannot be > IV_MAX */
1456 SETs(boolSV((UV)aiv < buv));
1464 SETs(boolSV(TOPn < value));
1471 djSP; tryAMAGICbinSET(gt,0);
1472 #ifdef PERL_PRESERVE_IVUV
1475 SvIV_please(TOPm1s);
1476 if (SvIOK(TOPm1s)) {
1477 bool auvok = SvUOK(TOPm1s);
1478 bool buvok = SvUOK(TOPs);
1480 if (!auvok && !buvok) { /* ## IV > IV ## */
1481 IV aiv = SvIVX(TOPm1s);
1482 IV biv = SvIVX(TOPs);
1485 SETs(boolSV(aiv > biv));
1488 if (auvok && buvok) { /* ## UV > UV ## */
1489 UV auv = SvUVX(TOPm1s);
1490 UV buv = SvUVX(TOPs);
1493 SETs(boolSV(auv > buv));
1496 if (auvok) { /* ## UV > IV ## */
1503 /* As (a) is a UV, it's >=0, so it must be > */
1508 if (auv > (UV) IV_MAX) {
1509 /* As (b) is an IV, it cannot be > IV_MAX */
1513 SETs(boolSV(auv > (UV)biv));
1516 { /* ## IV > UV ## */
1520 aiv = SvIVX(TOPm1s);
1522 /* As (b) is a UV, it's >=0, so it cannot be > */
1529 if (buv >= (UV) IV_MAX) {
1530 /* As (a) is an IV, it cannot be > IV_MAX */
1534 SETs(boolSV((UV)aiv > buv));
1542 SETs(boolSV(TOPn > value));
1549 djSP; tryAMAGICbinSET(le,0);
1550 #ifdef PERL_PRESERVE_IVUV
1553 SvIV_please(TOPm1s);
1554 if (SvIOK(TOPm1s)) {
1555 bool auvok = SvUOK(TOPm1s);
1556 bool buvok = SvUOK(TOPs);
1558 if (!auvok && !buvok) { /* ## IV <= IV ## */
1559 IV aiv = SvIVX(TOPm1s);
1560 IV biv = SvIVX(TOPs);
1563 SETs(boolSV(aiv <= biv));
1566 if (auvok && buvok) { /* ## UV <= UV ## */
1567 UV auv = SvUVX(TOPm1s);
1568 UV buv = SvUVX(TOPs);
1571 SETs(boolSV(auv <= buv));
1574 if (auvok) { /* ## UV <= IV ## */
1581 /* As (a) is a UV, it's >=0, so a cannot be <= */
1586 if (auv > (UV) IV_MAX) {
1587 /* As (b) is an IV, it cannot be > IV_MAX */
1591 SETs(boolSV(auv <= (UV)biv));
1594 { /* ## IV <= UV ## */
1598 aiv = SvIVX(TOPm1s);
1600 /* As (b) is a UV, it's >=0, so a must be <= */
1607 if (buv >= (UV) IV_MAX) {
1608 /* As (a) is an IV, it cannot be > IV_MAX */
1612 SETs(boolSV((UV)aiv <= buv));
1620 SETs(boolSV(TOPn <= value));
1627 djSP; tryAMAGICbinSET(ge,0);
1628 #ifdef PERL_PRESERVE_IVUV
1631 SvIV_please(TOPm1s);
1632 if (SvIOK(TOPm1s)) {
1633 bool auvok = SvUOK(TOPm1s);
1634 bool buvok = SvUOK(TOPs);
1636 if (!auvok && !buvok) { /* ## IV >= IV ## */
1637 IV aiv = SvIVX(TOPm1s);
1638 IV biv = SvIVX(TOPs);
1641 SETs(boolSV(aiv >= biv));
1644 if (auvok && buvok) { /* ## UV >= UV ## */
1645 UV auv = SvUVX(TOPm1s);
1646 UV buv = SvUVX(TOPs);
1649 SETs(boolSV(auv >= buv));
1652 if (auvok) { /* ## UV >= IV ## */
1659 /* As (a) is a UV, it's >=0, so it must be >= */
1664 if (auv >= (UV) IV_MAX) {
1665 /* As (b) is an IV, it cannot be > IV_MAX */
1669 SETs(boolSV(auv >= (UV)biv));
1672 { /* ## IV >= UV ## */
1676 aiv = SvIVX(TOPm1s);
1678 /* As (b) is a UV, it's >=0, so a cannot be >= */
1685 if (buv > (UV) IV_MAX) {
1686 /* As (a) is an IV, it cannot be > IV_MAX */
1690 SETs(boolSV((UV)aiv >= buv));
1698 SETs(boolSV(TOPn >= value));
1705 djSP; tryAMAGICbinSET(ne,0);
1706 #ifdef PERL_PRESERVE_IVUV
1709 SvIV_please(TOPm1s);
1710 if (SvIOK(TOPm1s)) {
1711 bool auvok = SvUOK(TOPm1s);
1712 bool buvok = SvUOK(TOPs);
1714 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1715 IV aiv = SvIVX(TOPm1s);
1716 IV biv = SvIVX(TOPs);
1719 SETs(boolSV(aiv != biv));
1722 if (auvok && buvok) { /* ## UV != UV ## */
1723 UV auv = SvUVX(TOPm1s);
1724 UV buv = SvUVX(TOPs);
1727 SETs(boolSV(auv != buv));
1730 { /* ## Mixed IV,UV ## */
1734 /* != is commutative so swap if needed (save code) */
1736 /* swap. top of stack (b) is the iv */
1740 /* As (a) is a UV, it's >0, so it cannot be == */
1749 /* As (b) is a UV, it's >0, so it cannot be == */
1753 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1755 /* we know iv is >= 0 */
1756 if (uv > (UV) IV_MAX) {
1760 SETs(boolSV((UV)iv != uv));
1768 SETs(boolSV(TOPn != value));
1775 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1776 #ifdef PERL_PRESERVE_IVUV
1777 /* Fortunately it seems NaN isn't IOK */
1780 SvIV_please(TOPm1s);
1781 if (SvIOK(TOPm1s)) {
1782 bool leftuvok = SvUOK(TOPm1s);
1783 bool rightuvok = SvUOK(TOPs);
1785 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1786 IV leftiv = SvIVX(TOPm1s);
1787 IV rightiv = SvIVX(TOPs);
1789 if (leftiv > rightiv)
1791 else if (leftiv < rightiv)
1795 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1796 UV leftuv = SvUVX(TOPm1s);
1797 UV rightuv = SvUVX(TOPs);
1799 if (leftuv > rightuv)
1801 else if (leftuv < rightuv)
1805 } else if (leftuvok) { /* ## UV <=> IV ## */
1809 rightiv = SvIVX(TOPs);
1811 /* As (a) is a UV, it's >=0, so it cannot be < */
1814 leftuv = SvUVX(TOPm1s);
1815 if (leftuv > (UV) IV_MAX) {
1816 /* As (b) is an IV, it cannot be > IV_MAX */
1818 } else if (leftuv > (UV)rightiv) {
1820 } else if (leftuv < (UV)rightiv) {
1826 } else { /* ## IV <=> UV ## */
1830 leftiv = SvIVX(TOPm1s);
1832 /* As (b) is a UV, it's >=0, so it must be < */
1835 rightuv = SvUVX(TOPs);
1836 if (rightuv > (UV) IV_MAX) {
1837 /* As (a) is an IV, it cannot be > IV_MAX */
1839 } else if (leftiv > (UV)rightuv) {
1841 } else if (leftiv < (UV)rightuv) {
1859 if (Perl_isnan(left) || Perl_isnan(right)) {
1863 value = (left > right) - (left < right);
1867 else if (left < right)
1869 else if (left > right)
1883 djSP; tryAMAGICbinSET(slt,0);
1886 int cmp = ((PL_op->op_private & OPpLOCALE)
1887 ? sv_cmp_locale(left, right)
1888 : sv_cmp(left, right));
1889 SETs(boolSV(cmp < 0));
1896 djSP; tryAMAGICbinSET(sgt,0);
1899 int cmp = ((PL_op->op_private & OPpLOCALE)
1900 ? sv_cmp_locale(left, right)
1901 : sv_cmp(left, right));
1902 SETs(boolSV(cmp > 0));
1909 djSP; tryAMAGICbinSET(sle,0);
1912 int cmp = ((PL_op->op_private & OPpLOCALE)
1913 ? sv_cmp_locale(left, right)
1914 : sv_cmp(left, right));
1915 SETs(boolSV(cmp <= 0));
1922 djSP; tryAMAGICbinSET(sge,0);
1925 int cmp = ((PL_op->op_private & OPpLOCALE)
1926 ? sv_cmp_locale(left, right)
1927 : sv_cmp(left, right));
1928 SETs(boolSV(cmp >= 0));
1935 djSP; tryAMAGICbinSET(seq,0);
1938 SETs(boolSV(sv_eq(left, right)));
1945 djSP; tryAMAGICbinSET(sne,0);
1948 SETs(boolSV(!sv_eq(left, right)));
1955 djSP; dTARGET; tryAMAGICbin(scmp,0);
1958 int cmp = ((PL_op->op_private & OPpLOCALE)
1959 ? sv_cmp_locale(left, right)
1960 : sv_cmp(left, right));
1968 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1971 if (SvNIOKp(left) || SvNIOKp(right)) {
1972 if (PL_op->op_private & HINT_INTEGER) {
1973 IV i = SvIV(left) & SvIV(right);
1977 UV u = SvUV(left) & SvUV(right);
1982 do_vop(PL_op->op_type, TARG, left, right);
1991 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1994 if (SvNIOKp(left) || SvNIOKp(right)) {
1995 if (PL_op->op_private & HINT_INTEGER) {
1996 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2000 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2005 do_vop(PL_op->op_type, TARG, left, right);
2014 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2017 if (SvNIOKp(left) || SvNIOKp(right)) {
2018 if (PL_op->op_private & HINT_INTEGER) {
2019 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2023 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2028 do_vop(PL_op->op_type, TARG, left, right);
2037 djSP; dTARGET; tryAMAGICun(neg);
2040 int flags = SvFLAGS(sv);
2043 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2044 /* It's publicly an integer, or privately an integer-not-float */
2047 if (SvIVX(sv) == IV_MIN) {
2048 /* 2s complement assumption. */
2049 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2052 else if (SvUVX(sv) <= IV_MAX) {
2057 else if (SvIVX(sv) != IV_MIN) {
2061 #ifdef PERL_PRESERVE_IVUV
2070 else if (SvPOKp(sv)) {
2072 char *s = SvPV(sv, len);
2073 if (isIDFIRST(*s)) {
2074 sv_setpvn(TARG, "-", 1);
2077 else if (*s == '+' || *s == '-') {
2079 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2081 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2082 sv_setpvn(TARG, "-", 1);
2088 goto oops_its_an_int;
2089 sv_setnv(TARG, -SvNV(sv));
2101 djSP; tryAMAGICunSET(not);
2102 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2108 djSP; dTARGET; tryAMAGICun(compl);
2112 if (PL_op->op_private & HINT_INTEGER) {
2127 tmps = (U8*)SvPV_force(TARG, len);
2130 /* Calculate exact length, let's not estimate. */
2139 while (tmps < send) {
2140 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2141 tmps += UTF8SKIP(tmps);
2142 targlen += UNISKIP(~c);
2148 /* Now rewind strings and write them. */
2152 Newz(0, result, targlen + 1, U8);
2153 while (tmps < send) {
2154 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2155 tmps += UTF8SKIP(tmps);
2156 result = uv_to_utf8(result, ~c);
2160 sv_setpvn(TARG, (char*)result, targlen);
2164 Newz(0, result, nchar + 1, U8);
2165 while (tmps < send) {
2166 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
2167 tmps += UTF8SKIP(tmps);
2172 sv_setpvn(TARG, (char*)result, nchar);
2180 register long *tmpl;
2181 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2184 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2189 for ( ; anum > 0; anum--, tmps++)
2198 /* integer versions of some of the above */
2202 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2205 SETi( left * right );
2212 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2216 DIE(aTHX_ "Illegal division by zero");
2217 value = POPi / value;
2225 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2229 DIE(aTHX_ "Illegal modulus zero");
2230 SETi( left % right );
2237 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2240 SETi( left + right );
2247 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2250 SETi( left - right );
2257 djSP; tryAMAGICbinSET(lt,0);
2260 SETs(boolSV(left < right));
2267 djSP; tryAMAGICbinSET(gt,0);
2270 SETs(boolSV(left > right));
2277 djSP; tryAMAGICbinSET(le,0);
2280 SETs(boolSV(left <= right));
2287 djSP; tryAMAGICbinSET(ge,0);
2290 SETs(boolSV(left >= right));
2297 djSP; tryAMAGICbinSET(eq,0);
2300 SETs(boolSV(left == right));
2307 djSP; tryAMAGICbinSET(ne,0);
2310 SETs(boolSV(left != right));
2317 djSP; dTARGET; tryAMAGICbin(ncmp,0);
2324 else if (left < right)
2335 djSP; dTARGET; tryAMAGICun(neg);
2340 /* High falutin' math. */
2344 djSP; dTARGET; tryAMAGICbin(atan2,0);
2347 SETn(Perl_atan2(left, right));
2354 djSP; dTARGET; tryAMAGICun(sin);
2358 value = Perl_sin(value);
2366 djSP; dTARGET; tryAMAGICun(cos);
2370 value = Perl_cos(value);
2376 /* Support Configure command-line overrides for rand() functions.
2377 After 5.005, perhaps we should replace this by Configure support
2378 for drand48(), random(), or rand(). For 5.005, though, maintain
2379 compatibility by calling rand() but allow the user to override it.
2380 See INSTALL for details. --Andy Dougherty 15 July 1998
2382 /* Now it's after 5.005, and Configure supports drand48() and random(),
2383 in addition to rand(). So the overrides should not be needed any more.
2384 --Jarkko Hietaniemi 27 September 1998
2387 #ifndef HAS_DRAND48_PROTO
2388 extern double drand48 (void);
2401 if (!PL_srand_called) {
2402 (void)seedDrand01((Rand_seed_t)seed());
2403 PL_srand_called = TRUE;
2418 (void)seedDrand01((Rand_seed_t)anum);
2419 PL_srand_called = TRUE;
2428 * This is really just a quick hack which grabs various garbage
2429 * values. It really should be a real hash algorithm which
2430 * spreads the effect of every input bit onto every output bit,
2431 * if someone who knows about such things would bother to write it.
2432 * Might be a good idea to add that function to CORE as well.
2433 * No numbers below come from careful analysis or anything here,
2434 * except they are primes and SEED_C1 > 1E6 to get a full-width
2435 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2436 * probably be bigger too.
2439 # define SEED_C1 1000003
2440 #define SEED_C4 73819
2442 # define SEED_C1 25747
2443 #define SEED_C4 20639
2447 #define SEED_C5 26107
2449 #ifndef PERL_NO_DEV_RANDOM
2454 # include <starlet.h>
2455 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2456 * in 100-ns units, typically incremented ever 10 ms. */
2457 unsigned int when[2];
2459 # ifdef HAS_GETTIMEOFDAY
2460 struct timeval when;
2466 /* This test is an escape hatch, this symbol isn't set by Configure. */
2467 #ifndef PERL_NO_DEV_RANDOM
2468 #ifndef PERL_RANDOM_DEVICE
2469 /* /dev/random isn't used by default because reads from it will block
2470 * if there isn't enough entropy available. You can compile with
2471 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2472 * is enough real entropy to fill the seed. */
2473 # define PERL_RANDOM_DEVICE "/dev/urandom"
2475 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2477 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2486 _ckvmssts(sys$gettim(when));
2487 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2489 # ifdef HAS_GETTIMEOFDAY
2490 gettimeofday(&when,(struct timezone *) 0);
2491 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2494 u = (U32)SEED_C1 * when;
2497 u += SEED_C3 * (U32)PerlProc_getpid();
2498 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2499 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2500 u += SEED_C5 * (U32)PTR2UV(&when);
2507 djSP; dTARGET; tryAMAGICun(exp);
2511 value = Perl_exp(value);
2519 djSP; dTARGET; tryAMAGICun(log);
2524 SET_NUMERIC_STANDARD();
2525 DIE(aTHX_ "Can't take log of %g", value);
2527 value = Perl_log(value);
2535 djSP; dTARGET; tryAMAGICun(sqrt);
2540 SET_NUMERIC_STANDARD();
2541 DIE(aTHX_ "Can't take sqrt of %g", value);
2543 value = Perl_sqrt(value);
2551 djSP; dTARGET; tryAMAGICun(int);
2554 IV iv = TOPi; /* attempt to convert to IV if possible. */
2555 /* XXX it's arguable that compiler casting to IV might be subtly
2556 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2557 else preferring IV has introduced a subtle behaviour change bug. OTOH
2558 relying on floating point to be accurate is a bug. */
2569 if (value < (NV)UV_MAX + 0.5) {
2572 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2573 (void)Perl_modf(value, &value);
2575 double tmp = (double)value;
2576 (void)Perl_modf(tmp, &tmp);
2583 if (value > (NV)IV_MIN - 0.5) {
2586 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2587 (void)Perl_modf(-value, &value);
2590 double tmp = (double)value;
2591 (void)Perl_modf(-tmp, &tmp);
2604 djSP; dTARGET; tryAMAGICun(abs);
2606 /* This will cache the NV value if string isn't actually integer */
2610 /* IVX is precise */
2612 SETu(TOPu); /* force it to be numeric only */
2620 /* 2s complement assumption. Also, not really needed as
2621 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2644 argtype = 1; /* allow underscores */
2645 XPUSHn(scan_hex(tmps, 99, &argtype));
2658 while (*tmps && isSPACE(*tmps))
2662 argtype = 1; /* allow underscores */
2664 value = scan_hex(++tmps, 99, &argtype);
2665 else if (*tmps == 'b')
2666 value = scan_bin(++tmps, 99, &argtype);
2668 value = scan_oct(tmps, 99, &argtype);
2681 SETi(sv_len_utf8(sv));
2697 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2699 I32 arybase = PL_curcop->cop_arybase;
2702 int num_args = PL_op->op_private & 7;
2704 SvTAINTED_off(TARG); /* decontaminate */
2705 SvUTF8_off(TARG); /* decontaminate */
2709 repl = SvPV(sv, repl_len);
2716 tmps = SvPV(sv, curlen);
2718 utfcurlen = sv_len_utf8(sv);
2719 if (utfcurlen == curlen)
2727 if (pos >= arybase) {
2745 else if (len >= 0) {
2747 if (rem > (I32)curlen)
2762 Perl_croak(aTHX_ "substr outside of string");
2763 if (ckWARN(WARN_SUBSTR))
2764 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2771 sv_pos_u2b(sv, &pos, &rem);
2773 sv_setpvn(TARG, tmps, rem);
2777 sv_insert(sv, pos, rem, repl, repl_len);
2778 else if (lvalue) { /* it's an lvalue! */
2779 if (!SvGMAGICAL(sv)) {
2783 if (ckWARN(WARN_SUBSTR))
2784 Perl_warner(aTHX_ WARN_SUBSTR,
2785 "Attempt to use reference as lvalue in substr");
2787 if (SvOK(sv)) /* is it defined ? */
2788 (void)SvPOK_only_UTF8(sv);
2790 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2793 if (SvTYPE(TARG) < SVt_PVLV) {
2794 sv_upgrade(TARG, SVt_PVLV);
2795 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2799 if (LvTARG(TARG) != sv) {
2801 SvREFCNT_dec(LvTARG(TARG));
2802 LvTARG(TARG) = SvREFCNT_inc(sv);
2804 LvTARGOFF(TARG) = upos;
2805 LvTARGLEN(TARG) = urem;
2809 PUSHs(TARG); /* avoid SvSETMAGIC here */
2816 register IV size = POPi;
2817 register IV offset = POPi;
2818 register SV *src = POPs;
2819 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2821 SvTAINTED_off(TARG); /* decontaminate */
2822 if (lvalue) { /* it's an lvalue! */
2823 if (SvTYPE(TARG) < SVt_PVLV) {
2824 sv_upgrade(TARG, SVt_PVLV);
2825 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2828 if (LvTARG(TARG) != src) {
2830 SvREFCNT_dec(LvTARG(TARG));
2831 LvTARG(TARG) = SvREFCNT_inc(src);
2833 LvTARGOFF(TARG) = offset;
2834 LvTARGLEN(TARG) = size;
2837 sv_setuv(TARG, do_vecget(src, offset, size));
2852 I32 arybase = PL_curcop->cop_arybase;
2857 offset = POPi - arybase;
2860 tmps = SvPV(big, biglen);
2861 if (offset > 0 && DO_UTF8(big))
2862 sv_pos_u2b(big, &offset, 0);
2865 else if (offset > biglen)
2867 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2868 (unsigned char*)tmps + biglen, little, 0)))
2871 retval = tmps2 - tmps;
2872 if (retval > 0 && DO_UTF8(big))
2873 sv_pos_b2u(big, &retval);
2874 PUSHi(retval + arybase);
2889 I32 arybase = PL_curcop->cop_arybase;
2895 tmps2 = SvPV(little, llen);
2896 tmps = SvPV(big, blen);
2900 if (offset > 0 && DO_UTF8(big))
2901 sv_pos_u2b(big, &offset, 0);
2902 offset = offset - arybase + llen;
2906 else if (offset > blen)
2908 if (!(tmps2 = rninstr(tmps, tmps + offset,
2909 tmps2, tmps2 + llen)))
2912 retval = tmps2 - tmps;
2913 if (retval > 0 && DO_UTF8(big))
2914 sv_pos_b2u(big, &retval);
2915 PUSHi(retval + arybase);
2921 djSP; dMARK; dORIGMARK; dTARGET;
2922 do_sprintf(TARG, SP-MARK, MARK+1);
2923 TAINT_IF(SvTAINTED(TARG));
2934 U8 *s = (U8*)SvPVx(argsv, len);
2936 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
2946 (void)SvUPGRADE(TARG,SVt_PV);
2948 if (value > 255 && !IN_BYTE) {
2949 SvGROW(TARG, UNISKIP(value)+1);
2950 tmps = (char*)uv_to_utf8((U8*)SvPVX(TARG), value);
2951 SvCUR_set(TARG, tmps - SvPVX(TARG));
2953 (void)SvPOK_only(TARG);
2964 (void)SvPOK_only(TARG);
2971 djSP; dTARGET; dPOPTOPssrl;
2974 char *tmps = SvPV(left, n_a);
2976 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2978 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2982 "The crypt() function is unimplemented due to excessive paranoia.");
2995 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
2997 U8 tmpbuf[UTF8_MAXLEN+1];
2999 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3001 if (PL_op->op_private & OPpLOCALE) {
3004 uv = toTITLE_LC_uni(uv);
3007 uv = toTITLE_utf8(s);
3009 tend = uv_to_utf8(tmpbuf, uv);
3011 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3013 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3014 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3019 s = (U8*)SvPV_force(sv, slen);
3020 Copy(tmpbuf, s, ulen, U8);
3024 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3026 SvUTF8_off(TARG); /* decontaminate */
3031 s = (U8*)SvPV_force(sv, slen);
3033 if (PL_op->op_private & OPpLOCALE) {
3036 *s = toUPPER_LC(*s);
3054 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3056 U8 tmpbuf[UTF8_MAXLEN+1];
3058 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3060 if (PL_op->op_private & OPpLOCALE) {
3063 uv = toLOWER_LC_uni(uv);
3066 uv = toLOWER_utf8(s);
3068 tend = uv_to_utf8(tmpbuf, uv);
3070 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3072 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3073 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3078 s = (U8*)SvPV_force(sv, slen);
3079 Copy(tmpbuf, s, ulen, U8);
3083 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3085 SvUTF8_off(TARG); /* decontaminate */
3090 s = (U8*)SvPV_force(sv, slen);
3092 if (PL_op->op_private & OPpLOCALE) {
3095 *s = toLOWER_LC(*s);
3119 s = (U8*)SvPV(sv,len);
3121 SvUTF8_off(TARG); /* decontaminate */
3122 sv_setpvn(TARG, "", 0);
3126 (void)SvUPGRADE(TARG, SVt_PV);
3127 SvGROW(TARG, (len * 2) + 1);
3128 (void)SvPOK_only(TARG);
3129 d = (U8*)SvPVX(TARG);
3131 if (PL_op->op_private & OPpLOCALE) {
3135 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3141 d = uv_to_utf8(d, toUPPER_utf8( s ));
3147 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3152 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3154 SvUTF8_off(TARG); /* decontaminate */
3159 s = (U8*)SvPV_force(sv, len);
3161 register U8 *send = s + len;
3163 if (PL_op->op_private & OPpLOCALE) {
3166 for (; s < send; s++)
3167 *s = toUPPER_LC(*s);
3170 for (; s < send; s++)
3193 s = (U8*)SvPV(sv,len);
3195 SvUTF8_off(TARG); /* decontaminate */
3196 sv_setpvn(TARG, "", 0);
3200 (void)SvUPGRADE(TARG, SVt_PV);
3201 SvGROW(TARG, (len * 2) + 1);
3202 (void)SvPOK_only(TARG);
3203 d = (U8*)SvPVX(TARG);
3205 if (PL_op->op_private & OPpLOCALE) {
3209 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3215 d = uv_to_utf8(d, toLOWER_utf8(s));
3221 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3226 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3228 SvUTF8_off(TARG); /* decontaminate */
3234 s = (U8*)SvPV_force(sv, len);
3236 register U8 *send = s + len;
3238 if (PL_op->op_private & OPpLOCALE) {
3241 for (; s < send; s++)
3242 *s = toLOWER_LC(*s);
3245 for (; s < send; s++)
3260 register char *s = SvPV(sv,len);
3263 SvUTF8_off(TARG); /* decontaminate */
3265 (void)SvUPGRADE(TARG, SVt_PV);
3266 SvGROW(TARG, (len * 2) + 1);
3270 if (UTF8_IS_CONTINUED(*s)) {
3271 STRLEN ulen = UTF8SKIP(s);
3295 SvCUR_set(TARG, d - SvPVX(TARG));
3296 (void)SvPOK_only_UTF8(TARG);
3299 sv_setpvn(TARG, s, len);
3301 if (SvSMAGICAL(TARG))
3310 djSP; dMARK; dORIGMARK;
3312 register AV* av = (AV*)POPs;
3313 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3314 I32 arybase = PL_curcop->cop_arybase;
3317 if (SvTYPE(av) == SVt_PVAV) {
3318 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3320 for (svp = MARK + 1; svp <= SP; svp++) {
3325 if (max > AvMAX(av))
3328 while (++MARK <= SP) {
3329 elem = SvIVx(*MARK);
3333 svp = av_fetch(av, elem, lval);
3335 if (!svp || *svp == &PL_sv_undef)
3336 DIE(aTHX_ PL_no_aelem, elem);
3337 if (PL_op->op_private & OPpLVAL_INTRO)
3338 save_aelem(av, elem, svp);
3340 *MARK = svp ? *svp : &PL_sv_undef;
3343 if (GIMME != G_ARRAY) {
3351 /* Associative arrays. */
3356 HV *hash = (HV*)POPs;
3358 I32 gimme = GIMME_V;
3359 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3362 /* might clobber stack_sp */
3363 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3368 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3369 if (gimme == G_ARRAY) {
3372 /* might clobber stack_sp */
3374 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3379 else if (gimme == G_SCALAR)
3398 I32 gimme = GIMME_V;
3399 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3403 if (PL_op->op_private & OPpSLICE) {
3407 hvtype = SvTYPE(hv);
3408 if (hvtype == SVt_PVHV) { /* hash element */
3409 while (++MARK <= SP) {
3410 sv = hv_delete_ent(hv, *MARK, discard, 0);
3411 *MARK = sv ? sv : &PL_sv_undef;
3414 else if (hvtype == SVt_PVAV) {
3415 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3416 while (++MARK <= SP) {
3417 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3418 *MARK = sv ? sv : &PL_sv_undef;
3421 else { /* pseudo-hash element */
3422 while (++MARK <= SP) {
3423 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3424 *MARK = sv ? sv : &PL_sv_undef;
3429 DIE(aTHX_ "Not a HASH reference");
3432 else if (gimme == G_SCALAR) {
3441 if (SvTYPE(hv) == SVt_PVHV)
3442 sv = hv_delete_ent(hv, keysv, discard, 0);
3443 else if (SvTYPE(hv) == SVt_PVAV) {
3444 if (PL_op->op_flags & OPf_SPECIAL)
3445 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3447 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3450 DIE(aTHX_ "Not a HASH reference");
3465 if (PL_op->op_private & OPpEXISTS_SUB) {
3469 cv = sv_2cv(sv, &hv, &gv, FALSE);
3472 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3478 if (SvTYPE(hv) == SVt_PVHV) {
3479 if (hv_exists_ent(hv, tmpsv, 0))
3482 else if (SvTYPE(hv) == SVt_PVAV) {
3483 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3484 if (av_exists((AV*)hv, SvIV(tmpsv)))
3487 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3491 DIE(aTHX_ "Not a HASH reference");
3498 djSP; dMARK; dORIGMARK;
3499 register HV *hv = (HV*)POPs;
3500 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3501 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3503 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3504 DIE(aTHX_ "Can't localize pseudo-hash element");
3506 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3507 while (++MARK <= SP) {
3510 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3512 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3513 svp = he ? &HeVAL(he) : 0;
3516 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3519 if (!svp || *svp == &PL_sv_undef) {
3521 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3523 if (PL_op->op_private & OPpLVAL_INTRO) {
3525 save_helem(hv, keysv, svp);
3528 char *key = SvPV(keysv, keylen);
3529 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3533 *MARK = svp ? *svp : &PL_sv_undef;
3536 if (GIMME != G_ARRAY) {
3544 /* List operators. */
3549 if (GIMME != G_ARRAY) {
3551 *MARK = *SP; /* unwanted list, return last item */
3553 *MARK = &PL_sv_undef;
3562 SV **lastrelem = PL_stack_sp;
3563 SV **lastlelem = PL_stack_base + POPMARK;
3564 SV **firstlelem = PL_stack_base + POPMARK + 1;
3565 register SV **firstrelem = lastlelem + 1;
3566 I32 arybase = PL_curcop->cop_arybase;
3567 I32 lval = PL_op->op_flags & OPf_MOD;
3568 I32 is_something_there = lval;
3570 register I32 max = lastrelem - lastlelem;
3571 register SV **lelem;
3574 if (GIMME != G_ARRAY) {
3575 ix = SvIVx(*lastlelem);
3580 if (ix < 0 || ix >= max)
3581 *firstlelem = &PL_sv_undef;
3583 *firstlelem = firstrelem[ix];
3589 SP = firstlelem - 1;
3593 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3599 if (ix < 0 || ix >= max)
3600 *lelem = &PL_sv_undef;
3602 is_something_there = TRUE;
3603 if (!(*lelem = firstrelem[ix]))
3604 *lelem = &PL_sv_undef;
3607 if (is_something_there)
3610 SP = firstlelem - 1;
3616 djSP; dMARK; dORIGMARK;
3617 I32 items = SP - MARK;
3618 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3619 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3626 djSP; dMARK; dORIGMARK;
3627 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3631 SV *val = NEWSV(46, 0);
3633 sv_setsv(val, *++MARK);
3634 else if (ckWARN(WARN_MISC))
3635 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3636 (void)hv_store_ent(hv,key,val,0);
3645 djSP; dMARK; dORIGMARK;
3646 register AV *ary = (AV*)*++MARK;
3650 register I32 offset;
3651 register I32 length;
3658 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3659 *MARK-- = SvTIED_obj((SV*)ary, mg);
3663 call_method("SPLICE",GIMME_V);
3672 offset = i = SvIVx(*MARK);
3674 offset += AvFILLp(ary) + 1;
3676 offset -= PL_curcop->cop_arybase;
3678 DIE(aTHX_ PL_no_aelem, i);
3680 length = SvIVx(*MARK++);
3682 length += AvFILLp(ary) - offset + 1;
3688 length = AvMAX(ary) + 1; /* close enough to infinity */
3692 length = AvMAX(ary) + 1;
3694 if (offset > AvFILLp(ary) + 1)
3695 offset = AvFILLp(ary) + 1;
3696 after = AvFILLp(ary) + 1 - (offset + length);
3697 if (after < 0) { /* not that much array */
3698 length += after; /* offset+length now in array */
3704 /* At this point, MARK .. SP-1 is our new LIST */
3707 diff = newlen - length;
3708 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3711 if (diff < 0) { /* shrinking the area */
3713 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3714 Copy(MARK, tmparyval, newlen, SV*);
3717 MARK = ORIGMARK + 1;
3718 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3719 MEXTEND(MARK, length);
3720 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3722 EXTEND_MORTAL(length);
3723 for (i = length, dst = MARK; i; i--) {
3724 sv_2mortal(*dst); /* free them eventualy */
3731 *MARK = AvARRAY(ary)[offset+length-1];
3734 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3735 SvREFCNT_dec(*dst++); /* free them now */
3738 AvFILLp(ary) += diff;
3740 /* pull up or down? */
3742 if (offset < after) { /* easier to pull up */
3743 if (offset) { /* esp. if nothing to pull */
3744 src = &AvARRAY(ary)[offset-1];
3745 dst = src - diff; /* diff is negative */
3746 for (i = offset; i > 0; i--) /* can't trust Copy */
3750 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3754 if (after) { /* anything to pull down? */
3755 src = AvARRAY(ary) + offset + length;
3756 dst = src + diff; /* diff is negative */
3757 Move(src, dst, after, SV*);
3759 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3760 /* avoid later double free */
3764 dst[--i] = &PL_sv_undef;
3767 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3769 *dst = NEWSV(46, 0);
3770 sv_setsv(*dst++, *src++);
3772 Safefree(tmparyval);
3775 else { /* no, expanding (or same) */
3777 New(452, tmparyval, length, SV*); /* so remember deletion */
3778 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3781 if (diff > 0) { /* expanding */
3783 /* push up or down? */
3785 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3789 Move(src, dst, offset, SV*);
3791 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3793 AvFILLp(ary) += diff;
3796 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3797 av_extend(ary, AvFILLp(ary) + diff);
3798 AvFILLp(ary) += diff;
3801 dst = AvARRAY(ary) + AvFILLp(ary);
3803 for (i = after; i; i--) {
3810 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3811 *dst = NEWSV(46, 0);
3812 sv_setsv(*dst++, *src++);
3814 MARK = ORIGMARK + 1;
3815 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3817 Copy(tmparyval, MARK, length, SV*);
3819 EXTEND_MORTAL(length);
3820 for (i = length, dst = MARK; i; i--) {
3821 sv_2mortal(*dst); /* free them eventualy */
3825 Safefree(tmparyval);
3829 else if (length--) {
3830 *MARK = tmparyval[length];
3833 while (length-- > 0)
3834 SvREFCNT_dec(tmparyval[length]);
3836 Safefree(tmparyval);
3839 *MARK = &PL_sv_undef;
3847 djSP; dMARK; dORIGMARK; dTARGET;
3848 register AV *ary = (AV*)*++MARK;
3849 register SV *sv = &PL_sv_undef;
3852 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3853 *MARK-- = SvTIED_obj((SV*)ary, mg);
3857 call_method("PUSH",G_SCALAR|G_DISCARD);
3862 /* Why no pre-extend of ary here ? */
3863 for (++MARK; MARK <= SP; MARK++) {
3866 sv_setsv(sv, *MARK);
3871 PUSHi( AvFILL(ary) + 1 );
3879 SV *sv = av_pop(av);
3881 (void)sv_2mortal(sv);
3890 SV *sv = av_shift(av);
3895 (void)sv_2mortal(sv);
3902 djSP; dMARK; dORIGMARK; dTARGET;
3903 register AV *ary = (AV*)*++MARK;
3908 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3909 *MARK-- = SvTIED_obj((SV*)ary, mg);
3913 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3918 av_unshift(ary, SP - MARK);
3921 sv_setsv(sv, *++MARK);
3922 (void)av_store(ary, i++, sv);
3926 PUSHi( AvFILL(ary) + 1 );
3936 if (GIMME == G_ARRAY) {
3943 /* safe as long as stack cannot get extended in the above */
3948 register char *down;
3953 SvUTF8_off(TARG); /* decontaminate */
3955 do_join(TARG, &PL_sv_no, MARK, SP);
3957 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3958 up = SvPV_force(TARG, len);
3960 if (DO_UTF8(TARG)) { /* first reverse each character */
3961 U8* s = (U8*)SvPVX(TARG);
3962 U8* send = (U8*)(s + len);
3964 if (UTF8_IS_ASCII(*s)) {
3969 if (!utf8_to_uv_simple(s, 0))
3973 down = (char*)(s - 1);
3974 /* reverse this character */
3984 down = SvPVX(TARG) + len - 1;
3990 (void)SvPOK_only_UTF8(TARG);
3999 S_mul128(pTHX_ SV *sv, U8 m)
4002 char *s = SvPV(sv, len);
4006 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4007 SV *tmpNew = newSVpvn("0000000000", 10);
4009 sv_catsv(tmpNew, sv);
4010 SvREFCNT_dec(sv); /* free old sv */
4015 while (!*t) /* trailing '\0'? */
4018 i = ((*t - '0') << 7) + m;
4019 *(t--) = '0' + (i % 10);
4025 /* Explosives and implosives. */
4027 #if 'I' == 73 && 'J' == 74
4028 /* On an ASCII/ISO kind of system */
4029 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4032 Some other sort of character set - use memchr() so we don't match
4035 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4042 I32 start_sp_offset = SP - PL_stack_base;
4043 I32 gimme = GIMME_V;
4047 register char *pat = SvPV(left, llen);
4048 register char *s = SvPV(right, rlen);
4049 char *strend = s + rlen;
4051 register char *patend = pat + llen;
4057 /* 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));
4333 if (len > strend - s)
4336 if (DO_UTF8(right)) {
4339 auv = utf8_to_uv((U8*)s, strend - s,
4340 &l, UTF8_ALLOW_ANYUV);
4352 auint = *s++ & 0xFF;
4360 if (DO_UTF8(right)) {
4363 auv = utf8_to_uv((U8*)s, strend - s,
4364 &l, UTF8_ALLOW_ANYUV);
4367 PUSHs(sv_2mortal(sv));
4374 auint = *s++ & 0xFF;
4376 sv_setuv(sv, auint);
4377 PUSHs(sv_2mortal(sv));
4383 #if SHORTSIZE == SIZE16
4384 along = (strend - s) / SIZE16;
4386 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4391 #if SHORTSIZE != SIZE16
4395 COPYNN(s, &ashort, sizeof(short));
4406 #if SHORTSIZE > SIZE16
4418 #if SHORTSIZE != SIZE16
4422 COPYNN(s, &ashort, sizeof(short));
4425 sv_setiv(sv, (IV)ashort);
4426 PUSHs(sv_2mortal(sv));
4434 #if SHORTSIZE > SIZE16
4440 sv_setiv(sv, (IV)ashort);
4441 PUSHs(sv_2mortal(sv));
4449 #if SHORTSIZE == SIZE16
4450 along = (strend - s) / SIZE16;
4452 unatint = natint && datumtype == 'S';
4453 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4458 #if SHORTSIZE != SIZE16
4460 unsigned short aushort;
4462 COPYNN(s, &aushort, sizeof(unsigned short));
4463 s += sizeof(unsigned short);
4471 COPY16(s, &aushort);
4474 if (datumtype == 'n')
4475 aushort = PerlSock_ntohs(aushort);
4478 if (datumtype == 'v')
4479 aushort = vtohs(aushort);
4488 #if SHORTSIZE != SIZE16
4490 unsigned short aushort;
4492 COPYNN(s, &aushort, sizeof(unsigned short));
4493 s += sizeof(unsigned short);
4495 sv_setiv(sv, (UV)aushort);
4496 PUSHs(sv_2mortal(sv));
4503 COPY16(s, &aushort);
4507 if (datumtype == 'n')
4508 aushort = PerlSock_ntohs(aushort);
4511 if (datumtype == 'v')
4512 aushort = vtohs(aushort);
4514 sv_setiv(sv, (UV)aushort);
4515 PUSHs(sv_2mortal(sv));
4521 along = (strend - s) / sizeof(int);
4526 Copy(s, &aint, 1, int);
4529 cdouble += (NV)aint;
4538 Copy(s, &aint, 1, int);
4542 /* Without the dummy below unpack("i", pack("i",-1))
4543 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4544 * cc with optimization turned on.
4546 * The bug was detected in
4547 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4548 * with optimization (-O4) turned on.
4549 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4550 * does not have this problem even with -O4.
4552 * This bug was reported as DECC_BUGS 1431
4553 * and tracked internally as GEM_BUGS 7775.
4555 * The bug is fixed in
4556 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4557 * UNIX V4.0F support: DEC C V5.9-006 or later
4558 * UNIX V4.0E support: DEC C V5.8-011 or later
4561 * See also few lines later for the same bug.
4564 sv_setiv(sv, (IV)aint) :
4566 sv_setiv(sv, (IV)aint);
4567 PUSHs(sv_2mortal(sv));
4572 along = (strend - s) / sizeof(unsigned int);
4577 Copy(s, &auint, 1, unsigned int);
4578 s += sizeof(unsigned int);
4580 cdouble += (NV)auint;
4589 Copy(s, &auint, 1, unsigned int);
4590 s += sizeof(unsigned int);
4593 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4594 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4595 * See details few lines earlier. */
4597 sv_setuv(sv, (UV)auint) :
4599 sv_setuv(sv, (UV)auint);
4600 PUSHs(sv_2mortal(sv));
4605 #if LONGSIZE == SIZE32
4606 along = (strend - s) / SIZE32;
4608 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4613 #if LONGSIZE != SIZE32
4616 COPYNN(s, &along, sizeof(long));
4619 cdouble += (NV)along;
4628 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4632 #if LONGSIZE > SIZE32
4633 if (along > 2147483647)
4634 along -= 4294967296;
4638 cdouble += (NV)along;
4647 #if LONGSIZE != SIZE32
4650 COPYNN(s, &along, sizeof(long));
4653 sv_setiv(sv, (IV)along);
4654 PUSHs(sv_2mortal(sv));
4661 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4665 #if LONGSIZE > SIZE32
4666 if (along > 2147483647)
4667 along -= 4294967296;
4671 sv_setiv(sv, (IV)along);
4672 PUSHs(sv_2mortal(sv));
4680 #if LONGSIZE == SIZE32
4681 along = (strend - s) / SIZE32;
4683 unatint = natint && datumtype == 'L';
4684 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4689 #if LONGSIZE != SIZE32
4691 unsigned long aulong;
4693 COPYNN(s, &aulong, sizeof(unsigned long));
4694 s += sizeof(unsigned long);
4696 cdouble += (NV)aulong;
4708 if (datumtype == 'N')
4709 aulong = PerlSock_ntohl(aulong);
4712 if (datumtype == 'V')
4713 aulong = vtohl(aulong);
4716 cdouble += (NV)aulong;
4725 #if LONGSIZE != SIZE32
4727 unsigned long aulong;
4729 COPYNN(s, &aulong, sizeof(unsigned long));
4730 s += sizeof(unsigned long);
4732 sv_setuv(sv, (UV)aulong);
4733 PUSHs(sv_2mortal(sv));
4743 if (datumtype == 'N')
4744 aulong = PerlSock_ntohl(aulong);
4747 if (datumtype == 'V')
4748 aulong = vtohl(aulong);
4751 sv_setuv(sv, (UV)aulong);
4752 PUSHs(sv_2mortal(sv));
4758 along = (strend - s) / sizeof(char*);
4764 if (sizeof(char*) > strend - s)
4767 Copy(s, &aptr, 1, char*);
4773 PUSHs(sv_2mortal(sv));
4783 while ((len > 0) && (s < strend)) {
4784 auv = (auv << 7) | (*s & 0x7f);
4785 if (UTF8_IS_ASCII(*s++)) {
4789 PUSHs(sv_2mortal(sv));
4793 else if (++bytes >= sizeof(UV)) { /* promote to string */
4797 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4798 while (s < strend) {
4799 sv = mul128(sv, *s & 0x7f);
4800 if (!(*s++ & 0x80)) {
4809 PUSHs(sv_2mortal(sv));
4814 if ((s >= strend) && bytes)
4815 DIE(aTHX_ "Unterminated compressed integer");
4820 if (sizeof(char*) > strend - s)
4823 Copy(s, &aptr, 1, char*);
4828 sv_setpvn(sv, aptr, len);
4829 PUSHs(sv_2mortal(sv));
4833 along = (strend - s) / sizeof(Quad_t);
4839 if (s + sizeof(Quad_t) > strend)
4842 Copy(s, &aquad, 1, Quad_t);
4843 s += sizeof(Quad_t);
4846 if (aquad >= IV_MIN && aquad <= IV_MAX)
4847 sv_setiv(sv, (IV)aquad);
4849 sv_setnv(sv, (NV)aquad);
4850 PUSHs(sv_2mortal(sv));
4854 along = (strend - s) / sizeof(Quad_t);
4860 if (s + sizeof(Uquad_t) > strend)
4863 Copy(s, &auquad, 1, Uquad_t);
4864 s += sizeof(Uquad_t);
4867 if (auquad <= UV_MAX)
4868 sv_setuv(sv, (UV)auquad);
4870 sv_setnv(sv, (NV)auquad);
4871 PUSHs(sv_2mortal(sv));
4875 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4878 along = (strend - s) / sizeof(float);
4883 Copy(s, &afloat, 1, float);
4892 Copy(s, &afloat, 1, float);
4895 sv_setnv(sv, (NV)afloat);
4896 PUSHs(sv_2mortal(sv));
4902 along = (strend - s) / sizeof(double);
4907 Copy(s, &adouble, 1, double);
4908 s += sizeof(double);
4916 Copy(s, &adouble, 1, double);
4917 s += sizeof(double);
4919 sv_setnv(sv, (NV)adouble);
4920 PUSHs(sv_2mortal(sv));
4926 * Initialise the decode mapping. By using a table driven
4927 * algorithm, the code will be character-set independent
4928 * (and just as fast as doing character arithmetic)
4930 if (PL_uudmap['M'] == 0) {
4933 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4934 PL_uudmap[(U8)PL_uuemap[i]] = i;
4936 * Because ' ' and '`' map to the same value,
4937 * we need to decode them both the same.
4942 along = (strend - s) * 3 / 4;
4943 sv = NEWSV(42, along);
4946 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4951 len = PL_uudmap[*(U8*)s++] & 077;
4953 if (s < strend && ISUUCHAR(*s))
4954 a = PL_uudmap[*(U8*)s++] & 077;
4957 if (s < strend && ISUUCHAR(*s))
4958 b = PL_uudmap[*(U8*)s++] & 077;
4961 if (s < strend && ISUUCHAR(*s))
4962 c = PL_uudmap[*(U8*)s++] & 077;
4965 if (s < strend && ISUUCHAR(*s))
4966 d = PL_uudmap[*(U8*)s++] & 077;
4969 hunk[0] = (a << 2) | (b >> 4);
4970 hunk[1] = (b << 4) | (c >> 2);
4971 hunk[2] = (c << 6) | d;
4972 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4977 else if (s[1] == '\n') /* possible checksum byte */
4980 XPUSHs(sv_2mortal(sv));
4985 if (strchr("fFdD", datumtype) ||
4986 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4990 while (checksum >= 16) {
4994 while (checksum >= 4) {
5000 along = (1 << checksum) - 1;
5001 while (cdouble < 0.0)
5003 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5004 sv_setnv(sv, cdouble);
5007 if (checksum < 32) {
5008 aulong = (1 << checksum) - 1;
5011 sv_setuv(sv, (UV)culong);
5013 XPUSHs(sv_2mortal(sv));
5017 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5018 PUSHs(&PL_sv_undef);
5023 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5027 *hunk = PL_uuemap[len];
5028 sv_catpvn(sv, hunk, 1);
5031 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5032 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5033 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5034 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5035 sv_catpvn(sv, hunk, 4);
5040 char r = (len > 1 ? s[1] : '\0');
5041 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5042 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5043 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5044 hunk[3] = PL_uuemap[0];
5045 sv_catpvn(sv, hunk, 4);
5047 sv_catpvn(sv, "\n", 1);
5051 S_is_an_int(pTHX_ char *s, STRLEN l)
5054 SV *result = newSVpvn(s, l);
5055 char *result_c = SvPV(result, n_a); /* convenience */
5056 char *out = result_c;
5066 SvREFCNT_dec(result);
5089 SvREFCNT_dec(result);
5095 SvCUR_set(result, out - result_c);
5099 /* pnum must be '\0' terminated */
5101 S_div128(pTHX_ SV *pnum, bool *done)
5104 char *s = SvPV(pnum, len);
5113 i = m * 10 + (*t - '0');
5115 r = (i >> 7); /* r < 10 */
5122 SvCUR_set(pnum, (STRLEN) (t - s));
5129 djSP; dMARK; dORIGMARK; dTARGET;
5130 register SV *cat = TARG;
5133 register char *pat = SvPVx(*++MARK, fromlen);
5135 register char *patend = pat + fromlen;
5140 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5141 static char *space10 = " ";
5143 /* These must not be in registers: */
5159 #ifdef PERL_NATINT_PACK
5160 int natint; /* native integer */
5166 sv_setpvn(cat, "", 0);
5168 while (pat < patend) {
5169 SV *lengthcode = Nullsv;
5170 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5171 datumtype = *pat++ & 0xFF;
5172 #ifdef PERL_NATINT_PACK
5175 if (isSPACE(datumtype)) {
5179 if (datumtype == 'U' && pat == patcopy+1)
5181 if (datumtype == '#') {
5182 while (pat < patend && *pat != '\n')
5187 char *natstr = "sSiIlL";
5189 if (strchr(natstr, datumtype)) {
5190 #ifdef PERL_NATINT_PACK
5196 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5199 len = strchr("@Xxu", datumtype) ? 0 : items;
5202 else if (isDIGIT(*pat)) {
5204 while (isDIGIT(*pat)) {
5205 len = (len * 10) + (*pat++ - '0');
5207 DIE(aTHX_ "Repeat count in pack overflows");
5214 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5215 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5216 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5217 ? *MARK : &PL_sv_no)
5218 + (*pat == 'Z' ? 1 : 0)));
5222 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5223 case ',': /* grandfather in commas but with a warning */
5224 if (commas++ == 0 && ckWARN(WARN_PACK))
5225 Perl_warner(aTHX_ WARN_PACK,
5226 "Invalid type in pack: '%c'", (int)datumtype);
5229 DIE(aTHX_ "%% may only be used in unpack");
5240 if (SvCUR(cat) < len)
5241 DIE(aTHX_ "X outside of string");
5248 sv_catpvn(cat, null10, 10);
5251 sv_catpvn(cat, null10, len);
5257 aptr = SvPV(fromstr, fromlen);
5258 if (pat[-1] == '*') {
5260 if (datumtype == 'Z')
5263 if (fromlen >= len) {
5264 sv_catpvn(cat, aptr, len);
5265 if (datumtype == 'Z')
5266 *(SvEND(cat)-1) = '\0';
5269 sv_catpvn(cat, aptr, fromlen);
5271 if (datumtype == 'A') {
5273 sv_catpvn(cat, space10, 10);
5276 sv_catpvn(cat, space10, len);
5280 sv_catpvn(cat, null10, 10);
5283 sv_catpvn(cat, null10, len);
5295 str = SvPV(fromstr, fromlen);
5299 SvCUR(cat) += (len+7)/8;
5300 SvGROW(cat, SvCUR(cat) + 1);
5301 aptr = SvPVX(cat) + aint;
5306 if (datumtype == 'B') {
5307 for (len = 0; len++ < aint;) {
5308 items |= *str++ & 1;
5312 *aptr++ = items & 0xff;
5318 for (len = 0; len++ < aint;) {
5324 *aptr++ = items & 0xff;
5330 if (datumtype == 'B')
5331 items <<= 7 - (aint & 7);
5333 items >>= 7 - (aint & 7);
5334 *aptr++ = items & 0xff;
5336 str = SvPVX(cat) + SvCUR(cat);
5351 str = SvPV(fromstr, fromlen);
5355 SvCUR(cat) += (len+1)/2;
5356 SvGROW(cat, SvCUR(cat) + 1);
5357 aptr = SvPVX(cat) + aint;
5362 if (datumtype == 'H') {
5363 for (len = 0; len++ < aint;) {
5365 items |= ((*str++ & 15) + 9) & 15;
5367 items |= *str++ & 15;
5371 *aptr++ = items & 0xff;
5377 for (len = 0; len++ < aint;) {
5379 items |= (((*str++ & 15) + 9) & 15) << 4;
5381 items |= (*str++ & 15) << 4;
5385 *aptr++ = items & 0xff;
5391 *aptr++ = items & 0xff;
5392 str = SvPVX(cat) + SvCUR(cat);
5402 aint = SvIV(fromstr);
5404 sv_catpvn(cat, &achar, sizeof(char));
5408 has_utf8 = SvUTF8(cat);
5411 auv = SvUV(fromstr);
5412 if (!has_utf8 && auv > 0xFF && !IN_BYTE) {
5415 sv_utf8_upgrade(cat);
5417 SvUTF8_on(cat); /* There will be UTF8. */
5420 SvGROW(cat, SvCUR(cat) + UNISKIP(auv) + 1);
5421 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auv)
5426 sv_catpvn(cat, &achar, sizeof(char));
5432 has_utf8 = SvUTF8(cat);
5435 auv = SvUV(fromstr);
5436 if (!has_utf8 && auv > 0x80) {
5438 sv_utf8_upgrade(cat);
5440 SvGROW(cat, SvCUR(cat) + UNISKIP(auv) + 1);
5441 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auv)
5446 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5451 afloat = (float)SvNV(fromstr);
5452 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5459 adouble = (double)SvNV(fromstr);
5460 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5466 ashort = (I16)SvIV(fromstr);
5468 ashort = PerlSock_htons(ashort);
5470 CAT16(cat, &ashort);
5476 ashort = (I16)SvIV(fromstr);
5478 ashort = htovs(ashort);
5480 CAT16(cat, &ashort);
5484 #if SHORTSIZE != SIZE16
5486 unsigned short aushort;
5490 aushort = SvUV(fromstr);
5491 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5501 aushort = (U16)SvUV(fromstr);
5502 CAT16(cat, &aushort);
5508 #if SHORTSIZE != SIZE16
5514 ashort = SvIV(fromstr);
5515 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5523 ashort = (I16)SvIV(fromstr);
5524 CAT16(cat, &ashort);
5531 auint = SvUV(fromstr);
5532 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5538 adouble = Perl_floor(SvNV(fromstr));
5541 DIE(aTHX_ "Cannot compress negative numbers");
5544 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5545 adouble <= 0xffffffff
5547 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5548 adouble <= UV_MAX_cxux
5555 char buf[1 + sizeof(UV)];
5556 char *in = buf + sizeof(buf);
5557 UV auv = U_V(adouble);
5560 *--in = (auv & 0x7f) | 0x80;
5563 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5564 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5566 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5567 char *from, *result, *in;
5572 /* Copy string and check for compliance */
5573 from = SvPV(fromstr, len);
5574 if ((norm = is_an_int(from, len)) == NULL)
5575 DIE(aTHX_ "can compress only unsigned integer");
5577 New('w', result, len, char);
5581 *--in = div128(norm, &done) | 0x80;
5582 result[len - 1] &= 0x7F; /* clear continue bit */
5583 sv_catpvn(cat, in, (result + len) - in);
5585 SvREFCNT_dec(norm); /* free norm */
5587 else if (SvNOKp(fromstr)) {
5588 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5589 char *in = buf + sizeof(buf);
5592 double next = floor(adouble / 128);
5593 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5594 if (in <= buf) /* this cannot happen ;-) */
5595 DIE(aTHX_ "Cannot compress integer");
5598 } while (adouble > 0);
5599 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5600 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5603 DIE(aTHX_ "Cannot compress non integer");
5609 aint = SvIV(fromstr);
5610 sv_catpvn(cat, (char*)&aint, sizeof(int));
5616 aulong = SvUV(fromstr);
5618 aulong = PerlSock_htonl(aulong);
5620 CAT32(cat, &aulong);
5626 aulong = SvUV(fromstr);
5628 aulong = htovl(aulong);
5630 CAT32(cat, &aulong);
5634 #if LONGSIZE != SIZE32
5636 unsigned long aulong;
5640 aulong = SvUV(fromstr);
5641 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5649 aulong = SvUV(fromstr);
5650 CAT32(cat, &aulong);
5655 #if LONGSIZE != SIZE32
5661 along = SvIV(fromstr);
5662 sv_catpvn(cat, (char *)&along, sizeof(long));
5670 along = SvIV(fromstr);
5679 auquad = (Uquad_t)SvUV(fromstr);
5680 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5686 aquad = (Quad_t)SvIV(fromstr);
5687 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5692 len = 1; /* assume SV is correct length */
5697 if (fromstr == &PL_sv_undef)
5701 /* XXX better yet, could spirit away the string to
5702 * a safe spot and hang on to it until the result
5703 * of pack() (and all copies of the result) are
5706 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5707 || (SvPADTMP(fromstr)
5708 && !SvREADONLY(fromstr))))
5710 Perl_warner(aTHX_ WARN_PACK,
5711 "Attempt to pack pointer to temporary value");
5713 if (SvPOK(fromstr) || SvNIOK(fromstr))
5714 aptr = SvPV(fromstr,n_a);
5716 aptr = SvPV_force(fromstr,n_a);
5718 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5723 aptr = SvPV(fromstr, fromlen);
5724 SvGROW(cat, fromlen * 4 / 3);
5729 while (fromlen > 0) {
5736 doencodes(cat, aptr, todo);
5755 register IV limit = POPi; /* note, negative is forever */
5758 register char *s = SvPV(sv, len);
5759 bool do_utf8 = DO_UTF8(sv);
5760 char *strend = s + len;
5762 register REGEXP *rx;
5766 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5767 I32 maxiters = slen + 10;
5770 I32 origlimit = limit;
5773 AV *oldstack = PL_curstack;
5774 I32 gimme = GIMME_V;
5775 I32 oldsave = PL_savestack_ix;
5776 I32 make_mortal = 1;
5777 MAGIC *mg = (MAGIC *) NULL;
5780 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5785 DIE(aTHX_ "panic: pp_split");
5786 rx = pm->op_pmregexp;
5788 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5789 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5791 if (pm->op_pmreplroot) {
5793 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5795 ary = GvAVn((GV*)pm->op_pmreplroot);
5798 else if (gimme != G_ARRAY)
5800 ary = (AV*)PL_curpad[0];
5802 ary = GvAVn(PL_defgv);
5803 #endif /* USE_THREADS */
5806 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5812 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5814 XPUSHs(SvTIED_obj((SV*)ary, mg));
5820 for (i = AvFILLp(ary); i >= 0; i--)
5821 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5823 /* temporarily switch stacks */
5824 SWITCHSTACK(PL_curstack, ary);
5828 base = SP - PL_stack_base;
5830 if (pm->op_pmflags & PMf_SKIPWHITE) {
5831 if (pm->op_pmflags & PMf_LOCALE) {
5832 while (isSPACE_LC(*s))
5840 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5841 SAVEINT(PL_multiline);
5842 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5846 limit = maxiters + 2;
5847 if (pm->op_pmflags & PMf_WHITE) {
5850 while (m < strend &&
5851 !((pm->op_pmflags & PMf_LOCALE)
5852 ? isSPACE_LC(*m) : isSPACE(*m)))
5857 dstr = NEWSV(30, m-s);
5858 sv_setpvn(dstr, s, m-s);
5862 (void)SvUTF8_on(dstr);
5866 while (s < strend &&
5867 ((pm->op_pmflags & PMf_LOCALE)
5868 ? isSPACE_LC(*s) : isSPACE(*s)))
5872 else if (strEQ("^", rx->precomp)) {
5875 for (m = s; m < strend && *m != '\n'; m++) ;
5879 dstr = NEWSV(30, m-s);
5880 sv_setpvn(dstr, s, m-s);
5884 (void)SvUTF8_on(dstr);
5889 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5890 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5891 && (rx->reganch & ROPT_CHECK_ALL)
5892 && !(rx->reganch & ROPT_ANCH)) {
5893 int tail = (rx->reganch & RE_INTUIT_TAIL);
5894 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5897 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5899 char c = *SvPV(csv, n_a);
5902 for (m = s; m < strend && *m != c; m++) ;
5905 dstr = NEWSV(30, m-s);
5906 sv_setpvn(dstr, s, m-s);
5910 (void)SvUTF8_on(dstr);
5912 /* The rx->minlen is in characters but we want to step
5913 * s ahead by bytes. */
5915 s = (char*)utf8_hop((U8*)m, len);
5917 s = m + len; /* Fake \n at the end */
5922 while (s < strend && --limit &&
5923 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5924 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5927 dstr = NEWSV(31, m-s);
5928 sv_setpvn(dstr, s, m-s);
5932 (void)SvUTF8_on(dstr);
5934 /* The rx->minlen is in characters but we want to step
5935 * s ahead by bytes. */
5937 s = (char*)utf8_hop((U8*)m, len);
5939 s = m + len; /* Fake \n at the end */
5944 maxiters += slen * rx->nparens;
5945 while (s < strend && --limit
5946 /* && (!rx->check_substr
5947 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5949 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5950 1 /* minend */, sv, NULL, 0))
5952 TAINT_IF(RX_MATCH_TAINTED(rx));
5953 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5958 strend = s + (strend - m);
5960 m = rx->startp[0] + orig;
5961 dstr = NEWSV(32, m-s);
5962 sv_setpvn(dstr, s, m-s);
5966 (void)SvUTF8_on(dstr);
5969 for (i = 1; i <= rx->nparens; i++) {
5970 s = rx->startp[i] + orig;
5971 m = rx->endp[i] + orig;
5973 dstr = NEWSV(33, m-s);
5974 sv_setpvn(dstr, s, m-s);
5977 dstr = NEWSV(33, 0);
5981 (void)SvUTF8_on(dstr);
5985 s = rx->endp[0] + orig;
5989 LEAVE_SCOPE(oldsave);
5990 iters = (SP - PL_stack_base) - base;
5991 if (iters > maxiters)
5992 DIE(aTHX_ "Split loop");
5994 /* keep field after final delim? */
5995 if (s < strend || (iters && origlimit)) {
5996 STRLEN l = strend - s;
5997 dstr = NEWSV(34, l);
5998 sv_setpvn(dstr, s, l);
6002 (void)SvUTF8_on(dstr);
6006 else if (!origlimit) {
6007 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6013 SWITCHSTACK(ary, oldstack);
6014 if (SvSMAGICAL(ary)) {
6019 if (gimme == G_ARRAY) {
6021 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6029 call_method("PUSH",G_SCALAR|G_DISCARD);
6032 if (gimme == G_ARRAY) {
6033 /* EXTEND should not be needed - we just popped them */
6035 for (i=0; i < iters; i++) {
6036 SV **svp = av_fetch(ary, i, FALSE);
6037 PUSHs((svp) ? *svp : &PL_sv_undef);
6044 if (gimme == G_ARRAY)
6047 if (iters || !pm->op_pmreplroot) {
6057 Perl_unlock_condpair(pTHX_ void *svv)
6059 MAGIC *mg = mg_find((SV*)svv, 'm');
6062 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6063 MUTEX_LOCK(MgMUTEXP(mg));
6064 if (MgOWNER(mg) != thr)
6065 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6067 COND_SIGNAL(MgOWNERCONDP(mg));
6068 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6069 PTR2UV(thr), PTR2UV(svv));)
6070 MUTEX_UNLOCK(MgMUTEXP(mg));
6072 #endif /* USE_THREADS */
6081 #endif /* USE_THREADS */
6082 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6083 || SvTYPE(retsv) == SVt_PVCV) {
6084 retsv = refto(retsv);
6095 if (PL_op->op_private & OPpLVAL_INTRO)
6096 PUSHs(*save_threadsv(PL_op->op_targ));
6098 PUSHs(THREADSV(PL_op->op_targ));
6101 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6102 #endif /* USE_THREADS */