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_SCALARREF
452 /* But globs are already references (kinda) */
453 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
457 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
461 ret = sv_2mortal(newSVpvn(str, n - 1));
463 else if (code) /* Non-Overridable */
465 else { /* None such */
467 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
471 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
473 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
482 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
484 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
500 if (GIMME != G_ARRAY) {
504 *MARK = &PL_sv_undef;
505 *MARK = refto(*MARK);
509 EXTEND_MORTAL(SP - MARK);
511 *MARK = refto(*MARK);
516 S_refto(pTHX_ SV *sv)
520 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
523 if (!(sv = LvTARG(sv)))
526 (void)SvREFCNT_inc(sv);
528 else if (SvTYPE(sv) == SVt_PVAV) {
529 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
532 (void)SvREFCNT_inc(sv);
534 else if (SvPADTMP(sv))
538 (void)SvREFCNT_inc(sv);
541 sv_upgrade(rv, SVt_RV);
555 if (sv && SvGMAGICAL(sv))
558 if (!sv || !SvROK(sv))
562 pv = sv_reftype(sv,TRUE);
563 PUSHp(pv, strlen(pv));
573 stash = CopSTASH(PL_curcop);
579 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
580 Perl_croak(aTHX_ "Attempt to bless into a reference");
582 if (ckWARN(WARN_MISC) && len == 0)
583 Perl_warner(aTHX_ WARN_MISC,
584 "Explicit blessing to '' (assuming package main)");
585 stash = gv_stashpvn(ptr, len, TRUE);
588 (void)sv_bless(TOPs, stash);
602 elem = SvPV(sv, n_a);
606 switch (elem ? *elem : '\0')
609 if (strEQ(elem, "ARRAY"))
610 tmpRef = (SV*)GvAV(gv);
613 if (strEQ(elem, "CODE"))
614 tmpRef = (SV*)GvCVu(gv);
617 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
618 tmpRef = (SV*)GvIOp(gv);
620 if (strEQ(elem, "FORMAT"))
621 tmpRef = (SV*)GvFORM(gv);
624 if (strEQ(elem, "GLOB"))
628 if (strEQ(elem, "HASH"))
629 tmpRef = (SV*)GvHV(gv);
632 if (strEQ(elem, "IO"))
633 tmpRef = (SV*)GvIOp(gv);
636 if (strEQ(elem, "NAME"))
637 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
640 if (strEQ(elem, "PACKAGE"))
641 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
644 if (strEQ(elem, "SCALAR"))
658 /* Pattern matching */
663 register unsigned char *s;
666 register I32 *sfirst;
670 if (sv == PL_lastscream) {
676 SvSCREAM_off(PL_lastscream);
677 SvREFCNT_dec(PL_lastscream);
679 PL_lastscream = SvREFCNT_inc(sv);
682 s = (unsigned char*)(SvPV(sv, len));
686 if (pos > PL_maxscream) {
687 if (PL_maxscream < 0) {
688 PL_maxscream = pos + 80;
689 New(301, PL_screamfirst, 256, I32);
690 New(302, PL_screamnext, PL_maxscream, I32);
693 PL_maxscream = pos + pos / 4;
694 Renew(PL_screamnext, PL_maxscream, I32);
698 sfirst = PL_screamfirst;
699 snext = PL_screamnext;
701 if (!sfirst || !snext)
702 DIE(aTHX_ "do_study: out of memory");
704 for (ch = 256; ch; --ch)
711 snext[pos] = sfirst[ch] - pos;
718 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
727 if (PL_op->op_flags & OPf_STACKED)
733 TARG = sv_newmortal();
738 /* Lvalue operators. */
750 dSP; dMARK; dTARGET; dORIGMARK;
752 do_chop(TARG, *++MARK);
761 SETi(do_chomp(TOPs));
768 register I32 count = 0;
771 count += do_chomp(POPs);
782 if (!sv || !SvANY(sv))
784 switch (SvTYPE(sv)) {
786 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
790 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
794 if (CvROOT(sv) || CvXSUB(sv))
811 if (!PL_op->op_private) {
820 if (SvTHINKFIRST(sv))
823 switch (SvTYPE(sv)) {
833 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
834 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
835 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
839 /* let user-undef'd sub keep its identity */
840 GV* gv = CvGV((CV*)sv);
847 SvSetMagicSV(sv, &PL_sv_undef);
851 Newz(602, gp, 1, GP);
852 GvGP(sv) = gp_ref(gp);
853 GvSV(sv) = NEWSV(72,0);
854 GvLINE(sv) = CopLINE(PL_curcop);
860 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
863 SvPV_set(sv, Nullch);
876 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
877 DIE(aTHX_ PL_no_modify);
878 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
879 SvIVX(TOPs) != IV_MIN)
882 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
893 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
894 DIE(aTHX_ PL_no_modify);
895 sv_setsv(TARG, TOPs);
896 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
897 SvIVX(TOPs) != IV_MAX)
900 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
914 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
915 DIE(aTHX_ PL_no_modify);
916 sv_setsv(TARG, TOPs);
917 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
918 SvIVX(TOPs) != IV_MIN)
921 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
930 /* Ordinary operators. */
934 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
937 SETn( Perl_pow( left, right) );
944 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
945 #ifdef PERL_PRESERVE_IVUV
948 /* Unless the left argument is integer in range we are going to have to
949 use NV maths. Hence only attempt to coerce the right argument if
950 we know the left is integer. */
951 /* Left operand is defined, so is it IV? */
954 bool auvok = SvUOK(TOPm1s);
955 bool buvok = SvUOK(TOPs);
956 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
957 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
964 alow = SvUVX(TOPm1s);
966 IV aiv = SvIVX(TOPm1s);
969 auvok = TRUE; /* effectively it's a UV now */
971 alow = -aiv; /* abs, auvok == false records sign */
977 IV biv = SvIVX(TOPs);
980 buvok = TRUE; /* effectively it's a UV now */
982 blow = -biv; /* abs, buvok == false records sign */
986 /* If this does sign extension on unsigned it's time for plan B */
987 ahigh = alow >> (4 * sizeof (UV));
989 bhigh = blow >> (4 * sizeof (UV));
991 if (ahigh && bhigh) {
992 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
993 which is overflow. Drop to NVs below. */
994 } else if (!ahigh && !bhigh) {
995 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
996 so the unsigned multiply cannot overflow. */
997 UV product = alow * blow;
998 if (auvok == buvok) {
999 /* -ve * -ve or +ve * +ve gives a +ve result. */
1003 } else if (product <= (UV)IV_MIN) {
1004 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1005 /* -ve result, which could overflow an IV */
1009 } /* else drop to NVs below. */
1011 /* One operand is large, 1 small */
1014 /* swap the operands */
1016 bhigh = blow; /* bhigh now the temp var for the swap */
1020 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1021 multiplies can't overflow. shift can, add can, -ve can. */
1022 product_middle = ahigh * blow;
1023 if (!(product_middle & topmask)) {
1024 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1026 product_middle <<= (4 * sizeof (UV));
1027 product_low = alow * blow;
1029 /* as for pp_add, UV + something mustn't get smaller.
1030 IIRC ANSI mandates this wrapping *behaviour* for
1031 unsigned whatever the actual representation*/
1032 product_low += product_middle;
1033 if (product_low >= product_middle) {
1034 /* didn't overflow */
1035 if (auvok == buvok) {
1036 /* -ve * -ve or +ve * +ve gives a +ve result. */
1038 SETu( product_low );
1040 } else if (product_low <= (UV)IV_MIN) {
1041 /* 2s complement assumption again */
1042 /* -ve result, which could overflow an IV */
1044 SETi( -product_low );
1046 } /* else drop to NVs below. */
1048 } /* product_middle too large */
1049 } /* ahigh && bhigh */
1050 } /* SvIOK(TOPm1s) */
1055 SETn( left * right );
1062 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1067 DIE(aTHX_ "Illegal division by zero");
1069 /* insure that 20./5. == 4. */
1072 if ((NV)I_V(left) == left &&
1073 (NV)I_V(right) == right &&
1074 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1078 value = left / right;
1082 value = left / right;
1091 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1097 bool use_double = 0;
1101 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1103 right = (right_neg = (i < 0)) ? -i : i;
1108 right_neg = dright < 0;
1113 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1115 left = (left_neg = (i < 0)) ? -i : i;
1123 left_neg = dleft < 0;
1132 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1134 # define CAST_D2UV(d) U_V(d)
1136 # define CAST_D2UV(d) ((UV)(d))
1138 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1139 * or, in other words, precision of UV more than of NV.
1140 * But in fact the approach below turned out to be an
1141 * optimization - floor() may be slow */
1142 if (dright <= UV_MAX && dleft <= UV_MAX) {
1143 right = CAST_D2UV(dright);
1144 left = CAST_D2UV(dleft);
1149 /* Backward-compatibility clause: */
1150 dright = Perl_floor(dright + 0.5);
1151 dleft = Perl_floor(dleft + 0.5);
1154 DIE(aTHX_ "Illegal modulus zero");
1156 dans = Perl_fmod(dleft, dright);
1157 if ((left_neg != right_neg) && dans)
1158 dans = dright - dans;
1161 sv_setnv(TARG, dans);
1168 DIE(aTHX_ "Illegal modulus zero");
1171 if ((left_neg != right_neg) && ans)
1174 /* XXX may warn: unary minus operator applied to unsigned type */
1175 /* could change -foo to be (~foo)+1 instead */
1176 if (ans <= ~((UV)IV_MAX)+1)
1177 sv_setiv(TARG, ~ans+1);
1179 sv_setnv(TARG, -(NV)ans);
1182 sv_setuv(TARG, ans);
1191 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1193 register IV count = POPi;
1194 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1196 I32 items = SP - MARK;
1199 max = items * count;
1208 repeatcpy((char*)(MARK + items), (char*)MARK,
1209 items * sizeof(SV*), count - 1);
1212 else if (count <= 0)
1215 else { /* Note: mark already snarfed by pp_list */
1220 SvSetSV(TARG, tmpstr);
1221 SvPV_force(TARG, len);
1222 isutf = DO_UTF8(TARG);
1227 SvGROW(TARG, (count * len) + 1);
1228 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1229 SvCUR(TARG) *= count;
1231 *SvEND(TARG) = '\0';
1234 (void)SvPOK_only_UTF8(TARG);
1236 (void)SvPOK_only(TARG);
1238 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1239 /* The parser saw this as a list repeat, and there
1240 are probably several items on the stack. But we're
1241 in scalar context, and there's no pp_list to save us
1242 now. So drop the rest of the items -- robin@kitsite.com
1255 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1256 useleft = USE_LEFT(TOPm1s);
1257 #ifdef PERL_PRESERVE_IVUV
1258 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1259 "bad things" happen if you rely on signed integers wrapping. */
1262 /* Unless the left argument is integer in range we are going to have to
1263 use NV maths. Hence only attempt to coerce the right argument if
1264 we know the left is integer. */
1271 a_valid = auvok = 1;
1272 /* left operand is undef, treat as zero. */
1274 /* Left operand is defined, so is it IV? */
1275 SvIV_please(TOPm1s);
1276 if (SvIOK(TOPm1s)) {
1277 if ((auvok = SvUOK(TOPm1s)))
1278 auv = SvUVX(TOPm1s);
1280 register IV aiv = SvIVX(TOPm1s);
1283 auvok = 1; /* Now acting as a sign flag. */
1284 } else { /* 2s complement assumption for IV_MIN */
1292 bool result_good = 0;
1295 bool buvok = SvUOK(TOPs);
1300 register IV biv = SvIVX(TOPs);
1307 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1308 else "IV" now, independant of how it came in.
1309 if a, b represents positive, A, B negative, a maps to -A etc
1314 all UV maths. negate result if A negative.
1315 subtract if signs same, add if signs differ. */
1317 if (auvok ^ buvok) {
1326 /* Must get smaller */
1331 if (result <= buv) {
1332 /* result really should be -(auv-buv). as its negation
1333 of true value, need to swap our result flag */
1345 if (result <= (UV)IV_MIN)
1346 SETi( -(IV)result );
1348 /* result valid, but out of range for IV. */
1349 SETn( -(NV)result );
1353 } /* Overflow, drop through to NVs. */
1357 useleft = USE_LEFT(TOPm1s);
1361 /* left operand is undef, treat as zero - value */
1365 SETn( TOPn - value );
1372 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1375 if (PL_op->op_private & HINT_INTEGER) {
1389 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1392 if (PL_op->op_private & HINT_INTEGER) {
1406 dSP; tryAMAGICbinSET(lt,0);
1407 #ifdef PERL_PRESERVE_IVUV
1410 SvIV_please(TOPm1s);
1411 if (SvIOK(TOPm1s)) {
1412 bool auvok = SvUOK(TOPm1s);
1413 bool buvok = SvUOK(TOPs);
1415 if (!auvok && !buvok) { /* ## IV < IV ## */
1416 IV aiv = SvIVX(TOPm1s);
1417 IV biv = SvIVX(TOPs);
1420 SETs(boolSV(aiv < biv));
1423 if (auvok && buvok) { /* ## UV < UV ## */
1424 UV auv = SvUVX(TOPm1s);
1425 UV buv = SvUVX(TOPs);
1428 SETs(boolSV(auv < buv));
1431 if (auvok) { /* ## UV < IV ## */
1438 /* As (a) is a UV, it's >=0, so it cannot be < */
1443 if (auv >= (UV) IV_MAX) {
1444 /* As (b) is an IV, it cannot be > IV_MAX */
1448 SETs(boolSV(auv < (UV)biv));
1451 { /* ## IV < UV ## */
1455 aiv = SvIVX(TOPm1s);
1457 /* As (b) is a UV, it's >=0, so it must be < */
1464 if (buv > (UV) IV_MAX) {
1465 /* As (a) is an IV, it cannot be > IV_MAX */
1469 SETs(boolSV((UV)aiv < buv));
1477 SETs(boolSV(TOPn < value));
1484 dSP; tryAMAGICbinSET(gt,0);
1485 #ifdef PERL_PRESERVE_IVUV
1488 SvIV_please(TOPm1s);
1489 if (SvIOK(TOPm1s)) {
1490 bool auvok = SvUOK(TOPm1s);
1491 bool buvok = SvUOK(TOPs);
1493 if (!auvok && !buvok) { /* ## IV > IV ## */
1494 IV aiv = SvIVX(TOPm1s);
1495 IV biv = SvIVX(TOPs);
1498 SETs(boolSV(aiv > biv));
1501 if (auvok && buvok) { /* ## UV > UV ## */
1502 UV auv = SvUVX(TOPm1s);
1503 UV buv = SvUVX(TOPs);
1506 SETs(boolSV(auv > buv));
1509 if (auvok) { /* ## UV > IV ## */
1516 /* As (a) is a UV, it's >=0, so it must be > */
1521 if (auv > (UV) IV_MAX) {
1522 /* As (b) is an IV, it cannot be > IV_MAX */
1526 SETs(boolSV(auv > (UV)biv));
1529 { /* ## IV > UV ## */
1533 aiv = SvIVX(TOPm1s);
1535 /* As (b) is a UV, it's >=0, so it cannot be > */
1542 if (buv >= (UV) IV_MAX) {
1543 /* As (a) is an IV, it cannot be > IV_MAX */
1547 SETs(boolSV((UV)aiv > buv));
1555 SETs(boolSV(TOPn > value));
1562 dSP; tryAMAGICbinSET(le,0);
1563 #ifdef PERL_PRESERVE_IVUV
1566 SvIV_please(TOPm1s);
1567 if (SvIOK(TOPm1s)) {
1568 bool auvok = SvUOK(TOPm1s);
1569 bool buvok = SvUOK(TOPs);
1571 if (!auvok && !buvok) { /* ## IV <= IV ## */
1572 IV aiv = SvIVX(TOPm1s);
1573 IV biv = SvIVX(TOPs);
1576 SETs(boolSV(aiv <= biv));
1579 if (auvok && buvok) { /* ## UV <= UV ## */
1580 UV auv = SvUVX(TOPm1s);
1581 UV buv = SvUVX(TOPs);
1584 SETs(boolSV(auv <= buv));
1587 if (auvok) { /* ## UV <= IV ## */
1594 /* As (a) is a UV, it's >=0, so a cannot be <= */
1599 if (auv > (UV) IV_MAX) {
1600 /* As (b) is an IV, it cannot be > IV_MAX */
1604 SETs(boolSV(auv <= (UV)biv));
1607 { /* ## IV <= UV ## */
1611 aiv = SvIVX(TOPm1s);
1613 /* As (b) is a UV, it's >=0, so a must be <= */
1620 if (buv >= (UV) IV_MAX) {
1621 /* As (a) is an IV, it cannot be > IV_MAX */
1625 SETs(boolSV((UV)aiv <= buv));
1633 SETs(boolSV(TOPn <= value));
1640 dSP; tryAMAGICbinSET(ge,0);
1641 #ifdef PERL_PRESERVE_IVUV
1644 SvIV_please(TOPm1s);
1645 if (SvIOK(TOPm1s)) {
1646 bool auvok = SvUOK(TOPm1s);
1647 bool buvok = SvUOK(TOPs);
1649 if (!auvok && !buvok) { /* ## IV >= IV ## */
1650 IV aiv = SvIVX(TOPm1s);
1651 IV biv = SvIVX(TOPs);
1654 SETs(boolSV(aiv >= biv));
1657 if (auvok && buvok) { /* ## UV >= UV ## */
1658 UV auv = SvUVX(TOPm1s);
1659 UV buv = SvUVX(TOPs);
1662 SETs(boolSV(auv >= buv));
1665 if (auvok) { /* ## UV >= IV ## */
1672 /* As (a) is a UV, it's >=0, so it must be >= */
1677 if (auv >= (UV) IV_MAX) {
1678 /* As (b) is an IV, it cannot be > IV_MAX */
1682 SETs(boolSV(auv >= (UV)biv));
1685 { /* ## IV >= UV ## */
1689 aiv = SvIVX(TOPm1s);
1691 /* As (b) is a UV, it's >=0, so a cannot be >= */
1698 if (buv > (UV) IV_MAX) {
1699 /* As (a) is an IV, it cannot be > IV_MAX */
1703 SETs(boolSV((UV)aiv >= buv));
1711 SETs(boolSV(TOPn >= value));
1718 dSP; tryAMAGICbinSET(ne,0);
1719 #ifndef NV_PRESERVES_UV
1720 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1721 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1725 #ifdef PERL_PRESERVE_IVUV
1728 SvIV_please(TOPm1s);
1729 if (SvIOK(TOPm1s)) {
1730 bool auvok = SvUOK(TOPm1s);
1731 bool buvok = SvUOK(TOPs);
1733 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1734 IV aiv = SvIVX(TOPm1s);
1735 IV biv = SvIVX(TOPs);
1738 SETs(boolSV(aiv != biv));
1741 if (auvok && buvok) { /* ## UV != UV ## */
1742 UV auv = SvUVX(TOPm1s);
1743 UV buv = SvUVX(TOPs);
1746 SETs(boolSV(auv != buv));
1749 { /* ## Mixed IV,UV ## */
1753 /* != is commutative so swap if needed (save code) */
1755 /* swap. top of stack (b) is the iv */
1759 /* As (a) is a UV, it's >0, so it cannot be == */
1768 /* As (b) is a UV, it's >0, so it cannot be == */
1772 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1774 /* we know iv is >= 0 */
1775 if (uv > (UV) IV_MAX) {
1779 SETs(boolSV((UV)iv != uv));
1787 SETs(boolSV(TOPn != value));
1794 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1795 #ifndef NV_PRESERVES_UV
1796 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1797 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1801 #ifdef PERL_PRESERVE_IVUV
1802 /* Fortunately it seems NaN isn't IOK */
1805 SvIV_please(TOPm1s);
1806 if (SvIOK(TOPm1s)) {
1807 bool leftuvok = SvUOK(TOPm1s);
1808 bool rightuvok = SvUOK(TOPs);
1810 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1811 IV leftiv = SvIVX(TOPm1s);
1812 IV rightiv = SvIVX(TOPs);
1814 if (leftiv > rightiv)
1816 else if (leftiv < rightiv)
1820 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1821 UV leftuv = SvUVX(TOPm1s);
1822 UV rightuv = SvUVX(TOPs);
1824 if (leftuv > rightuv)
1826 else if (leftuv < rightuv)
1830 } else if (leftuvok) { /* ## UV <=> IV ## */
1834 rightiv = SvIVX(TOPs);
1836 /* As (a) is a UV, it's >=0, so it cannot be < */
1839 leftuv = SvUVX(TOPm1s);
1840 if (leftuv > (UV) IV_MAX) {
1841 /* As (b) is an IV, it cannot be > IV_MAX */
1843 } else if (leftuv > (UV)rightiv) {
1845 } else if (leftuv < (UV)rightiv) {
1851 } else { /* ## IV <=> UV ## */
1855 leftiv = SvIVX(TOPm1s);
1857 /* As (b) is a UV, it's >=0, so it must be < */
1860 rightuv = SvUVX(TOPs);
1861 if (rightuv > (UV) IV_MAX) {
1862 /* As (a) is an IV, it cannot be > IV_MAX */
1864 } else if (leftiv > (UV)rightuv) {
1866 } else if (leftiv < (UV)rightuv) {
1884 if (Perl_isnan(left) || Perl_isnan(right)) {
1888 value = (left > right) - (left < right);
1892 else if (left < right)
1894 else if (left > right)
1908 dSP; tryAMAGICbinSET(slt,0);
1911 int cmp = ((PL_op->op_private & OPpLOCALE)
1912 ? sv_cmp_locale(left, right)
1913 : sv_cmp(left, right));
1914 SETs(boolSV(cmp < 0));
1921 dSP; tryAMAGICbinSET(sgt,0);
1924 int cmp = ((PL_op->op_private & OPpLOCALE)
1925 ? sv_cmp_locale(left, right)
1926 : sv_cmp(left, right));
1927 SETs(boolSV(cmp > 0));
1934 dSP; tryAMAGICbinSET(sle,0);
1937 int cmp = ((PL_op->op_private & OPpLOCALE)
1938 ? sv_cmp_locale(left, right)
1939 : sv_cmp(left, right));
1940 SETs(boolSV(cmp <= 0));
1947 dSP; tryAMAGICbinSET(sge,0);
1950 int cmp = ((PL_op->op_private & OPpLOCALE)
1951 ? sv_cmp_locale(left, right)
1952 : sv_cmp(left, right));
1953 SETs(boolSV(cmp >= 0));
1960 dSP; tryAMAGICbinSET(seq,0);
1963 SETs(boolSV(sv_eq(left, right)));
1970 dSP; tryAMAGICbinSET(sne,0);
1973 SETs(boolSV(!sv_eq(left, right)));
1980 dSP; dTARGET; tryAMAGICbin(scmp,0);
1983 int cmp = ((PL_op->op_private & OPpLOCALE)
1984 ? sv_cmp_locale(left, right)
1985 : sv_cmp(left, right));
1993 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1996 if (SvNIOKp(left) || SvNIOKp(right)) {
1997 if (PL_op->op_private & HINT_INTEGER) {
1998 IV i = SvIV(left) & SvIV(right);
2002 UV u = SvUV(left) & SvUV(right);
2007 do_vop(PL_op->op_type, TARG, left, right);
2016 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2019 if (SvNIOKp(left) || SvNIOKp(right)) {
2020 if (PL_op->op_private & HINT_INTEGER) {
2021 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2025 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2030 do_vop(PL_op->op_type, TARG, left, right);
2039 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2042 if (SvNIOKp(left) || SvNIOKp(right)) {
2043 if (PL_op->op_private & HINT_INTEGER) {
2044 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2048 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2053 do_vop(PL_op->op_type, TARG, left, right);
2062 dSP; dTARGET; tryAMAGICun(neg);
2065 int flags = SvFLAGS(sv);
2068 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2069 /* It's publicly an integer, or privately an integer-not-float */
2072 if (SvIVX(sv) == IV_MIN) {
2073 /* 2s complement assumption. */
2074 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2077 else if (SvUVX(sv) <= IV_MAX) {
2082 else if (SvIVX(sv) != IV_MIN) {
2086 #ifdef PERL_PRESERVE_IVUV
2095 else if (SvPOKp(sv)) {
2097 char *s = SvPV(sv, len);
2098 if (isIDFIRST(*s)) {
2099 sv_setpvn(TARG, "-", 1);
2102 else if (*s == '+' || *s == '-') {
2104 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2106 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2107 sv_setpvn(TARG, "-", 1);
2113 goto oops_its_an_int;
2114 sv_setnv(TARG, -SvNV(sv));
2126 dSP; tryAMAGICunSET(not);
2127 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2133 dSP; dTARGET; tryAMAGICun(compl);
2137 if (PL_op->op_private & HINT_INTEGER) {
2152 tmps = (U8*)SvPV_force(TARG, len);
2155 /* Calculate exact length, let's not estimate. */
2164 while (tmps < send) {
2165 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2166 tmps += UTF8SKIP(tmps);
2167 targlen += UNISKIP(~c);
2173 /* Now rewind strings and write them. */
2177 Newz(0, result, targlen + 1, U8);
2178 while (tmps < send) {
2179 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2180 tmps += UTF8SKIP(tmps);
2181 result = uvchr_to_utf8(result, ~c);
2185 sv_setpvn(TARG, (char*)result, targlen);
2189 Newz(0, result, nchar + 1, U8);
2190 while (tmps < send) {
2191 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2192 tmps += UTF8SKIP(tmps);
2197 sv_setpvn(TARG, (char*)result, nchar);
2205 register long *tmpl;
2206 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2209 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2214 for ( ; anum > 0; anum--, tmps++)
2223 /* integer versions of some of the above */
2227 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2230 SETi( left * right );
2237 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2241 DIE(aTHX_ "Illegal division by zero");
2242 value = POPi / value;
2250 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2254 DIE(aTHX_ "Illegal modulus zero");
2255 SETi( left % right );
2262 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2265 SETi( left + right );
2272 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2275 SETi( left - right );
2282 dSP; tryAMAGICbinSET(lt,0);
2285 SETs(boolSV(left < right));
2292 dSP; tryAMAGICbinSET(gt,0);
2295 SETs(boolSV(left > right));
2302 dSP; tryAMAGICbinSET(le,0);
2305 SETs(boolSV(left <= right));
2312 dSP; tryAMAGICbinSET(ge,0);
2315 SETs(boolSV(left >= right));
2322 dSP; tryAMAGICbinSET(eq,0);
2325 SETs(boolSV(left == right));
2332 dSP; tryAMAGICbinSET(ne,0);
2335 SETs(boolSV(left != right));
2342 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2349 else if (left < right)
2360 dSP; dTARGET; tryAMAGICun(neg);
2365 /* High falutin' math. */
2369 dSP; dTARGET; tryAMAGICbin(atan2,0);
2372 SETn(Perl_atan2(left, right));
2379 dSP; dTARGET; tryAMAGICun(sin);
2383 value = Perl_sin(value);
2391 dSP; dTARGET; tryAMAGICun(cos);
2395 value = Perl_cos(value);
2401 /* Support Configure command-line overrides for rand() functions.
2402 After 5.005, perhaps we should replace this by Configure support
2403 for drand48(), random(), or rand(). For 5.005, though, maintain
2404 compatibility by calling rand() but allow the user to override it.
2405 See INSTALL for details. --Andy Dougherty 15 July 1998
2407 /* Now it's after 5.005, and Configure supports drand48() and random(),
2408 in addition to rand(). So the overrides should not be needed any more.
2409 --Jarkko Hietaniemi 27 September 1998
2412 #ifndef HAS_DRAND48_PROTO
2413 extern double drand48 (void);
2426 if (!PL_srand_called) {
2427 (void)seedDrand01((Rand_seed_t)seed());
2428 PL_srand_called = TRUE;
2443 (void)seedDrand01((Rand_seed_t)anum);
2444 PL_srand_called = TRUE;
2453 * This is really just a quick hack which grabs various garbage
2454 * values. It really should be a real hash algorithm which
2455 * spreads the effect of every input bit onto every output bit,
2456 * if someone who knows about such things would bother to write it.
2457 * Might be a good idea to add that function to CORE as well.
2458 * No numbers below come from careful analysis or anything here,
2459 * except they are primes and SEED_C1 > 1E6 to get a full-width
2460 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2461 * probably be bigger too.
2464 # define SEED_C1 1000003
2465 #define SEED_C4 73819
2467 # define SEED_C1 25747
2468 #define SEED_C4 20639
2472 #define SEED_C5 26107
2474 #ifndef PERL_NO_DEV_RANDOM
2479 # include <starlet.h>
2480 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2481 * in 100-ns units, typically incremented ever 10 ms. */
2482 unsigned int when[2];
2484 # ifdef HAS_GETTIMEOFDAY
2485 struct timeval when;
2491 /* This test is an escape hatch, this symbol isn't set by Configure. */
2492 #ifndef PERL_NO_DEV_RANDOM
2493 #ifndef PERL_RANDOM_DEVICE
2494 /* /dev/random isn't used by default because reads from it will block
2495 * if there isn't enough entropy available. You can compile with
2496 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2497 * is enough real entropy to fill the seed. */
2498 # define PERL_RANDOM_DEVICE "/dev/urandom"
2500 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2502 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2511 _ckvmssts(sys$gettim(when));
2512 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2514 # ifdef HAS_GETTIMEOFDAY
2515 gettimeofday(&when,(struct timezone *) 0);
2516 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2519 u = (U32)SEED_C1 * when;
2522 u += SEED_C3 * (U32)PerlProc_getpid();
2523 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2524 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2525 u += SEED_C5 * (U32)PTR2UV(&when);
2532 dSP; dTARGET; tryAMAGICun(exp);
2536 value = Perl_exp(value);
2544 dSP; dTARGET; tryAMAGICun(log);
2549 SET_NUMERIC_STANDARD();
2550 DIE(aTHX_ "Can't take log of %g", value);
2552 value = Perl_log(value);
2560 dSP; dTARGET; tryAMAGICun(sqrt);
2565 SET_NUMERIC_STANDARD();
2566 DIE(aTHX_ "Can't take sqrt of %g", value);
2568 value = Perl_sqrt(value);
2576 dSP; dTARGET; tryAMAGICun(int);
2579 IV iv = TOPi; /* attempt to convert to IV if possible. */
2580 /* XXX it's arguable that compiler casting to IV might be subtly
2581 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2582 else preferring IV has introduced a subtle behaviour change bug. OTOH
2583 relying on floating point to be accurate is a bug. */
2594 if (value < (NV)UV_MAX + 0.5) {
2597 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2598 (void)Perl_modf(value, &value);
2600 double tmp = (double)value;
2601 (void)Perl_modf(tmp, &tmp);
2608 if (value > (NV)IV_MIN - 0.5) {
2611 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2612 (void)Perl_modf(-value, &value);
2615 double tmp = (double)value;
2616 (void)Perl_modf(-tmp, &tmp);
2629 dSP; dTARGET; tryAMAGICun(abs);
2631 /* This will cache the NV value if string isn't actually integer */
2635 /* IVX is precise */
2637 SETu(TOPu); /* force it to be numeric only */
2645 /* 2s complement assumption. Also, not really needed as
2646 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2668 tmps = (SvPVx(POPs, len));
2669 argtype = 1; /* allow underscores */
2670 XPUSHn(scan_hex(tmps, len, &argtype));
2682 tmps = (SvPVx(POPs, len));
2683 while (*tmps && len && isSPACE(*tmps))
2687 argtype = 1; /* allow underscores */
2689 value = scan_hex(++tmps, --len, &argtype);
2690 else if (*tmps == 'b')
2691 value = scan_bin(++tmps, --len, &argtype);
2693 value = scan_oct(tmps, len, &argtype);
2706 SETi(sv_len_utf8(sv));
2722 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2724 I32 arybase = PL_curcop->cop_arybase;
2728 int num_args = PL_op->op_private & 7;
2729 bool repl_need_utf8_upgrade = FALSE;
2730 bool repl_is_utf8 = FALSE;
2732 SvTAINTED_off(TARG); /* decontaminate */
2733 SvUTF8_off(TARG); /* decontaminate */
2737 repl = SvPV(repl_sv, repl_len);
2738 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2748 sv_utf8_upgrade(sv);
2750 else if (DO_UTF8(sv))
2751 repl_need_utf8_upgrade = TRUE;
2753 tmps = SvPV(sv, curlen);
2755 utf8_curlen = sv_len_utf8(sv);
2756 if (utf8_curlen == curlen)
2759 curlen = utf8_curlen;
2764 if (pos >= arybase) {
2782 else if (len >= 0) {
2784 if (rem > (I32)curlen)
2799 Perl_croak(aTHX_ "substr outside of string");
2800 if (ckWARN(WARN_SUBSTR))
2801 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2808 sv_pos_u2b(sv, &pos, &rem);
2810 sv_setpvn(TARG, tmps, rem);
2811 #ifdef USE_LOCALE_COLLATE
2812 sv_unmagic(TARG, 'o');
2817 SV* repl_sv_copy = NULL;
2819 if (repl_need_utf8_upgrade) {
2820 repl_sv_copy = newSVsv(repl_sv);
2821 sv_utf8_upgrade(repl_sv_copy);
2822 repl = SvPV(repl_sv_copy, repl_len);
2823 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2825 sv_insert(sv, pos, rem, repl, repl_len);
2829 SvREFCNT_dec(repl_sv_copy);
2831 else if (lvalue) { /* it's an lvalue! */
2832 if (!SvGMAGICAL(sv)) {
2836 if (ckWARN(WARN_SUBSTR))
2837 Perl_warner(aTHX_ WARN_SUBSTR,
2838 "Attempt to use reference as lvalue in substr");
2840 if (SvOK(sv)) /* is it defined ? */
2841 (void)SvPOK_only_UTF8(sv);
2843 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2846 if (SvTYPE(TARG) < SVt_PVLV) {
2847 sv_upgrade(TARG, SVt_PVLV);
2848 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2852 if (LvTARG(TARG) != sv) {
2854 SvREFCNT_dec(LvTARG(TARG));
2855 LvTARG(TARG) = SvREFCNT_inc(sv);
2857 LvTARGOFF(TARG) = upos;
2858 LvTARGLEN(TARG) = urem;
2862 PUSHs(TARG); /* avoid SvSETMAGIC here */
2869 register IV size = POPi;
2870 register IV offset = POPi;
2871 register SV *src = POPs;
2872 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2874 SvTAINTED_off(TARG); /* decontaminate */
2875 if (lvalue) { /* it's an lvalue! */
2876 if (SvTYPE(TARG) < SVt_PVLV) {
2877 sv_upgrade(TARG, SVt_PVLV);
2878 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2881 if (LvTARG(TARG) != src) {
2883 SvREFCNT_dec(LvTARG(TARG));
2884 LvTARG(TARG) = SvREFCNT_inc(src);
2886 LvTARGOFF(TARG) = offset;
2887 LvTARGLEN(TARG) = size;
2890 sv_setuv(TARG, do_vecget(src, offset, size));
2905 I32 arybase = PL_curcop->cop_arybase;
2910 offset = POPi - arybase;
2913 tmps = SvPV(big, biglen);
2914 if (offset > 0 && DO_UTF8(big))
2915 sv_pos_u2b(big, &offset, 0);
2918 else if (offset > biglen)
2920 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2921 (unsigned char*)tmps + biglen, little, 0)))
2924 retval = tmps2 - tmps;
2925 if (retval > 0 && DO_UTF8(big))
2926 sv_pos_b2u(big, &retval);
2927 PUSHi(retval + arybase);
2942 I32 arybase = PL_curcop->cop_arybase;
2948 tmps2 = SvPV(little, llen);
2949 tmps = SvPV(big, blen);
2953 if (offset > 0 && DO_UTF8(big))
2954 sv_pos_u2b(big, &offset, 0);
2955 offset = offset - arybase + llen;
2959 else if (offset > blen)
2961 if (!(tmps2 = rninstr(tmps, tmps + offset,
2962 tmps2, tmps2 + llen)))
2965 retval = tmps2 - tmps;
2966 if (retval > 0 && DO_UTF8(big))
2967 sv_pos_b2u(big, &retval);
2968 PUSHi(retval + arybase);
2974 dSP; dMARK; dORIGMARK; dTARGET;
2975 do_sprintf(TARG, SP-MARK, MARK+1);
2976 TAINT_IF(SvTAINTED(TARG));
2987 U8 *s = (U8*)SvPVx(argsv, len);
2989 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2999 (void)SvUPGRADE(TARG,SVt_PV);
3001 if (value > 255 && !IN_BYTE) {
3002 SvGROW(TARG, UNISKIP(value)+1);
3003 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3004 SvCUR_set(TARG, tmps - SvPVX(TARG));
3006 (void)SvPOK_only(TARG);
3017 (void)SvPOK_only(TARG);
3024 dSP; dTARGET; dPOPTOPssrl;
3027 char *tmps = SvPV(left, n_a);
3029 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3031 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3035 "The crypt() function is unimplemented due to excessive paranoia.");
3048 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3050 U8 tmpbuf[UTF8_MAXLEN+1];
3054 if (PL_op->op_private & OPpLOCALE) {
3057 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3060 uv = toTITLE_utf8(s);
3062 tend = uvchr_to_utf8(tmpbuf, uv);
3064 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3066 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3067 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3072 s = (U8*)SvPV_force(sv, slen);
3073 Copy(tmpbuf, s, ulen, U8);
3077 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3079 SvUTF8_off(TARG); /* decontaminate */
3084 s = (U8*)SvPV_force(sv, slen);
3086 if (PL_op->op_private & OPpLOCALE) {
3089 *s = toUPPER_LC(*s);
3107 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3109 U8 tmpbuf[UTF8_MAXLEN+1];
3113 if (PL_op->op_private & OPpLOCALE) {
3116 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3119 uv = toLOWER_utf8(s);
3121 tend = uvchr_to_utf8(tmpbuf, uv);
3123 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3125 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3126 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3131 s = (U8*)SvPV_force(sv, slen);
3132 Copy(tmpbuf, s, ulen, U8);
3136 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3138 SvUTF8_off(TARG); /* decontaminate */
3143 s = (U8*)SvPV_force(sv, slen);
3145 if (PL_op->op_private & OPpLOCALE) {
3148 *s = toLOWER_LC(*s);
3172 s = (U8*)SvPV(sv,len);
3174 SvUTF8_off(TARG); /* decontaminate */
3175 sv_setpvn(TARG, "", 0);
3179 (void)SvUPGRADE(TARG, SVt_PV);
3180 SvGROW(TARG, (len * 2) + 1);
3181 (void)SvPOK_only(TARG);
3182 d = (U8*)SvPVX(TARG);
3184 if (PL_op->op_private & OPpLOCALE) {
3188 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3194 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3200 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3205 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3207 SvUTF8_off(TARG); /* decontaminate */
3212 s = (U8*)SvPV_force(sv, len);
3214 register U8 *send = s + len;
3216 if (PL_op->op_private & OPpLOCALE) {
3219 for (; s < send; s++)
3220 *s = toUPPER_LC(*s);
3223 for (; s < send; s++)
3246 s = (U8*)SvPV(sv,len);
3248 SvUTF8_off(TARG); /* decontaminate */
3249 sv_setpvn(TARG, "", 0);
3253 (void)SvUPGRADE(TARG, SVt_PV);
3254 SvGROW(TARG, (len * 2) + 1);
3255 (void)SvPOK_only(TARG);
3256 d = (U8*)SvPVX(TARG);
3258 if (PL_op->op_private & OPpLOCALE) {
3262 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3268 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3274 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3279 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3281 SvUTF8_off(TARG); /* decontaminate */
3287 s = (U8*)SvPV_force(sv, len);
3289 register U8 *send = s + len;
3291 if (PL_op->op_private & OPpLOCALE) {
3294 for (; s < send; s++)
3295 *s = toLOWER_LC(*s);
3298 for (; s < send; s++)
3313 register char *s = SvPV(sv,len);
3316 SvUTF8_off(TARG); /* decontaminate */
3318 (void)SvUPGRADE(TARG, SVt_PV);
3319 SvGROW(TARG, (len * 2) + 1);
3323 if (UTF8_IS_CONTINUED(*s)) {
3324 STRLEN ulen = UTF8SKIP(s);
3348 SvCUR_set(TARG, d - SvPVX(TARG));
3349 (void)SvPOK_only_UTF8(TARG);
3352 sv_setpvn(TARG, s, len);
3354 if (SvSMAGICAL(TARG))
3363 dSP; dMARK; dORIGMARK;
3365 register AV* av = (AV*)POPs;
3366 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3367 I32 arybase = PL_curcop->cop_arybase;
3370 if (SvTYPE(av) == SVt_PVAV) {
3371 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3373 for (svp = MARK + 1; svp <= SP; svp++) {
3378 if (max > AvMAX(av))
3381 while (++MARK <= SP) {
3382 elem = SvIVx(*MARK);
3386 svp = av_fetch(av, elem, lval);
3388 if (!svp || *svp == &PL_sv_undef)
3389 DIE(aTHX_ PL_no_aelem, elem);
3390 if (PL_op->op_private & OPpLVAL_INTRO)
3391 save_aelem(av, elem, svp);
3393 *MARK = svp ? *svp : &PL_sv_undef;
3396 if (GIMME != G_ARRAY) {
3404 /* Associative arrays. */
3409 HV *hash = (HV*)POPs;
3411 I32 gimme = GIMME_V;
3412 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3415 /* might clobber stack_sp */
3416 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3421 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3422 if (gimme == G_ARRAY) {
3425 /* might clobber stack_sp */
3427 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3432 else if (gimme == G_SCALAR)
3451 I32 gimme = GIMME_V;
3452 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3456 if (PL_op->op_private & OPpSLICE) {
3460 hvtype = SvTYPE(hv);
3461 if (hvtype == SVt_PVHV) { /* hash element */
3462 while (++MARK <= SP) {
3463 sv = hv_delete_ent(hv, *MARK, discard, 0);
3464 *MARK = sv ? sv : &PL_sv_undef;
3467 else if (hvtype == SVt_PVAV) {
3468 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3469 while (++MARK <= SP) {
3470 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3471 *MARK = sv ? sv : &PL_sv_undef;
3474 else { /* pseudo-hash element */
3475 while (++MARK <= SP) {
3476 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3477 *MARK = sv ? sv : &PL_sv_undef;
3482 DIE(aTHX_ "Not a HASH reference");
3485 else if (gimme == G_SCALAR) {
3494 if (SvTYPE(hv) == SVt_PVHV)
3495 sv = hv_delete_ent(hv, keysv, discard, 0);
3496 else if (SvTYPE(hv) == SVt_PVAV) {
3497 if (PL_op->op_flags & OPf_SPECIAL)
3498 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3500 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3503 DIE(aTHX_ "Not a HASH reference");
3518 if (PL_op->op_private & OPpEXISTS_SUB) {
3522 cv = sv_2cv(sv, &hv, &gv, FALSE);
3525 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3531 if (SvTYPE(hv) == SVt_PVHV) {
3532 if (hv_exists_ent(hv, tmpsv, 0))
3535 else if (SvTYPE(hv) == SVt_PVAV) {
3536 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3537 if (av_exists((AV*)hv, SvIV(tmpsv)))
3540 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3544 DIE(aTHX_ "Not a HASH reference");
3551 dSP; dMARK; dORIGMARK;
3552 register HV *hv = (HV*)POPs;
3553 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3554 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3556 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3557 DIE(aTHX_ "Can't localize pseudo-hash element");
3559 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3560 while (++MARK <= SP) {
3563 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3564 realhv ? hv_exists_ent(hv, keysv, 0)
3565 : avhv_exists_ent((AV*)hv, keysv, 0);
3567 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3568 svp = he ? &HeVAL(he) : 0;
3571 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3574 if (!svp || *svp == &PL_sv_undef) {
3576 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3578 if (PL_op->op_private & OPpLVAL_INTRO) {
3580 save_helem(hv, keysv, svp);
3583 char *key = SvPV(keysv, keylen);
3584 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3588 *MARK = svp ? *svp : &PL_sv_undef;
3591 if (GIMME != G_ARRAY) {
3599 /* List operators. */
3604 if (GIMME != G_ARRAY) {
3606 *MARK = *SP; /* unwanted list, return last item */
3608 *MARK = &PL_sv_undef;
3617 SV **lastrelem = PL_stack_sp;
3618 SV **lastlelem = PL_stack_base + POPMARK;
3619 SV **firstlelem = PL_stack_base + POPMARK + 1;
3620 register SV **firstrelem = lastlelem + 1;
3621 I32 arybase = PL_curcop->cop_arybase;
3622 I32 lval = PL_op->op_flags & OPf_MOD;
3623 I32 is_something_there = lval;
3625 register I32 max = lastrelem - lastlelem;
3626 register SV **lelem;
3629 if (GIMME != G_ARRAY) {
3630 ix = SvIVx(*lastlelem);
3635 if (ix < 0 || ix >= max)
3636 *firstlelem = &PL_sv_undef;
3638 *firstlelem = firstrelem[ix];
3644 SP = firstlelem - 1;
3648 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3654 if (ix < 0 || ix >= max)
3655 *lelem = &PL_sv_undef;
3657 is_something_there = TRUE;
3658 if (!(*lelem = firstrelem[ix]))
3659 *lelem = &PL_sv_undef;
3662 if (is_something_there)
3665 SP = firstlelem - 1;
3671 dSP; dMARK; dORIGMARK;
3672 I32 items = SP - MARK;
3673 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3674 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3681 dSP; dMARK; dORIGMARK;
3682 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3686 SV *val = NEWSV(46, 0);
3688 sv_setsv(val, *++MARK);
3689 else if (ckWARN(WARN_MISC))
3690 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3691 (void)hv_store_ent(hv,key,val,0);
3700 dSP; dMARK; dORIGMARK;
3701 register AV *ary = (AV*)*++MARK;
3705 register I32 offset;
3706 register I32 length;
3713 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3714 *MARK-- = SvTIED_obj((SV*)ary, mg);
3718 call_method("SPLICE",GIMME_V);
3727 offset = i = SvIVx(*MARK);
3729 offset += AvFILLp(ary) + 1;
3731 offset -= PL_curcop->cop_arybase;
3733 DIE(aTHX_ PL_no_aelem, i);
3735 length = SvIVx(*MARK++);
3737 length += AvFILLp(ary) - offset + 1;
3743 length = AvMAX(ary) + 1; /* close enough to infinity */
3747 length = AvMAX(ary) + 1;
3749 if (offset > AvFILLp(ary) + 1)
3750 offset = AvFILLp(ary) + 1;
3751 after = AvFILLp(ary) + 1 - (offset + length);
3752 if (after < 0) { /* not that much array */
3753 length += after; /* offset+length now in array */
3759 /* At this point, MARK .. SP-1 is our new LIST */
3762 diff = newlen - length;
3763 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3766 if (diff < 0) { /* shrinking the area */
3768 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3769 Copy(MARK, tmparyval, newlen, SV*);
3772 MARK = ORIGMARK + 1;
3773 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3774 MEXTEND(MARK, length);
3775 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3777 EXTEND_MORTAL(length);
3778 for (i = length, dst = MARK; i; i--) {
3779 sv_2mortal(*dst); /* free them eventualy */
3786 *MARK = AvARRAY(ary)[offset+length-1];
3789 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3790 SvREFCNT_dec(*dst++); /* free them now */
3793 AvFILLp(ary) += diff;
3795 /* pull up or down? */
3797 if (offset < after) { /* easier to pull up */
3798 if (offset) { /* esp. if nothing to pull */
3799 src = &AvARRAY(ary)[offset-1];
3800 dst = src - diff; /* diff is negative */
3801 for (i = offset; i > 0; i--) /* can't trust Copy */
3805 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3809 if (after) { /* anything to pull down? */
3810 src = AvARRAY(ary) + offset + length;
3811 dst = src + diff; /* diff is negative */
3812 Move(src, dst, after, SV*);
3814 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3815 /* avoid later double free */
3819 dst[--i] = &PL_sv_undef;
3822 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3824 *dst = NEWSV(46, 0);
3825 sv_setsv(*dst++, *src++);
3827 Safefree(tmparyval);
3830 else { /* no, expanding (or same) */
3832 New(452, tmparyval, length, SV*); /* so remember deletion */
3833 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3836 if (diff > 0) { /* expanding */
3838 /* push up or down? */
3840 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3844 Move(src, dst, offset, SV*);
3846 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3848 AvFILLp(ary) += diff;
3851 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3852 av_extend(ary, AvFILLp(ary) + diff);
3853 AvFILLp(ary) += diff;
3856 dst = AvARRAY(ary) + AvFILLp(ary);
3858 for (i = after; i; i--) {
3865 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3866 *dst = NEWSV(46, 0);
3867 sv_setsv(*dst++, *src++);
3869 MARK = ORIGMARK + 1;
3870 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3872 Copy(tmparyval, MARK, length, SV*);
3874 EXTEND_MORTAL(length);
3875 for (i = length, dst = MARK; i; i--) {
3876 sv_2mortal(*dst); /* free them eventualy */
3880 Safefree(tmparyval);
3884 else if (length--) {
3885 *MARK = tmparyval[length];
3888 while (length-- > 0)
3889 SvREFCNT_dec(tmparyval[length]);
3891 Safefree(tmparyval);
3894 *MARK = &PL_sv_undef;
3902 dSP; dMARK; dORIGMARK; dTARGET;
3903 register AV *ary = (AV*)*++MARK;
3904 register SV *sv = &PL_sv_undef;
3907 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3908 *MARK-- = SvTIED_obj((SV*)ary, mg);
3912 call_method("PUSH",G_SCALAR|G_DISCARD);
3917 /* Why no pre-extend of ary here ? */
3918 for (++MARK; MARK <= SP; MARK++) {
3921 sv_setsv(sv, *MARK);
3926 PUSHi( AvFILL(ary) + 1 );
3934 SV *sv = av_pop(av);
3936 (void)sv_2mortal(sv);
3945 SV *sv = av_shift(av);
3950 (void)sv_2mortal(sv);
3957 dSP; dMARK; dORIGMARK; dTARGET;
3958 register AV *ary = (AV*)*++MARK;
3963 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3964 *MARK-- = SvTIED_obj((SV*)ary, mg);
3968 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3973 av_unshift(ary, SP - MARK);
3976 sv_setsv(sv, *++MARK);
3977 (void)av_store(ary, i++, sv);
3981 PUSHi( AvFILL(ary) + 1 );
3991 if (GIMME == G_ARRAY) {
3998 /* safe as long as stack cannot get extended in the above */
4003 register char *down;
4008 SvUTF8_off(TARG); /* decontaminate */
4010 do_join(TARG, &PL_sv_no, MARK, SP);
4012 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4013 up = SvPV_force(TARG, len);
4015 if (DO_UTF8(TARG)) { /* first reverse each character */
4016 U8* s = (U8*)SvPVX(TARG);
4017 U8* send = (U8*)(s + len);
4019 if (UTF8_IS_INVARIANT(*s)) {
4024 if (!utf8_to_uvchr(s, 0))
4028 down = (char*)(s - 1);
4029 /* reverse this character */
4039 down = SvPVX(TARG) + len - 1;
4045 (void)SvPOK_only_UTF8(TARG);
4054 S_mul128(pTHX_ SV *sv, U8 m)
4057 char *s = SvPV(sv, len);
4061 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4062 SV *tmpNew = newSVpvn("0000000000", 10);
4064 sv_catsv(tmpNew, sv);
4065 SvREFCNT_dec(sv); /* free old sv */
4070 while (!*t) /* trailing '\0'? */
4073 i = ((*t - '0') << 7) + m;
4074 *(t--) = '0' + (i % 10);
4080 /* Explosives and implosives. */
4082 #if 'I' == 73 && 'J' == 74
4083 /* On an ASCII/ISO kind of system */
4084 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4087 Some other sort of character set - use memchr() so we don't match
4090 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4098 I32 start_sp_offset = SP - PL_stack_base;
4099 I32 gimme = GIMME_V;
4103 register char *pat = SvPV(left, llen);
4104 #ifdef PACKED_IS_OCTETS
4105 /* Packed side is assumed to be octets - so force downgrade if it
4106 has been UTF-8 encoded by accident
4108 register char *s = SvPVbyte(right, rlen);
4110 register char *s = SvPV(right, rlen);
4112 char *strend = s + rlen;
4114 register char *patend = pat + llen;
4120 /* These must not be in registers: */
4137 register U32 culong;
4141 #ifdef PERL_NATINT_PACK
4142 int natint; /* native integer */
4143 int unatint; /* unsigned native integer */
4146 if (gimme != G_ARRAY) { /* arrange to do first one only */
4148 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4149 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4151 while (isDIGIT(*patend) || *patend == '*')
4157 while (pat < patend) {
4159 datumtype = *pat++ & 0xFF;
4160 #ifdef PERL_NATINT_PACK
4163 if (isSPACE(datumtype))
4165 if (datumtype == '#') {
4166 while (pat < patend && *pat != '\n')
4171 char *natstr = "sSiIlL";
4173 if (strchr(natstr, datumtype)) {
4174 #ifdef PERL_NATINT_PACK
4180 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4185 else if (*pat == '*') {
4186 len = strend - strbeg; /* long enough */
4190 else if (isDIGIT(*pat)) {
4192 while (isDIGIT(*pat)) {
4193 len = (len * 10) + (*pat++ - '0');
4195 DIE(aTHX_ "Repeat count in unpack overflows");
4199 len = (datumtype != '@');
4203 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4204 case ',': /* grandfather in commas but with a warning */
4205 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4206 Perl_warner(aTHX_ WARN_UNPACK,
4207 "Invalid type in unpack: '%c'", (int)datumtype);
4210 if (len == 1 && pat[-1] != '1')
4219 if (len > strend - strbeg)
4220 DIE(aTHX_ "@ outside of string");
4224 if (len > s - strbeg)
4225 DIE(aTHX_ "X outside of string");
4229 if (len > strend - s)
4230 DIE(aTHX_ "x outside of string");
4234 if (start_sp_offset >= SP - PL_stack_base)
4235 DIE(aTHX_ "/ must follow a numeric type");
4238 pat++; /* ignore '*' for compatibility with pack */
4240 DIE(aTHX_ "/ cannot take a count" );
4247 if (len > strend - s)
4250 goto uchar_checksum;
4251 sv = NEWSV(35, len);
4252 sv_setpvn(sv, s, len);
4254 if (datumtype == 'A' || datumtype == 'Z') {
4255 aptr = s; /* borrow register */
4256 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4261 else { /* 'A' strips both nulls and spaces */
4262 s = SvPVX(sv) + len - 1;
4263 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4267 SvCUR_set(sv, s - SvPVX(sv));
4268 s = aptr; /* unborrow register */
4270 XPUSHs(sv_2mortal(sv));
4274 if (star || len > (strend - s) * 8)
4275 len = (strend - s) * 8;
4278 Newz(601, PL_bitcount, 256, char);
4279 for (bits = 1; bits < 256; bits++) {
4280 if (bits & 1) PL_bitcount[bits]++;
4281 if (bits & 2) PL_bitcount[bits]++;
4282 if (bits & 4) PL_bitcount[bits]++;
4283 if (bits & 8) PL_bitcount[bits]++;
4284 if (bits & 16) PL_bitcount[bits]++;
4285 if (bits & 32) PL_bitcount[bits]++;
4286 if (bits & 64) PL_bitcount[bits]++;
4287 if (bits & 128) PL_bitcount[bits]++;
4291 culong += PL_bitcount[*(unsigned char*)s++];
4296 if (datumtype == 'b') {
4298 if (bits & 1) culong++;
4304 if (bits & 128) culong++;
4311 sv = NEWSV(35, len + 1);
4315 if (datumtype == 'b') {
4317 for (len = 0; len < aint; len++) {
4318 if (len & 7) /*SUPPRESS 595*/
4322 *str++ = '0' + (bits & 1);
4327 for (len = 0; len < aint; len++) {
4332 *str++ = '0' + ((bits & 128) != 0);
4336 XPUSHs(sv_2mortal(sv));
4340 if (star || len > (strend - s) * 2)
4341 len = (strend - s) * 2;
4342 sv = NEWSV(35, len + 1);
4346 if (datumtype == 'h') {
4348 for (len = 0; len < aint; len++) {
4353 *str++ = PL_hexdigit[bits & 15];
4358 for (len = 0; len < aint; len++) {
4363 *str++ = PL_hexdigit[(bits >> 4) & 15];
4367 XPUSHs(sv_2mortal(sv));
4370 if (len > strend - s)
4375 if (aint >= 128) /* fake up signed chars */
4385 if (aint >= 128) /* fake up signed chars */
4388 sv_setiv(sv, (IV)aint);
4389 PUSHs(sv_2mortal(sv));
4394 if (len > strend - s)
4409 sv_setiv(sv, (IV)auint);
4410 PUSHs(sv_2mortal(sv));
4415 if (len > strend - s)
4418 while (len-- > 0 && s < strend) {
4420 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4424 cdouble += (NV)auint;
4432 while (len-- > 0 && s < strend) {
4434 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4438 sv_setuv(sv, (UV)auint);
4439 PUSHs(sv_2mortal(sv));
4444 #if SHORTSIZE == SIZE16
4445 along = (strend - s) / SIZE16;
4447 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4452 #if SHORTSIZE != SIZE16
4456 COPYNN(s, &ashort, sizeof(short));
4467 #if SHORTSIZE > SIZE16
4479 #if SHORTSIZE != SIZE16
4483 COPYNN(s, &ashort, sizeof(short));
4486 sv_setiv(sv, (IV)ashort);
4487 PUSHs(sv_2mortal(sv));
4495 #if SHORTSIZE > SIZE16
4501 sv_setiv(sv, (IV)ashort);
4502 PUSHs(sv_2mortal(sv));
4510 #if SHORTSIZE == SIZE16
4511 along = (strend - s) / SIZE16;
4513 unatint = natint && datumtype == 'S';
4514 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4519 #if SHORTSIZE != SIZE16
4521 unsigned short aushort;
4523 COPYNN(s, &aushort, sizeof(unsigned short));
4524 s += sizeof(unsigned short);
4532 COPY16(s, &aushort);
4535 if (datumtype == 'n')
4536 aushort = PerlSock_ntohs(aushort);
4539 if (datumtype == 'v')
4540 aushort = vtohs(aushort);
4549 #if SHORTSIZE != SIZE16
4551 unsigned short aushort;
4553 COPYNN(s, &aushort, sizeof(unsigned short));
4554 s += sizeof(unsigned short);
4556 sv_setiv(sv, (UV)aushort);
4557 PUSHs(sv_2mortal(sv));
4564 COPY16(s, &aushort);
4568 if (datumtype == 'n')
4569 aushort = PerlSock_ntohs(aushort);
4572 if (datumtype == 'v')
4573 aushort = vtohs(aushort);
4575 sv_setiv(sv, (UV)aushort);
4576 PUSHs(sv_2mortal(sv));
4582 along = (strend - s) / sizeof(int);
4587 Copy(s, &aint, 1, int);
4590 cdouble += (NV)aint;
4599 Copy(s, &aint, 1, int);
4603 /* Without the dummy below unpack("i", pack("i",-1))
4604 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4605 * cc with optimization turned on.
4607 * The bug was detected in
4608 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4609 * with optimization (-O4) turned on.
4610 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4611 * does not have this problem even with -O4.
4613 * This bug was reported as DECC_BUGS 1431
4614 * and tracked internally as GEM_BUGS 7775.
4616 * The bug is fixed in
4617 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4618 * UNIX V4.0F support: DEC C V5.9-006 or later
4619 * UNIX V4.0E support: DEC C V5.8-011 or later
4622 * See also few lines later for the same bug.
4625 sv_setiv(sv, (IV)aint) :
4627 sv_setiv(sv, (IV)aint);
4628 PUSHs(sv_2mortal(sv));
4633 along = (strend - s) / sizeof(unsigned int);
4638 Copy(s, &auint, 1, unsigned int);
4639 s += sizeof(unsigned int);
4641 cdouble += (NV)auint;
4650 Copy(s, &auint, 1, unsigned int);
4651 s += sizeof(unsigned int);
4654 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4655 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4656 * See details few lines earlier. */
4658 sv_setuv(sv, (UV)auint) :
4660 sv_setuv(sv, (UV)auint);
4661 PUSHs(sv_2mortal(sv));
4666 #if LONGSIZE == SIZE32
4667 along = (strend - s) / SIZE32;
4669 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4674 #if LONGSIZE != SIZE32
4677 COPYNN(s, &along, sizeof(long));
4680 cdouble += (NV)along;
4689 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4693 #if LONGSIZE > SIZE32
4694 if (along > 2147483647)
4695 along -= 4294967296;
4699 cdouble += (NV)along;
4708 #if LONGSIZE != SIZE32
4711 COPYNN(s, &along, sizeof(long));
4714 sv_setiv(sv, (IV)along);
4715 PUSHs(sv_2mortal(sv));
4722 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4726 #if LONGSIZE > SIZE32
4727 if (along > 2147483647)
4728 along -= 4294967296;
4732 sv_setiv(sv, (IV)along);
4733 PUSHs(sv_2mortal(sv));
4741 #if LONGSIZE == SIZE32
4742 along = (strend - s) / SIZE32;
4744 unatint = natint && datumtype == 'L';
4745 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4750 #if LONGSIZE != SIZE32
4752 unsigned long aulong;
4754 COPYNN(s, &aulong, sizeof(unsigned long));
4755 s += sizeof(unsigned long);
4757 cdouble += (NV)aulong;
4769 if (datumtype == 'N')
4770 aulong = PerlSock_ntohl(aulong);
4773 if (datumtype == 'V')
4774 aulong = vtohl(aulong);
4777 cdouble += (NV)aulong;
4786 #if LONGSIZE != SIZE32
4788 unsigned long aulong;
4790 COPYNN(s, &aulong, sizeof(unsigned long));
4791 s += sizeof(unsigned long);
4793 sv_setuv(sv, (UV)aulong);
4794 PUSHs(sv_2mortal(sv));
4804 if (datumtype == 'N')
4805 aulong = PerlSock_ntohl(aulong);
4808 if (datumtype == 'V')
4809 aulong = vtohl(aulong);
4812 sv_setuv(sv, (UV)aulong);
4813 PUSHs(sv_2mortal(sv));
4819 along = (strend - s) / sizeof(char*);
4825 if (sizeof(char*) > strend - s)
4828 Copy(s, &aptr, 1, char*);
4834 PUSHs(sv_2mortal(sv));
4844 while ((len > 0) && (s < strend)) {
4845 auv = (auv << 7) | (*s & 0x7f);
4846 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4847 if ((U8)(*s++) < 0x80) {
4851 PUSHs(sv_2mortal(sv));
4855 else if (++bytes >= sizeof(UV)) { /* promote to string */
4859 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4860 while (s < strend) {
4861 sv = mul128(sv, *s & 0x7f);
4862 if (!(*s++ & 0x80)) {
4871 PUSHs(sv_2mortal(sv));
4876 if ((s >= strend) && bytes)
4877 DIE(aTHX_ "Unterminated compressed integer");
4882 if (sizeof(char*) > strend - s)
4885 Copy(s, &aptr, 1, char*);
4890 sv_setpvn(sv, aptr, len);
4891 PUSHs(sv_2mortal(sv));
4895 along = (strend - s) / sizeof(Quad_t);
4901 if (s + sizeof(Quad_t) > strend)
4904 Copy(s, &aquad, 1, Quad_t);
4905 s += sizeof(Quad_t);
4908 if (aquad >= IV_MIN && aquad <= IV_MAX)
4909 sv_setiv(sv, (IV)aquad);
4911 sv_setnv(sv, (NV)aquad);
4912 PUSHs(sv_2mortal(sv));
4916 along = (strend - s) / sizeof(Quad_t);
4922 if (s + sizeof(Uquad_t) > strend)
4925 Copy(s, &auquad, 1, Uquad_t);
4926 s += sizeof(Uquad_t);
4929 if (auquad <= UV_MAX)
4930 sv_setuv(sv, (UV)auquad);
4932 sv_setnv(sv, (NV)auquad);
4933 PUSHs(sv_2mortal(sv));
4937 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4940 along = (strend - s) / sizeof(float);
4945 Copy(s, &afloat, 1, float);
4954 Copy(s, &afloat, 1, float);
4957 sv_setnv(sv, (NV)afloat);
4958 PUSHs(sv_2mortal(sv));
4964 along = (strend - s) / sizeof(double);
4969 Copy(s, &adouble, 1, double);
4970 s += sizeof(double);
4978 Copy(s, &adouble, 1, double);
4979 s += sizeof(double);
4981 sv_setnv(sv, (NV)adouble);
4982 PUSHs(sv_2mortal(sv));
4988 * Initialise the decode mapping. By using a table driven
4989 * algorithm, the code will be character-set independent
4990 * (and just as fast as doing character arithmetic)
4992 if (PL_uudmap['M'] == 0) {
4995 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4996 PL_uudmap[(U8)PL_uuemap[i]] = i;
4998 * Because ' ' and '`' map to the same value,
4999 * we need to decode them both the same.
5004 along = (strend - s) * 3 / 4;
5005 sv = NEWSV(42, along);
5008 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
5013 len = PL_uudmap[*(U8*)s++] & 077;
5015 if (s < strend && ISUUCHAR(*s))
5016 a = PL_uudmap[*(U8*)s++] & 077;
5019 if (s < strend && ISUUCHAR(*s))
5020 b = PL_uudmap[*(U8*)s++] & 077;
5023 if (s < strend && ISUUCHAR(*s))
5024 c = PL_uudmap[*(U8*)s++] & 077;
5027 if (s < strend && ISUUCHAR(*s))
5028 d = PL_uudmap[*(U8*)s++] & 077;
5031 hunk[0] = (a << 2) | (b >> 4);
5032 hunk[1] = (b << 4) | (c >> 2);
5033 hunk[2] = (c << 6) | d;
5034 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5039 else if (s[1] == '\n') /* possible checksum byte */
5042 XPUSHs(sv_2mortal(sv));
5047 if (strchr("fFdD", datumtype) ||
5048 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5052 while (checksum >= 16) {
5056 while (checksum >= 4) {
5062 along = (1 << checksum) - 1;
5063 while (cdouble < 0.0)
5065 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5066 sv_setnv(sv, cdouble);
5069 if (checksum < 32) {
5070 aulong = (1 << checksum) - 1;
5073 sv_setuv(sv, (UV)culong);
5075 XPUSHs(sv_2mortal(sv));
5079 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5080 PUSHs(&PL_sv_undef);
5085 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5089 *hunk = PL_uuemap[len];
5090 sv_catpvn(sv, hunk, 1);
5093 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5094 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5095 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5096 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5097 sv_catpvn(sv, hunk, 4);
5102 char r = (len > 1 ? s[1] : '\0');
5103 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5104 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5105 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5106 hunk[3] = PL_uuemap[0];
5107 sv_catpvn(sv, hunk, 4);
5109 sv_catpvn(sv, "\n", 1);
5113 S_is_an_int(pTHX_ char *s, STRLEN l)
5116 SV *result = newSVpvn(s, l);
5117 char *result_c = SvPV(result, n_a); /* convenience */
5118 char *out = result_c;
5128 SvREFCNT_dec(result);
5151 SvREFCNT_dec(result);
5157 SvCUR_set(result, out - result_c);
5161 /* pnum must be '\0' terminated */
5163 S_div128(pTHX_ SV *pnum, bool *done)
5166 char *s = SvPV(pnum, len);
5175 i = m * 10 + (*t - '0');
5177 r = (i >> 7); /* r < 10 */
5184 SvCUR_set(pnum, (STRLEN) (t - s));
5191 dSP; dMARK; dORIGMARK; dTARGET;
5192 register SV *cat = TARG;
5195 register char *pat = SvPVx(*++MARK, fromlen);
5197 register char *patend = pat + fromlen;
5202 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5203 static char *space10 = " ";
5205 /* These must not be in registers: */
5220 #ifdef PERL_NATINT_PACK
5221 int natint; /* native integer */
5226 sv_setpvn(cat, "", 0);
5228 while (pat < patend) {
5229 SV *lengthcode = Nullsv;
5230 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5231 datumtype = *pat++ & 0xFF;
5232 #ifdef PERL_NATINT_PACK
5235 if (isSPACE(datumtype)) {
5239 #ifndef PACKED_IS_OCTETS
5240 if (datumtype == 'U' && pat == patcopy+1)
5243 if (datumtype == '#') {
5244 while (pat < patend && *pat != '\n')
5249 char *natstr = "sSiIlL";
5251 if (strchr(natstr, datumtype)) {
5252 #ifdef PERL_NATINT_PACK
5258 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5261 len = strchr("@Xxu", datumtype) ? 0 : items;
5264 else if (isDIGIT(*pat)) {
5266 while (isDIGIT(*pat)) {
5267 len = (len * 10) + (*pat++ - '0');
5269 DIE(aTHX_ "Repeat count in pack overflows");
5276 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5277 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5278 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5279 ? *MARK : &PL_sv_no)
5280 + (*pat == 'Z' ? 1 : 0)));
5284 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5285 case ',': /* grandfather in commas but with a warning */
5286 if (commas++ == 0 && ckWARN(WARN_PACK))
5287 Perl_warner(aTHX_ WARN_PACK,
5288 "Invalid type in pack: '%c'", (int)datumtype);
5291 DIE(aTHX_ "%% may only be used in unpack");
5302 if (SvCUR(cat) < len)
5303 DIE(aTHX_ "X outside of string");
5310 sv_catpvn(cat, null10, 10);
5313 sv_catpvn(cat, null10, len);
5319 aptr = SvPV(fromstr, fromlen);
5320 if (pat[-1] == '*') {
5322 if (datumtype == 'Z')
5325 if (fromlen >= len) {
5326 sv_catpvn(cat, aptr, len);
5327 if (datumtype == 'Z')
5328 *(SvEND(cat)-1) = '\0';
5331 sv_catpvn(cat, aptr, fromlen);
5333 if (datumtype == 'A') {
5335 sv_catpvn(cat, space10, 10);
5338 sv_catpvn(cat, space10, len);
5342 sv_catpvn(cat, null10, 10);
5345 sv_catpvn(cat, null10, len);
5357 str = SvPV(fromstr, fromlen);
5361 SvCUR(cat) += (len+7)/8;
5362 SvGROW(cat, SvCUR(cat) + 1);
5363 aptr = SvPVX(cat) + aint;
5368 if (datumtype == 'B') {
5369 for (len = 0; len++ < aint;) {
5370 items |= *str++ & 1;
5374 *aptr++ = items & 0xff;
5380 for (len = 0; len++ < aint;) {
5386 *aptr++ = items & 0xff;
5392 if (datumtype == 'B')
5393 items <<= 7 - (aint & 7);
5395 items >>= 7 - (aint & 7);
5396 *aptr++ = items & 0xff;
5398 str = SvPVX(cat) + SvCUR(cat);
5413 str = SvPV(fromstr, fromlen);
5417 SvCUR(cat) += (len+1)/2;
5418 SvGROW(cat, SvCUR(cat) + 1);
5419 aptr = SvPVX(cat) + aint;
5424 if (datumtype == 'H') {
5425 for (len = 0; len++ < aint;) {
5427 items |= ((*str++ & 15) + 9) & 15;
5429 items |= *str++ & 15;
5433 *aptr++ = items & 0xff;
5439 for (len = 0; len++ < aint;) {
5441 items |= (((*str++ & 15) + 9) & 15) << 4;
5443 items |= (*str++ & 15) << 4;
5447 *aptr++ = items & 0xff;
5453 *aptr++ = items & 0xff;
5454 str = SvPVX(cat) + SvCUR(cat);
5465 aint = SvIV(fromstr);
5467 sv_catpvn(cat, &achar, sizeof(char));
5473 auint = SvUV(fromstr);
5474 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5475 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5480 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5485 afloat = (float)SvNV(fromstr);
5486 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5493 adouble = (double)SvNV(fromstr);
5494 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5500 ashort = (I16)SvIV(fromstr);
5502 ashort = PerlSock_htons(ashort);
5504 CAT16(cat, &ashort);
5510 ashort = (I16)SvIV(fromstr);
5512 ashort = htovs(ashort);
5514 CAT16(cat, &ashort);
5518 #if SHORTSIZE != SIZE16
5520 unsigned short aushort;
5524 aushort = SvUV(fromstr);
5525 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5535 aushort = (U16)SvUV(fromstr);
5536 CAT16(cat, &aushort);
5542 #if SHORTSIZE != SIZE16
5548 ashort = SvIV(fromstr);
5549 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5557 ashort = (I16)SvIV(fromstr);
5558 CAT16(cat, &ashort);
5565 auint = SvUV(fromstr);
5566 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5572 adouble = Perl_floor(SvNV(fromstr));
5575 DIE(aTHX_ "Cannot compress negative numbers");
5578 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5579 adouble <= 0xffffffff
5581 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5582 adouble <= UV_MAX_cxux
5589 char buf[1 + sizeof(UV)];
5590 char *in = buf + sizeof(buf);
5591 UV auv = U_V(adouble);
5594 *--in = (auv & 0x7f) | 0x80;
5597 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5598 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5600 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5601 char *from, *result, *in;
5606 /* Copy string and check for compliance */
5607 from = SvPV(fromstr, len);
5608 if ((norm = is_an_int(from, len)) == NULL)
5609 DIE(aTHX_ "can compress only unsigned integer");
5611 New('w', result, len, char);
5615 *--in = div128(norm, &done) | 0x80;
5616 result[len - 1] &= 0x7F; /* clear continue bit */
5617 sv_catpvn(cat, in, (result + len) - in);
5619 SvREFCNT_dec(norm); /* free norm */
5621 else if (SvNOKp(fromstr)) {
5622 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5623 char *in = buf + sizeof(buf);
5626 double next = floor(adouble / 128);
5627 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5628 if (in <= buf) /* this cannot happen ;-) */
5629 DIE(aTHX_ "Cannot compress integer");
5632 } while (adouble > 0);
5633 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5634 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5637 DIE(aTHX_ "Cannot compress non integer");
5643 aint = SvIV(fromstr);
5644 sv_catpvn(cat, (char*)&aint, sizeof(int));
5650 aulong = SvUV(fromstr);
5652 aulong = PerlSock_htonl(aulong);
5654 CAT32(cat, &aulong);
5660 aulong = SvUV(fromstr);
5662 aulong = htovl(aulong);
5664 CAT32(cat, &aulong);
5668 #if LONGSIZE != SIZE32
5670 unsigned long aulong;
5674 aulong = SvUV(fromstr);
5675 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5683 aulong = SvUV(fromstr);
5684 CAT32(cat, &aulong);
5689 #if LONGSIZE != SIZE32
5695 along = SvIV(fromstr);
5696 sv_catpvn(cat, (char *)&along, sizeof(long));
5704 along = SvIV(fromstr);
5713 auquad = (Uquad_t)SvUV(fromstr);
5714 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5720 aquad = (Quad_t)SvIV(fromstr);
5721 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5726 len = 1; /* assume SV is correct length */
5731 if (fromstr == &PL_sv_undef)
5735 /* XXX better yet, could spirit away the string to
5736 * a safe spot and hang on to it until the result
5737 * of pack() (and all copies of the result) are
5740 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5741 || (SvPADTMP(fromstr)
5742 && !SvREADONLY(fromstr))))
5744 Perl_warner(aTHX_ WARN_PACK,
5745 "Attempt to pack pointer to temporary value");
5747 if (SvPOK(fromstr) || SvNIOK(fromstr))
5748 aptr = SvPV(fromstr,n_a);
5750 aptr = SvPV_force(fromstr,n_a);
5752 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5757 aptr = SvPV(fromstr, fromlen);
5758 SvGROW(cat, fromlen * 4 / 3);
5763 while (fromlen > 0) {
5770 doencodes(cat, aptr, todo);
5789 register IV limit = POPi; /* note, negative is forever */
5792 register char *s = SvPV(sv, len);
5793 bool do_utf8 = DO_UTF8(sv);
5794 char *strend = s + len;
5796 register REGEXP *rx;
5800 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5801 I32 maxiters = slen + 10;
5804 I32 origlimit = limit;
5807 AV *oldstack = PL_curstack;
5808 I32 gimme = GIMME_V;
5809 I32 oldsave = PL_savestack_ix;
5810 I32 make_mortal = 1;
5811 MAGIC *mg = (MAGIC *) NULL;
5814 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5819 DIE(aTHX_ "panic: pp_split");
5820 rx = pm->op_pmregexp;
5822 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5823 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5825 if (pm->op_pmreplroot) {
5827 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5829 ary = GvAVn((GV*)pm->op_pmreplroot);
5832 else if (gimme != G_ARRAY)
5834 ary = (AV*)PL_curpad[0];
5836 ary = GvAVn(PL_defgv);
5837 #endif /* USE_THREADS */
5840 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5846 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5848 XPUSHs(SvTIED_obj((SV*)ary, mg));
5854 for (i = AvFILLp(ary); i >= 0; i--)
5855 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5857 /* temporarily switch stacks */
5858 SWITCHSTACK(PL_curstack, ary);
5862 base = SP - PL_stack_base;
5864 if (pm->op_pmflags & PMf_SKIPWHITE) {
5865 if (pm->op_pmflags & PMf_LOCALE) {
5866 while (isSPACE_LC(*s))
5874 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5875 SAVEINT(PL_multiline);
5876 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5880 limit = maxiters + 2;
5881 if (pm->op_pmflags & PMf_WHITE) {
5884 while (m < strend &&
5885 !((pm->op_pmflags & PMf_LOCALE)
5886 ? isSPACE_LC(*m) : isSPACE(*m)))
5891 dstr = NEWSV(30, m-s);
5892 sv_setpvn(dstr, s, m-s);
5896 (void)SvUTF8_on(dstr);
5900 while (s < strend &&
5901 ((pm->op_pmflags & PMf_LOCALE)
5902 ? isSPACE_LC(*s) : isSPACE(*s)))
5906 else if (strEQ("^", rx->precomp)) {
5909 for (m = s; m < strend && *m != '\n'; m++) ;
5913 dstr = NEWSV(30, m-s);
5914 sv_setpvn(dstr, s, m-s);
5918 (void)SvUTF8_on(dstr);
5923 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5924 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5925 && (rx->reganch & ROPT_CHECK_ALL)
5926 && !(rx->reganch & ROPT_ANCH)) {
5927 int tail = (rx->reganch & RE_INTUIT_TAIL);
5928 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5931 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5933 char c = *SvPV(csv, n_a);
5936 for (m = s; m < strend && *m != c; m++) ;
5939 dstr = NEWSV(30, m-s);
5940 sv_setpvn(dstr, s, m-s);
5944 (void)SvUTF8_on(dstr);
5946 /* The rx->minlen is in characters but we want to step
5947 * s ahead by bytes. */
5949 s = (char*)utf8_hop((U8*)m, len);
5951 s = m + len; /* Fake \n at the end */
5956 while (s < strend && --limit &&
5957 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5958 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5961 dstr = NEWSV(31, m-s);
5962 sv_setpvn(dstr, s, m-s);
5966 (void)SvUTF8_on(dstr);
5968 /* The rx->minlen is in characters but we want to step
5969 * s ahead by bytes. */
5971 s = (char*)utf8_hop((U8*)m, len);
5973 s = m + len; /* Fake \n at the end */
5978 maxiters += slen * rx->nparens;
5979 while (s < strend && --limit
5980 /* && (!rx->check_substr
5981 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5983 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5984 1 /* minend */, sv, NULL, 0))
5986 TAINT_IF(RX_MATCH_TAINTED(rx));
5987 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5992 strend = s + (strend - m);
5994 m = rx->startp[0] + orig;
5995 dstr = NEWSV(32, m-s);
5996 sv_setpvn(dstr, s, m-s);
6000 (void)SvUTF8_on(dstr);
6003 for (i = 1; i <= rx->nparens; i++) {
6004 s = rx->startp[i] + orig;
6005 m = rx->endp[i] + orig;
6007 dstr = NEWSV(33, m-s);
6008 sv_setpvn(dstr, s, m-s);
6011 dstr = NEWSV(33, 0);
6015 (void)SvUTF8_on(dstr);
6019 s = rx->endp[0] + orig;
6023 LEAVE_SCOPE(oldsave);
6024 iters = (SP - PL_stack_base) - base;
6025 if (iters > maxiters)
6026 DIE(aTHX_ "Split loop");
6028 /* keep field after final delim? */
6029 if (s < strend || (iters && origlimit)) {
6030 STRLEN l = strend - s;
6031 dstr = NEWSV(34, l);
6032 sv_setpvn(dstr, s, l);
6036 (void)SvUTF8_on(dstr);
6040 else if (!origlimit) {
6041 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6047 SWITCHSTACK(ary, oldstack);
6048 if (SvSMAGICAL(ary)) {
6053 if (gimme == G_ARRAY) {
6055 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6063 call_method("PUSH",G_SCALAR|G_DISCARD);
6066 if (gimme == G_ARRAY) {
6067 /* EXTEND should not be needed - we just popped them */
6069 for (i=0; i < iters; i++) {
6070 SV **svp = av_fetch(ary, i, FALSE);
6071 PUSHs((svp) ? *svp : &PL_sv_undef);
6078 if (gimme == G_ARRAY)
6081 if (iters || !pm->op_pmreplroot) {
6091 Perl_unlock_condpair(pTHX_ void *svv)
6093 MAGIC *mg = mg_find((SV*)svv, 'm');
6096 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6097 MUTEX_LOCK(MgMUTEXP(mg));
6098 if (MgOWNER(mg) != thr)
6099 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6101 COND_SIGNAL(MgOWNERCONDP(mg));
6102 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6103 PTR2UV(thr), PTR2UV(svv));)
6104 MUTEX_UNLOCK(MgMUTEXP(mg));
6106 #endif /* USE_THREADS */
6115 #endif /* USE_THREADS */
6116 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6117 || SvTYPE(retsv) == SVt_PVCV) {
6118 retsv = refto(retsv);
6129 if (PL_op->op_private & OPpLVAL_INTRO)
6130 PUSHs(*save_threadsv(PL_op->op_targ));
6132 PUSHs(THREADSV(PL_op->op_targ));
6135 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6136 #endif /* USE_THREADS */