3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if LONGSIZE > 4 && defined(_CRAY)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
85 /* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
89 #ifdef NEED_GETPID_PROTO
90 extern Pid_t getpid (void);
96 if (GIMME_V == G_SCALAR)
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
114 if (PL_op->op_flags & OPf_REF) {
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
123 if (GIMME == G_ARRAY) {
124 I32 maxarg = AvFILL((AV*)TARG) + 1;
126 if (SvMAGICAL(TARG)) {
128 for (i=0; i < maxarg; i++) {
129 SV **svp = av_fetch((AV*)TARG, i, FALSE);
130 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
134 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
139 SV* sv = sv_newmortal();
140 I32 maxarg = AvFILL((AV*)TARG) + 1;
141 sv_setiv(sv, maxarg);
153 if (PL_op->op_private & OPpLVAL_INTRO)
154 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
155 if (PL_op->op_flags & OPf_REF)
158 if (GIMME == G_SCALAR)
159 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
163 if (gimme == G_ARRAY) {
166 else if (gimme == G_SCALAR) {
167 SV* sv = sv_newmortal();
168 if (HvFILL((HV*)TARG))
169 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
170 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
180 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
191 tryAMAGICunDEREF(to_gv);
194 if (SvTYPE(sv) == SVt_PVIO) {
195 GV *gv = (GV*) sv_newmortal();
196 gv_init(gv, 0, "", 0, 0);
197 GvIOp(gv) = (IO *)sv;
198 (void)SvREFCNT_inc(sv);
201 else if (SvTYPE(sv) != SVt_PVGV)
202 DIE(aTHX_ "Not a GLOB reference");
205 if (SvTYPE(sv) != SVt_PVGV) {
209 if (SvGMAGICAL(sv)) {
214 if (!SvOK(sv) && sv != &PL_sv_undef) {
215 /* If this is a 'my' scalar and flag is set then vivify
218 if (PL_op->op_private & OPpDEREF) {
221 if (cUNOP->op_targ) {
223 SV *namesv = PL_curpad[cUNOP->op_targ];
224 name = SvPV(namesv, len);
225 gv = (GV*)NEWSV(0,0);
226 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
229 name = CopSTASHPV(PL_curcop);
232 if (SvTYPE(sv) < SVt_RV)
233 sv_upgrade(sv, SVt_RV);
239 if (PL_op->op_flags & OPf_REF ||
240 PL_op->op_private & HINT_STRICT_REFS)
241 DIE(aTHX_ PL_no_usym, "a symbol");
242 if (ckWARN(WARN_UNINITIALIZED))
247 if ((PL_op->op_flags & OPf_SPECIAL) &&
248 !(PL_op->op_flags & OPf_MOD))
250 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
252 && (!is_gv_magical(sym,len,0)
253 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
259 if (PL_op->op_private & HINT_STRICT_REFS)
260 DIE(aTHX_ PL_no_symref, sym, "a symbol");
261 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
265 if (PL_op->op_private & OPpLVAL_INTRO)
266 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
277 tryAMAGICunDEREF(to_sv);
280 switch (SvTYPE(sv)) {
284 DIE(aTHX_ "Not a SCALAR reference");
292 if (SvTYPE(gv) != SVt_PVGV) {
293 if (SvGMAGICAL(sv)) {
299 if (PL_op->op_flags & OPf_REF ||
300 PL_op->op_private & HINT_STRICT_REFS)
301 DIE(aTHX_ PL_no_usym, "a SCALAR");
302 if (ckWARN(WARN_UNINITIALIZED))
307 if ((PL_op->op_flags & OPf_SPECIAL) &&
308 !(PL_op->op_flags & OPf_MOD))
310 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
312 && (!is_gv_magical(sym,len,0)
313 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
319 if (PL_op->op_private & HINT_STRICT_REFS)
320 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
321 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
326 if (PL_op->op_flags & OPf_MOD) {
327 if (PL_op->op_private & OPpLVAL_INTRO)
328 sv = save_scalar((GV*)TOPs);
329 else if (PL_op->op_private & OPpDEREF)
330 vivify_ref(sv, PL_op->op_private & OPpDEREF);
340 SV *sv = AvARYLEN(av);
342 AvARYLEN(av) = sv = NEWSV(0,0);
343 sv_upgrade(sv, SVt_IV);
344 sv_magic(sv, (SV*)av, '#', Nullch, 0);
352 dSP; dTARGET; dPOPss;
354 if (PL_op->op_flags & OPf_MOD || LVRET) {
355 if (SvTYPE(TARG) < SVt_PVLV) {
356 sv_upgrade(TARG, SVt_PVLV);
357 sv_magic(TARG, Nullsv, '.', Nullch, 0);
361 if (LvTARG(TARG) != sv) {
363 SvREFCNT_dec(LvTARG(TARG));
364 LvTARG(TARG) = SvREFCNT_inc(sv);
366 PUSHs(TARG); /* no SvSETMAGIC */
372 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
373 mg = mg_find(sv, 'g');
374 if (mg && mg->mg_len >= 0) {
378 PUSHi(i + PL_curcop->cop_arybase);
392 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
393 /* (But not in defined().) */
394 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
397 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
398 if ((PL_op->op_private & OPpLVAL_INTRO)) {
399 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
402 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
406 cv = (CV*)&PL_sv_undef;
420 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
421 char *s = SvPVX(TOPs);
422 if (strnEQ(s, "CORE::", 6)) {
425 code = keyword(s + 6, SvCUR(TOPs) - 6);
426 if (code < 0) { /* Overridable. */
427 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
428 int i = 0, n = 0, seen_question = 0;
430 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
432 while (i < MAXO) { /* The slow way. */
433 if (strEQ(s + 6, PL_op_name[i])
434 || strEQ(s + 6, PL_op_desc[i]))
440 goto nonesuch; /* Should not happen... */
442 oa = PL_opargs[i] >> OASHIFT;
444 if (oa & OA_OPTIONAL && !seen_question) {
448 else if (n && str[0] == ';' && seen_question)
449 goto set; /* XXXX system, exec */
450 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
451 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
454 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
455 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
459 ret = sv_2mortal(newSVpvn(str, n - 1));
461 else if (code) /* Non-Overridable */
463 else { /* None such */
465 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
469 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
471 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
480 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
482 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
498 if (GIMME != G_ARRAY) {
502 *MARK = &PL_sv_undef;
503 *MARK = refto(*MARK);
507 EXTEND_MORTAL(SP - MARK);
509 *MARK = refto(*MARK);
514 S_refto(pTHX_ SV *sv)
518 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
521 if (!(sv = LvTARG(sv)))
524 (void)SvREFCNT_inc(sv);
526 else if (SvTYPE(sv) == SVt_PVAV) {
527 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
530 (void)SvREFCNT_inc(sv);
532 else if (SvPADTMP(sv))
536 (void)SvREFCNT_inc(sv);
539 sv_upgrade(rv, SVt_RV);
553 if (sv && SvGMAGICAL(sv))
556 if (!sv || !SvROK(sv))
560 pv = sv_reftype(sv,TRUE);
561 PUSHp(pv, strlen(pv));
571 stash = CopSTASH(PL_curcop);
577 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
578 Perl_croak(aTHX_ "Attempt to bless into a reference");
580 if (ckWARN(WARN_MISC) && len == 0)
581 Perl_warner(aTHX_ WARN_MISC,
582 "Explicit blessing to '' (assuming package main)");
583 stash = gv_stashpvn(ptr, len, TRUE);
586 (void)sv_bless(TOPs, stash);
600 elem = SvPV(sv, n_a);
604 switch (elem ? *elem : '\0')
607 if (strEQ(elem, "ARRAY"))
608 tmpRef = (SV*)GvAV(gv);
611 if (strEQ(elem, "CODE"))
612 tmpRef = (SV*)GvCVu(gv);
615 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
616 tmpRef = (SV*)GvIOp(gv);
618 if (strEQ(elem, "FORMAT"))
619 tmpRef = (SV*)GvFORM(gv);
622 if (strEQ(elem, "GLOB"))
626 if (strEQ(elem, "HASH"))
627 tmpRef = (SV*)GvHV(gv);
630 if (strEQ(elem, "IO"))
631 tmpRef = (SV*)GvIOp(gv);
634 if (strEQ(elem, "NAME"))
635 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
638 if (strEQ(elem, "PACKAGE"))
639 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
642 if (strEQ(elem, "SCALAR"))
656 /* Pattern matching */
661 register unsigned char *s;
664 register I32 *sfirst;
668 if (sv == PL_lastscream) {
674 SvSCREAM_off(PL_lastscream);
675 SvREFCNT_dec(PL_lastscream);
677 PL_lastscream = SvREFCNT_inc(sv);
680 s = (unsigned char*)(SvPV(sv, len));
684 if (pos > PL_maxscream) {
685 if (PL_maxscream < 0) {
686 PL_maxscream = pos + 80;
687 New(301, PL_screamfirst, 256, I32);
688 New(302, PL_screamnext, PL_maxscream, I32);
691 PL_maxscream = pos + pos / 4;
692 Renew(PL_screamnext, PL_maxscream, I32);
696 sfirst = PL_screamfirst;
697 snext = PL_screamnext;
699 if (!sfirst || !snext)
700 DIE(aTHX_ "do_study: out of memory");
702 for (ch = 256; ch; --ch)
709 snext[pos] = sfirst[ch] - pos;
716 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
725 if (PL_op->op_flags & OPf_STACKED)
731 TARG = sv_newmortal();
736 /* Lvalue operators. */
748 dSP; dMARK; dTARGET; dORIGMARK;
750 do_chop(TARG, *++MARK);
759 SETi(do_chomp(TOPs));
766 register I32 count = 0;
769 count += do_chomp(POPs);
780 if (!sv || !SvANY(sv))
782 switch (SvTYPE(sv)) {
784 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
788 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
792 if (CvROOT(sv) || CvXSUB(sv))
809 if (!PL_op->op_private) {
818 if (SvTHINKFIRST(sv))
821 switch (SvTYPE(sv)) {
831 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
832 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
833 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
837 /* let user-undef'd sub keep its identity */
838 GV* gv = CvGV((CV*)sv);
845 SvSetMagicSV(sv, &PL_sv_undef);
849 Newz(602, gp, 1, GP);
850 GvGP(sv) = gp_ref(gp);
851 GvSV(sv) = NEWSV(72,0);
852 GvLINE(sv) = CopLINE(PL_curcop);
858 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
861 SvPV_set(sv, Nullch);
874 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
875 DIE(aTHX_ PL_no_modify);
876 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
877 SvIVX(TOPs) != IV_MIN)
880 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
891 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
892 DIE(aTHX_ PL_no_modify);
893 sv_setsv(TARG, TOPs);
894 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
895 SvIVX(TOPs) != IV_MAX)
898 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
912 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
913 DIE(aTHX_ PL_no_modify);
914 sv_setsv(TARG, TOPs);
915 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
916 SvIVX(TOPs) != IV_MIN)
919 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
928 /* Ordinary operators. */
932 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
935 SETn( Perl_pow( left, right) );
942 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
943 #ifdef PERL_PRESERVE_IVUV
946 /* Unless the left argument is integer in range we are going to have to
947 use NV maths. Hence only attempt to coerce the right argument if
948 we know the left is integer. */
949 /* Left operand is defined, so is it IV? */
952 bool auvok = SvUOK(TOPm1s);
953 bool buvok = SvUOK(TOPs);
954 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
955 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
962 alow = SvUVX(TOPm1s);
964 IV aiv = SvIVX(TOPm1s);
967 auvok = TRUE; /* effectively it's a UV now */
969 alow = -aiv; /* abs, auvok == false records sign */
975 IV biv = SvIVX(TOPs);
978 buvok = TRUE; /* effectively it's a UV now */
980 blow = -biv; /* abs, buvok == false records sign */
984 /* If this does sign extension on unsigned it's time for plan B */
985 ahigh = alow >> (4 * sizeof (UV));
987 bhigh = blow >> (4 * sizeof (UV));
989 if (ahigh && bhigh) {
990 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
991 which is overflow. Drop to NVs below. */
992 } else if (!ahigh && !bhigh) {
993 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
994 so the unsigned multiply cannot overflow. */
995 UV product = alow * blow;
996 if (auvok == buvok) {
997 /* -ve * -ve or +ve * +ve gives a +ve result. */
1001 } else if (product <= (UV)IV_MIN) {
1002 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1003 /* -ve result, which could overflow an IV */
1007 } /* else drop to NVs below. */
1009 /* One operand is large, 1 small */
1012 /* swap the operands */
1014 bhigh = blow; /* bhigh now the temp var for the swap */
1018 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1019 multiplies can't overflow. shift can, add can, -ve can. */
1020 product_middle = ahigh * blow;
1021 if (!(product_middle & topmask)) {
1022 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1024 product_middle <<= (4 * sizeof (UV));
1025 product_low = alow * blow;
1027 /* as for pp_add, UV + something mustn't get smaller.
1028 IIRC ANSI mandates this wrapping *behaviour* for
1029 unsigned whatever the actual representation*/
1030 product_low += product_middle;
1031 if (product_low >= product_middle) {
1032 /* didn't overflow */
1033 if (auvok == buvok) {
1034 /* -ve * -ve or +ve * +ve gives a +ve result. */
1036 SETu( product_low );
1038 } else if (product_low <= (UV)IV_MIN) {
1039 /* 2s complement assumption again */
1040 /* -ve result, which could overflow an IV */
1042 SETi( -product_low );
1044 } /* else drop to NVs below. */
1046 } /* product_middle too large */
1047 } /* ahigh && bhigh */
1048 } /* SvIOK(TOPm1s) */
1053 SETn( left * right );
1060 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1065 DIE(aTHX_ "Illegal division by zero");
1067 /* insure that 20./5. == 4. */
1070 if ((NV)I_V(left) == left &&
1071 (NV)I_V(right) == right &&
1072 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1076 value = left / right;
1080 value = left / right;
1089 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1095 bool use_double = 0;
1099 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1101 right = (right_neg = (i < 0)) ? -i : i;
1106 right_neg = dright < 0;
1111 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1113 left = (left_neg = (i < 0)) ? -i : i;
1121 left_neg = dleft < 0;
1130 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1132 # define CAST_D2UV(d) U_V(d)
1134 # define CAST_D2UV(d) ((UV)(d))
1136 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1137 * or, in other words, precision of UV more than of NV.
1138 * But in fact the approach below turned out to be an
1139 * optimization - floor() may be slow */
1140 if (dright <= UV_MAX && dleft <= UV_MAX) {
1141 right = CAST_D2UV(dright);
1142 left = CAST_D2UV(dleft);
1147 /* Backward-compatibility clause: */
1148 dright = Perl_floor(dright + 0.5);
1149 dleft = Perl_floor(dleft + 0.5);
1152 DIE(aTHX_ "Illegal modulus zero");
1154 dans = Perl_fmod(dleft, dright);
1155 if ((left_neg != right_neg) && dans)
1156 dans = dright - dans;
1159 sv_setnv(TARG, dans);
1166 DIE(aTHX_ "Illegal modulus zero");
1169 if ((left_neg != right_neg) && ans)
1172 /* XXX may warn: unary minus operator applied to unsigned type */
1173 /* could change -foo to be (~foo)+1 instead */
1174 if (ans <= ~((UV)IV_MAX)+1)
1175 sv_setiv(TARG, ~ans+1);
1177 sv_setnv(TARG, -(NV)ans);
1180 sv_setuv(TARG, ans);
1189 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1191 register IV count = POPi;
1192 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1194 I32 items = SP - MARK;
1197 max = items * count;
1206 repeatcpy((char*)(MARK + items), (char*)MARK,
1207 items * sizeof(SV*), count - 1);
1210 else if (count <= 0)
1213 else { /* Note: mark already snarfed by pp_list */
1218 SvSetSV(TARG, tmpstr);
1219 SvPV_force(TARG, len);
1220 isutf = DO_UTF8(TARG);
1225 SvGROW(TARG, (count * len) + 1);
1226 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1227 SvCUR(TARG) *= count;
1229 *SvEND(TARG) = '\0';
1232 (void)SvPOK_only_UTF8(TARG);
1234 (void)SvPOK_only(TARG);
1243 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1244 useleft = USE_LEFT(TOPm1s);
1245 #ifdef PERL_PRESERVE_IVUV
1246 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1247 "bad things" happen if you rely on signed integers wrapping. */
1250 /* Unless the left argument is integer in range we are going to have to
1251 use NV maths. Hence only attempt to coerce the right argument if
1252 we know the left is integer. */
1259 a_valid = auvok = 1;
1260 /* left operand is undef, treat as zero. */
1262 /* Left operand is defined, so is it IV? */
1263 SvIV_please(TOPm1s);
1264 if (SvIOK(TOPm1s)) {
1265 if ((auvok = SvUOK(TOPm1s)))
1266 auv = SvUVX(TOPm1s);
1268 register IV aiv = SvIVX(TOPm1s);
1271 auvok = 1; /* Now acting as a sign flag. */
1272 } else { /* 2s complement assumption for IV_MIN */
1280 bool result_good = 0;
1283 bool buvok = SvUOK(TOPs);
1288 register IV biv = SvIVX(TOPs);
1295 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1296 else "IV" now, independant of how it came in.
1297 if a, b represents positive, A, B negative, a maps to -A etc
1302 all UV maths. negate result if A negative.
1303 subtract if signs same, add if signs differ. */
1305 if (auvok ^ buvok) {
1314 /* Must get smaller */
1319 if (result <= buv) {
1320 /* result really should be -(auv-buv). as its negation
1321 of true value, need to swap our result flag */
1333 if (result <= (UV)IV_MIN)
1334 SETi( -(IV)result );
1336 /* result valid, but out of range for IV. */
1337 SETn( -(NV)result );
1341 } /* Overflow, drop through to NVs. */
1345 useleft = USE_LEFT(TOPm1s);
1349 /* left operand is undef, treat as zero - value */
1353 SETn( TOPn - value );
1360 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1363 if (PL_op->op_private & HINT_INTEGER) {
1377 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1380 if (PL_op->op_private & HINT_INTEGER) {
1394 dSP; tryAMAGICbinSET(lt,0);
1395 #ifdef PERL_PRESERVE_IVUV
1398 SvIV_please(TOPm1s);
1399 if (SvIOK(TOPm1s)) {
1400 bool auvok = SvUOK(TOPm1s);
1401 bool buvok = SvUOK(TOPs);
1403 if (!auvok && !buvok) { /* ## IV < IV ## */
1404 IV aiv = SvIVX(TOPm1s);
1405 IV biv = SvIVX(TOPs);
1408 SETs(boolSV(aiv < biv));
1411 if (auvok && buvok) { /* ## UV < UV ## */
1412 UV auv = SvUVX(TOPm1s);
1413 UV buv = SvUVX(TOPs);
1416 SETs(boolSV(auv < buv));
1419 if (auvok) { /* ## UV < IV ## */
1426 /* As (a) is a UV, it's >=0, so it cannot be < */
1431 if (auv >= (UV) IV_MAX) {
1432 /* As (b) is an IV, it cannot be > IV_MAX */
1436 SETs(boolSV(auv < (UV)biv));
1439 { /* ## IV < UV ## */
1443 aiv = SvIVX(TOPm1s);
1445 /* As (b) is a UV, it's >=0, so it must be < */
1452 if (buv > (UV) IV_MAX) {
1453 /* As (a) is an IV, it cannot be > IV_MAX */
1457 SETs(boolSV((UV)aiv < buv));
1465 SETs(boolSV(TOPn < value));
1472 dSP; tryAMAGICbinSET(gt,0);
1473 #ifdef PERL_PRESERVE_IVUV
1476 SvIV_please(TOPm1s);
1477 if (SvIOK(TOPm1s)) {
1478 bool auvok = SvUOK(TOPm1s);
1479 bool buvok = SvUOK(TOPs);
1481 if (!auvok && !buvok) { /* ## IV > IV ## */
1482 IV aiv = SvIVX(TOPm1s);
1483 IV biv = SvIVX(TOPs);
1486 SETs(boolSV(aiv > biv));
1489 if (auvok && buvok) { /* ## UV > UV ## */
1490 UV auv = SvUVX(TOPm1s);
1491 UV buv = SvUVX(TOPs);
1494 SETs(boolSV(auv > buv));
1497 if (auvok) { /* ## UV > IV ## */
1504 /* As (a) is a UV, it's >=0, so it must be > */
1509 if (auv > (UV) IV_MAX) {
1510 /* As (b) is an IV, it cannot be > IV_MAX */
1514 SETs(boolSV(auv > (UV)biv));
1517 { /* ## IV > UV ## */
1521 aiv = SvIVX(TOPm1s);
1523 /* As (b) is a UV, it's >=0, so it cannot be > */
1530 if (buv >= (UV) IV_MAX) {
1531 /* As (a) is an IV, it cannot be > IV_MAX */
1535 SETs(boolSV((UV)aiv > buv));
1543 SETs(boolSV(TOPn > value));
1550 dSP; tryAMAGICbinSET(le,0);
1551 #ifdef PERL_PRESERVE_IVUV
1554 SvIV_please(TOPm1s);
1555 if (SvIOK(TOPm1s)) {
1556 bool auvok = SvUOK(TOPm1s);
1557 bool buvok = SvUOK(TOPs);
1559 if (!auvok && !buvok) { /* ## IV <= IV ## */
1560 IV aiv = SvIVX(TOPm1s);
1561 IV biv = SvIVX(TOPs);
1564 SETs(boolSV(aiv <= biv));
1567 if (auvok && buvok) { /* ## UV <= UV ## */
1568 UV auv = SvUVX(TOPm1s);
1569 UV buv = SvUVX(TOPs);
1572 SETs(boolSV(auv <= buv));
1575 if (auvok) { /* ## UV <= IV ## */
1582 /* As (a) is a UV, it's >=0, so a cannot be <= */
1587 if (auv > (UV) IV_MAX) {
1588 /* As (b) is an IV, it cannot be > IV_MAX */
1592 SETs(boolSV(auv <= (UV)biv));
1595 { /* ## IV <= UV ## */
1599 aiv = SvIVX(TOPm1s);
1601 /* As (b) is a UV, it's >=0, so a must be <= */
1608 if (buv >= (UV) IV_MAX) {
1609 /* As (a) is an IV, it cannot be > IV_MAX */
1613 SETs(boolSV((UV)aiv <= buv));
1621 SETs(boolSV(TOPn <= value));
1628 dSP; tryAMAGICbinSET(ge,0);
1629 #ifdef PERL_PRESERVE_IVUV
1632 SvIV_please(TOPm1s);
1633 if (SvIOK(TOPm1s)) {
1634 bool auvok = SvUOK(TOPm1s);
1635 bool buvok = SvUOK(TOPs);
1637 if (!auvok && !buvok) { /* ## IV >= IV ## */
1638 IV aiv = SvIVX(TOPm1s);
1639 IV biv = SvIVX(TOPs);
1642 SETs(boolSV(aiv >= biv));
1645 if (auvok && buvok) { /* ## UV >= UV ## */
1646 UV auv = SvUVX(TOPm1s);
1647 UV buv = SvUVX(TOPs);
1650 SETs(boolSV(auv >= buv));
1653 if (auvok) { /* ## UV >= IV ## */
1660 /* As (a) is a UV, it's >=0, so it must be >= */
1665 if (auv >= (UV) IV_MAX) {
1666 /* As (b) is an IV, it cannot be > IV_MAX */
1670 SETs(boolSV(auv >= (UV)biv));
1673 { /* ## IV >= UV ## */
1677 aiv = SvIVX(TOPm1s);
1679 /* As (b) is a UV, it's >=0, so a cannot be >= */
1686 if (buv > (UV) IV_MAX) {
1687 /* As (a) is an IV, it cannot be > IV_MAX */
1691 SETs(boolSV((UV)aiv >= buv));
1699 SETs(boolSV(TOPn >= value));
1706 dSP; tryAMAGICbinSET(ne,0);
1707 #ifdef PERL_PRESERVE_IVUV
1710 SvIV_please(TOPm1s);
1711 if (SvIOK(TOPm1s)) {
1712 bool auvok = SvUOK(TOPm1s);
1713 bool buvok = SvUOK(TOPs);
1715 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1716 IV aiv = SvIVX(TOPm1s);
1717 IV biv = SvIVX(TOPs);
1720 SETs(boolSV(aiv != biv));
1723 if (auvok && buvok) { /* ## UV != UV ## */
1724 UV auv = SvUVX(TOPm1s);
1725 UV buv = SvUVX(TOPs);
1728 SETs(boolSV(auv != buv));
1731 { /* ## Mixed IV,UV ## */
1735 /* != is commutative so swap if needed (save code) */
1737 /* swap. top of stack (b) is the iv */
1741 /* As (a) is a UV, it's >0, so it cannot be == */
1750 /* As (b) is a UV, it's >0, so it cannot be == */
1754 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1756 /* we know iv is >= 0 */
1757 if (uv > (UV) IV_MAX) {
1761 SETs(boolSV((UV)iv != uv));
1769 SETs(boolSV(TOPn != value));
1776 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1777 #ifdef PERL_PRESERVE_IVUV
1778 /* Fortunately it seems NaN isn't IOK */
1781 SvIV_please(TOPm1s);
1782 if (SvIOK(TOPm1s)) {
1783 bool leftuvok = SvUOK(TOPm1s);
1784 bool rightuvok = SvUOK(TOPs);
1786 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1787 IV leftiv = SvIVX(TOPm1s);
1788 IV rightiv = SvIVX(TOPs);
1790 if (leftiv > rightiv)
1792 else if (leftiv < rightiv)
1796 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1797 UV leftuv = SvUVX(TOPm1s);
1798 UV rightuv = SvUVX(TOPs);
1800 if (leftuv > rightuv)
1802 else if (leftuv < rightuv)
1806 } else if (leftuvok) { /* ## UV <=> IV ## */
1810 rightiv = SvIVX(TOPs);
1812 /* As (a) is a UV, it's >=0, so it cannot be < */
1815 leftuv = SvUVX(TOPm1s);
1816 if (leftuv > (UV) IV_MAX) {
1817 /* As (b) is an IV, it cannot be > IV_MAX */
1819 } else if (leftuv > (UV)rightiv) {
1821 } else if (leftuv < (UV)rightiv) {
1827 } else { /* ## IV <=> UV ## */
1831 leftiv = SvIVX(TOPm1s);
1833 /* As (b) is a UV, it's >=0, so it must be < */
1836 rightuv = SvUVX(TOPs);
1837 if (rightuv > (UV) IV_MAX) {
1838 /* As (a) is an IV, it cannot be > IV_MAX */
1840 } else if (leftiv > (UV)rightuv) {
1842 } else if (leftiv < (UV)rightuv) {
1860 if (Perl_isnan(left) || Perl_isnan(right)) {
1864 value = (left > right) - (left < right);
1868 else if (left < right)
1870 else if (left > right)
1884 dSP; tryAMAGICbinSET(slt,0);
1887 int cmp = ((PL_op->op_private & OPpLOCALE)
1888 ? sv_cmp_locale(left, right)
1889 : sv_cmp(left, right));
1890 SETs(boolSV(cmp < 0));
1897 dSP; tryAMAGICbinSET(sgt,0);
1900 int cmp = ((PL_op->op_private & OPpLOCALE)
1901 ? sv_cmp_locale(left, right)
1902 : sv_cmp(left, right));
1903 SETs(boolSV(cmp > 0));
1910 dSP; tryAMAGICbinSET(sle,0);
1913 int cmp = ((PL_op->op_private & OPpLOCALE)
1914 ? sv_cmp_locale(left, right)
1915 : sv_cmp(left, right));
1916 SETs(boolSV(cmp <= 0));
1923 dSP; tryAMAGICbinSET(sge,0);
1926 int cmp = ((PL_op->op_private & OPpLOCALE)
1927 ? sv_cmp_locale(left, right)
1928 : sv_cmp(left, right));
1929 SETs(boolSV(cmp >= 0));
1936 dSP; tryAMAGICbinSET(seq,0);
1939 SETs(boolSV(sv_eq(left, right)));
1946 dSP; tryAMAGICbinSET(sne,0);
1949 SETs(boolSV(!sv_eq(left, right)));
1956 dSP; dTARGET; tryAMAGICbin(scmp,0);
1959 int cmp = ((PL_op->op_private & OPpLOCALE)
1960 ? sv_cmp_locale(left, right)
1961 : sv_cmp(left, right));
1969 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1972 if (SvNIOKp(left) || SvNIOKp(right)) {
1973 if (PL_op->op_private & HINT_INTEGER) {
1974 IV i = SvIV(left) & SvIV(right);
1978 UV u = SvUV(left) & SvUV(right);
1983 do_vop(PL_op->op_type, TARG, left, right);
1992 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1995 if (SvNIOKp(left) || SvNIOKp(right)) {
1996 if (PL_op->op_private & HINT_INTEGER) {
1997 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2001 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2006 do_vop(PL_op->op_type, TARG, left, right);
2015 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2018 if (SvNIOKp(left) || SvNIOKp(right)) {
2019 if (PL_op->op_private & HINT_INTEGER) {
2020 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2024 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2029 do_vop(PL_op->op_type, TARG, left, right);
2038 dSP; dTARGET; tryAMAGICun(neg);
2041 int flags = SvFLAGS(sv);
2044 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2045 /* It's publicly an integer, or privately an integer-not-float */
2048 if (SvIVX(sv) == IV_MIN) {
2049 /* 2s complement assumption. */
2050 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2053 else if (SvUVX(sv) <= IV_MAX) {
2058 else if (SvIVX(sv) != IV_MIN) {
2062 #ifdef PERL_PRESERVE_IVUV
2071 else if (SvPOKp(sv)) {
2073 char *s = SvPV(sv, len);
2074 if (isIDFIRST(*s)) {
2075 sv_setpvn(TARG, "-", 1);
2078 else if (*s == '+' || *s == '-') {
2080 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2082 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2083 sv_setpvn(TARG, "-", 1);
2089 goto oops_its_an_int;
2090 sv_setnv(TARG, -SvNV(sv));
2102 dSP; tryAMAGICunSET(not);
2103 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2109 dSP; dTARGET; tryAMAGICun(compl);
2113 if (PL_op->op_private & HINT_INTEGER) {
2128 tmps = (U8*)SvPV_force(TARG, len);
2131 /* Calculate exact length, let's not estimate. */
2140 while (tmps < send) {
2141 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2142 tmps += UTF8SKIP(tmps);
2143 targlen += UNISKIP(~c);
2149 /* Now rewind strings and write them. */
2153 Newz(0, result, targlen + 1, U8);
2154 while (tmps < send) {
2155 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2156 tmps += UTF8SKIP(tmps);
2157 result = uvchr_to_utf8(result, ~c);
2161 sv_setpvn(TARG, (char*)result, targlen);
2165 Newz(0, result, nchar + 1, U8);
2166 while (tmps < send) {
2167 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2168 tmps += UTF8SKIP(tmps);
2173 sv_setpvn(TARG, (char*)result, nchar);
2181 register long *tmpl;
2182 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2185 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2190 for ( ; anum > 0; anum--, tmps++)
2199 /* integer versions of some of the above */
2203 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2206 SETi( left * right );
2213 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2217 DIE(aTHX_ "Illegal division by zero");
2218 value = POPi / value;
2226 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2230 DIE(aTHX_ "Illegal modulus zero");
2231 SETi( left % right );
2238 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2241 SETi( left + right );
2248 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2251 SETi( left - right );
2258 dSP; tryAMAGICbinSET(lt,0);
2261 SETs(boolSV(left < right));
2268 dSP; tryAMAGICbinSET(gt,0);
2271 SETs(boolSV(left > right));
2278 dSP; tryAMAGICbinSET(le,0);
2281 SETs(boolSV(left <= right));
2288 dSP; tryAMAGICbinSET(ge,0);
2291 SETs(boolSV(left >= right));
2298 dSP; tryAMAGICbinSET(eq,0);
2301 SETs(boolSV(left == right));
2308 dSP; tryAMAGICbinSET(ne,0);
2311 SETs(boolSV(left != right));
2318 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2325 else if (left < right)
2336 dSP; dTARGET; tryAMAGICun(neg);
2341 /* High falutin' math. */
2345 dSP; dTARGET; tryAMAGICbin(atan2,0);
2348 SETn(Perl_atan2(left, right));
2355 dSP; dTARGET; tryAMAGICun(sin);
2359 value = Perl_sin(value);
2367 dSP; dTARGET; tryAMAGICun(cos);
2371 value = Perl_cos(value);
2377 /* Support Configure command-line overrides for rand() functions.
2378 After 5.005, perhaps we should replace this by Configure support
2379 for drand48(), random(), or rand(). For 5.005, though, maintain
2380 compatibility by calling rand() but allow the user to override it.
2381 See INSTALL for details. --Andy Dougherty 15 July 1998
2383 /* Now it's after 5.005, and Configure supports drand48() and random(),
2384 in addition to rand(). So the overrides should not be needed any more.
2385 --Jarkko Hietaniemi 27 September 1998
2388 #ifndef HAS_DRAND48_PROTO
2389 extern double drand48 (void);
2402 if (!PL_srand_called) {
2403 (void)seedDrand01((Rand_seed_t)seed());
2404 PL_srand_called = TRUE;
2419 (void)seedDrand01((Rand_seed_t)anum);
2420 PL_srand_called = TRUE;
2429 * This is really just a quick hack which grabs various garbage
2430 * values. It really should be a real hash algorithm which
2431 * spreads the effect of every input bit onto every output bit,
2432 * if someone who knows about such things would bother to write it.
2433 * Might be a good idea to add that function to CORE as well.
2434 * No numbers below come from careful analysis or anything here,
2435 * except they are primes and SEED_C1 > 1E6 to get a full-width
2436 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2437 * probably be bigger too.
2440 # define SEED_C1 1000003
2441 #define SEED_C4 73819
2443 # define SEED_C1 25747
2444 #define SEED_C4 20639
2448 #define SEED_C5 26107
2450 #ifndef PERL_NO_DEV_RANDOM
2455 # include <starlet.h>
2456 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2457 * in 100-ns units, typically incremented ever 10 ms. */
2458 unsigned int when[2];
2460 # ifdef HAS_GETTIMEOFDAY
2461 struct timeval when;
2467 /* This test is an escape hatch, this symbol isn't set by Configure. */
2468 #ifndef PERL_NO_DEV_RANDOM
2469 #ifndef PERL_RANDOM_DEVICE
2470 /* /dev/random isn't used by default because reads from it will block
2471 * if there isn't enough entropy available. You can compile with
2472 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2473 * is enough real entropy to fill the seed. */
2474 # define PERL_RANDOM_DEVICE "/dev/urandom"
2476 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2478 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2487 _ckvmssts(sys$gettim(when));
2488 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2490 # ifdef HAS_GETTIMEOFDAY
2491 gettimeofday(&when,(struct timezone *) 0);
2492 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2495 u = (U32)SEED_C1 * when;
2498 u += SEED_C3 * (U32)PerlProc_getpid();
2499 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2500 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2501 u += SEED_C5 * (U32)PTR2UV(&when);
2508 dSP; dTARGET; tryAMAGICun(exp);
2512 value = Perl_exp(value);
2520 dSP; dTARGET; tryAMAGICun(log);
2525 SET_NUMERIC_STANDARD();
2526 DIE(aTHX_ "Can't take log of %g", value);
2528 value = Perl_log(value);
2536 dSP; dTARGET; tryAMAGICun(sqrt);
2541 SET_NUMERIC_STANDARD();
2542 DIE(aTHX_ "Can't take sqrt of %g", value);
2544 value = Perl_sqrt(value);
2552 dSP; dTARGET; tryAMAGICun(int);
2555 IV iv = TOPi; /* attempt to convert to IV if possible. */
2556 /* XXX it's arguable that compiler casting to IV might be subtly
2557 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2558 else preferring IV has introduced a subtle behaviour change bug. OTOH
2559 relying on floating point to be accurate is a bug. */
2570 if (value < (NV)UV_MAX + 0.5) {
2573 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2574 (void)Perl_modf(value, &value);
2576 double tmp = (double)value;
2577 (void)Perl_modf(tmp, &tmp);
2584 if (value > (NV)IV_MIN - 0.5) {
2587 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2588 (void)Perl_modf(-value, &value);
2591 double tmp = (double)value;
2592 (void)Perl_modf(-tmp, &tmp);
2605 dSP; dTARGET; tryAMAGICun(abs);
2607 /* This will cache the NV value if string isn't actually integer */
2611 /* IVX is precise */
2613 SETu(TOPu); /* force it to be numeric only */
2621 /* 2s complement assumption. Also, not really needed as
2622 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2645 argtype = 1; /* allow underscores */
2646 XPUSHn(scan_hex(tmps, 99, &argtype));
2659 while (*tmps && isSPACE(*tmps))
2663 argtype = 1; /* allow underscores */
2665 value = scan_hex(++tmps, 99, &argtype);
2666 else if (*tmps == 'b')
2667 value = scan_bin(++tmps, 99, &argtype);
2669 value = scan_oct(tmps, 99, &argtype);
2682 SETi(sv_len_utf8(sv));
2698 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2700 I32 arybase = PL_curcop->cop_arybase;
2703 int num_args = PL_op->op_private & 7;
2705 SvTAINTED_off(TARG); /* decontaminate */
2706 SvUTF8_off(TARG); /* decontaminate */
2710 repl = SvPV(sv, repl_len);
2717 tmps = SvPV(sv, curlen);
2719 utfcurlen = sv_len_utf8(sv);
2720 if (utfcurlen == curlen)
2728 if (pos >= arybase) {
2746 else if (len >= 0) {
2748 if (rem > (I32)curlen)
2763 Perl_croak(aTHX_ "substr outside of string");
2764 if (ckWARN(WARN_SUBSTR))
2765 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2772 sv_pos_u2b(sv, &pos, &rem);
2774 sv_setpvn(TARG, tmps, rem);
2778 sv_insert(sv, pos, rem, repl, repl_len);
2779 else if (lvalue) { /* it's an lvalue! */
2780 if (!SvGMAGICAL(sv)) {
2784 if (ckWARN(WARN_SUBSTR))
2785 Perl_warner(aTHX_ WARN_SUBSTR,
2786 "Attempt to use reference as lvalue in substr");
2788 if (SvOK(sv)) /* is it defined ? */
2789 (void)SvPOK_only_UTF8(sv);
2791 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2794 if (SvTYPE(TARG) < SVt_PVLV) {
2795 sv_upgrade(TARG, SVt_PVLV);
2796 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2800 if (LvTARG(TARG) != sv) {
2802 SvREFCNT_dec(LvTARG(TARG));
2803 LvTARG(TARG) = SvREFCNT_inc(sv);
2805 LvTARGOFF(TARG) = upos;
2806 LvTARGLEN(TARG) = urem;
2810 PUSHs(TARG); /* avoid SvSETMAGIC here */
2817 register IV size = POPi;
2818 register IV offset = POPi;
2819 register SV *src = POPs;
2820 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2822 SvTAINTED_off(TARG); /* decontaminate */
2823 if (lvalue) { /* it's an lvalue! */
2824 if (SvTYPE(TARG) < SVt_PVLV) {
2825 sv_upgrade(TARG, SVt_PVLV);
2826 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2829 if (LvTARG(TARG) != src) {
2831 SvREFCNT_dec(LvTARG(TARG));
2832 LvTARG(TARG) = SvREFCNT_inc(src);
2834 LvTARGOFF(TARG) = offset;
2835 LvTARGLEN(TARG) = size;
2838 sv_setuv(TARG, do_vecget(src, offset, size));
2853 I32 arybase = PL_curcop->cop_arybase;
2858 offset = POPi - arybase;
2861 tmps = SvPV(big, biglen);
2862 if (offset > 0 && DO_UTF8(big))
2863 sv_pos_u2b(big, &offset, 0);
2866 else if (offset > biglen)
2868 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2869 (unsigned char*)tmps + biglen, little, 0)))
2872 retval = tmps2 - tmps;
2873 if (retval > 0 && DO_UTF8(big))
2874 sv_pos_b2u(big, &retval);
2875 PUSHi(retval + arybase);
2890 I32 arybase = PL_curcop->cop_arybase;
2896 tmps2 = SvPV(little, llen);
2897 tmps = SvPV(big, blen);
2901 if (offset > 0 && DO_UTF8(big))
2902 sv_pos_u2b(big, &offset, 0);
2903 offset = offset - arybase + llen;
2907 else if (offset > blen)
2909 if (!(tmps2 = rninstr(tmps, tmps + offset,
2910 tmps2, tmps2 + llen)))
2913 retval = tmps2 - tmps;
2914 if (retval > 0 && DO_UTF8(big))
2915 sv_pos_b2u(big, &retval);
2916 PUSHi(retval + arybase);
2922 dSP; dMARK; dORIGMARK; dTARGET;
2923 do_sprintf(TARG, SP-MARK, MARK+1);
2924 TAINT_IF(SvTAINTED(TARG));
2935 U8 *s = (U8*)SvPVx(argsv, len);
2937 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2947 (void)SvUPGRADE(TARG,SVt_PV);
2949 if (value > 255 && !IN_BYTE) {
2950 SvGROW(TARG, UNISKIP(value)+1);
2951 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
2952 SvCUR_set(TARG, tmps - SvPVX(TARG));
2954 (void)SvPOK_only(TARG);
2965 (void)SvPOK_only(TARG);
2972 dSP; dTARGET; dPOPTOPssrl;
2975 char *tmps = SvPV(left, n_a);
2977 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2979 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2983 "The crypt() function is unimplemented due to excessive paranoia.");
2996 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
2998 U8 tmpbuf[UTF8_MAXLEN+1];
3002 if (PL_op->op_private & OPpLOCALE) {
3005 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3008 uv = toTITLE_utf8(s);
3010 tend = uvchr_to_utf8(tmpbuf, uv);
3012 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3014 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3015 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3020 s = (U8*)SvPV_force(sv, slen);
3021 Copy(tmpbuf, s, ulen, U8);
3025 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3027 SvUTF8_off(TARG); /* decontaminate */
3032 s = (U8*)SvPV_force(sv, slen);
3034 if (PL_op->op_private & OPpLOCALE) {
3037 *s = toUPPER_LC(*s);
3055 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3057 U8 tmpbuf[UTF8_MAXLEN+1];
3061 if (PL_op->op_private & OPpLOCALE) {
3064 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3067 uv = toLOWER_utf8(s);
3069 tend = uvchr_to_utf8(tmpbuf, uv);
3071 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3073 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3074 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3079 s = (U8*)SvPV_force(sv, slen);
3080 Copy(tmpbuf, s, ulen, U8);
3084 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3086 SvUTF8_off(TARG); /* decontaminate */
3091 s = (U8*)SvPV_force(sv, slen);
3093 if (PL_op->op_private & OPpLOCALE) {
3096 *s = toLOWER_LC(*s);
3120 s = (U8*)SvPV(sv,len);
3122 SvUTF8_off(TARG); /* decontaminate */
3123 sv_setpvn(TARG, "", 0);
3127 (void)SvUPGRADE(TARG, SVt_PV);
3128 SvGROW(TARG, (len * 2) + 1);
3129 (void)SvPOK_only(TARG);
3130 d = (U8*)SvPVX(TARG);
3132 if (PL_op->op_private & OPpLOCALE) {
3136 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3142 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3148 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3153 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3155 SvUTF8_off(TARG); /* decontaminate */
3160 s = (U8*)SvPV_force(sv, len);
3162 register U8 *send = s + len;
3164 if (PL_op->op_private & OPpLOCALE) {
3167 for (; s < send; s++)
3168 *s = toUPPER_LC(*s);
3171 for (; s < send; s++)
3194 s = (U8*)SvPV(sv,len);
3196 SvUTF8_off(TARG); /* decontaminate */
3197 sv_setpvn(TARG, "", 0);
3201 (void)SvUPGRADE(TARG, SVt_PV);
3202 SvGROW(TARG, (len * 2) + 1);
3203 (void)SvPOK_only(TARG);
3204 d = (U8*)SvPVX(TARG);
3206 if (PL_op->op_private & OPpLOCALE) {
3210 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3216 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3222 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3227 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3229 SvUTF8_off(TARG); /* decontaminate */
3235 s = (U8*)SvPV_force(sv, len);
3237 register U8 *send = s + len;
3239 if (PL_op->op_private & OPpLOCALE) {
3242 for (; s < send; s++)
3243 *s = toLOWER_LC(*s);
3246 for (; s < send; s++)
3261 register char *s = SvPV(sv,len);
3264 SvUTF8_off(TARG); /* decontaminate */
3266 (void)SvUPGRADE(TARG, SVt_PV);
3267 SvGROW(TARG, (len * 2) + 1);
3271 if (UTF8_IS_CONTINUED(*s)) {
3272 STRLEN ulen = UTF8SKIP(s);
3296 SvCUR_set(TARG, d - SvPVX(TARG));
3297 (void)SvPOK_only_UTF8(TARG);
3300 sv_setpvn(TARG, s, len);
3302 if (SvSMAGICAL(TARG))
3311 dSP; dMARK; dORIGMARK;
3313 register AV* av = (AV*)POPs;
3314 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3315 I32 arybase = PL_curcop->cop_arybase;
3318 if (SvTYPE(av) == SVt_PVAV) {
3319 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3321 for (svp = MARK + 1; svp <= SP; svp++) {
3326 if (max > AvMAX(av))
3329 while (++MARK <= SP) {
3330 elem = SvIVx(*MARK);
3334 svp = av_fetch(av, elem, lval);
3336 if (!svp || *svp == &PL_sv_undef)
3337 DIE(aTHX_ PL_no_aelem, elem);
3338 if (PL_op->op_private & OPpLVAL_INTRO)
3339 save_aelem(av, elem, svp);
3341 *MARK = svp ? *svp : &PL_sv_undef;
3344 if (GIMME != G_ARRAY) {
3352 /* Associative arrays. */
3357 HV *hash = (HV*)POPs;
3359 I32 gimme = GIMME_V;
3360 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3363 /* might clobber stack_sp */
3364 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3369 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3370 if (gimme == G_ARRAY) {
3373 /* might clobber stack_sp */
3375 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3380 else if (gimme == G_SCALAR)
3399 I32 gimme = GIMME_V;
3400 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3404 if (PL_op->op_private & OPpSLICE) {
3408 hvtype = SvTYPE(hv);
3409 if (hvtype == SVt_PVHV) { /* hash element */
3410 while (++MARK <= SP) {
3411 sv = hv_delete_ent(hv, *MARK, discard, 0);
3412 *MARK = sv ? sv : &PL_sv_undef;
3415 else if (hvtype == SVt_PVAV) {
3416 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3417 while (++MARK <= SP) {
3418 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3419 *MARK = sv ? sv : &PL_sv_undef;
3422 else { /* pseudo-hash element */
3423 while (++MARK <= SP) {
3424 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3425 *MARK = sv ? sv : &PL_sv_undef;
3430 DIE(aTHX_ "Not a HASH reference");
3433 else if (gimme == G_SCALAR) {
3442 if (SvTYPE(hv) == SVt_PVHV)
3443 sv = hv_delete_ent(hv, keysv, discard, 0);
3444 else if (SvTYPE(hv) == SVt_PVAV) {
3445 if (PL_op->op_flags & OPf_SPECIAL)
3446 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3448 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3451 DIE(aTHX_ "Not a HASH reference");
3466 if (PL_op->op_private & OPpEXISTS_SUB) {
3470 cv = sv_2cv(sv, &hv, &gv, FALSE);
3473 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3479 if (SvTYPE(hv) == SVt_PVHV) {
3480 if (hv_exists_ent(hv, tmpsv, 0))
3483 else if (SvTYPE(hv) == SVt_PVAV) {
3484 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3485 if (av_exists((AV*)hv, SvIV(tmpsv)))
3488 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3492 DIE(aTHX_ "Not a HASH reference");
3499 dSP; dMARK; dORIGMARK;
3500 register HV *hv = (HV*)POPs;
3501 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3502 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3504 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3505 DIE(aTHX_ "Can't localize pseudo-hash element");
3507 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3508 while (++MARK <= SP) {
3511 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3513 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3514 svp = he ? &HeVAL(he) : 0;
3517 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3520 if (!svp || *svp == &PL_sv_undef) {
3522 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3524 if (PL_op->op_private & OPpLVAL_INTRO) {
3526 save_helem(hv, keysv, svp);
3529 char *key = SvPV(keysv, keylen);
3530 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3534 *MARK = svp ? *svp : &PL_sv_undef;
3537 if (GIMME != G_ARRAY) {
3545 /* List operators. */
3550 if (GIMME != G_ARRAY) {
3552 *MARK = *SP; /* unwanted list, return last item */
3554 *MARK = &PL_sv_undef;
3563 SV **lastrelem = PL_stack_sp;
3564 SV **lastlelem = PL_stack_base + POPMARK;
3565 SV **firstlelem = PL_stack_base + POPMARK + 1;
3566 register SV **firstrelem = lastlelem + 1;
3567 I32 arybase = PL_curcop->cop_arybase;
3568 I32 lval = PL_op->op_flags & OPf_MOD;
3569 I32 is_something_there = lval;
3571 register I32 max = lastrelem - lastlelem;
3572 register SV **lelem;
3575 if (GIMME != G_ARRAY) {
3576 ix = SvIVx(*lastlelem);
3581 if (ix < 0 || ix >= max)
3582 *firstlelem = &PL_sv_undef;
3584 *firstlelem = firstrelem[ix];
3590 SP = firstlelem - 1;
3594 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3600 if (ix < 0 || ix >= max)
3601 *lelem = &PL_sv_undef;
3603 is_something_there = TRUE;
3604 if (!(*lelem = firstrelem[ix]))
3605 *lelem = &PL_sv_undef;
3608 if (is_something_there)
3611 SP = firstlelem - 1;
3617 dSP; dMARK; dORIGMARK;
3618 I32 items = SP - MARK;
3619 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3620 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3627 dSP; dMARK; dORIGMARK;
3628 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3632 SV *val = NEWSV(46, 0);
3634 sv_setsv(val, *++MARK);
3635 else if (ckWARN(WARN_MISC))
3636 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3637 (void)hv_store_ent(hv,key,val,0);
3646 dSP; dMARK; dORIGMARK;
3647 register AV *ary = (AV*)*++MARK;
3651 register I32 offset;
3652 register I32 length;
3659 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3660 *MARK-- = SvTIED_obj((SV*)ary, mg);
3664 call_method("SPLICE",GIMME_V);
3673 offset = i = SvIVx(*MARK);
3675 offset += AvFILLp(ary) + 1;
3677 offset -= PL_curcop->cop_arybase;
3679 DIE(aTHX_ PL_no_aelem, i);
3681 length = SvIVx(*MARK++);
3683 length += AvFILLp(ary) - offset + 1;
3689 length = AvMAX(ary) + 1; /* close enough to infinity */
3693 length = AvMAX(ary) + 1;
3695 if (offset > AvFILLp(ary) + 1)
3696 offset = AvFILLp(ary) + 1;
3697 after = AvFILLp(ary) + 1 - (offset + length);
3698 if (after < 0) { /* not that much array */
3699 length += after; /* offset+length now in array */
3705 /* At this point, MARK .. SP-1 is our new LIST */
3708 diff = newlen - length;
3709 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3712 if (diff < 0) { /* shrinking the area */
3714 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3715 Copy(MARK, tmparyval, newlen, SV*);
3718 MARK = ORIGMARK + 1;
3719 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3720 MEXTEND(MARK, length);
3721 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3723 EXTEND_MORTAL(length);
3724 for (i = length, dst = MARK; i; i--) {
3725 sv_2mortal(*dst); /* free them eventualy */
3732 *MARK = AvARRAY(ary)[offset+length-1];
3735 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3736 SvREFCNT_dec(*dst++); /* free them now */
3739 AvFILLp(ary) += diff;
3741 /* pull up or down? */
3743 if (offset < after) { /* easier to pull up */
3744 if (offset) { /* esp. if nothing to pull */
3745 src = &AvARRAY(ary)[offset-1];
3746 dst = src - diff; /* diff is negative */
3747 for (i = offset; i > 0; i--) /* can't trust Copy */
3751 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3755 if (after) { /* anything to pull down? */
3756 src = AvARRAY(ary) + offset + length;
3757 dst = src + diff; /* diff is negative */
3758 Move(src, dst, after, SV*);
3760 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3761 /* avoid later double free */
3765 dst[--i] = &PL_sv_undef;
3768 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3770 *dst = NEWSV(46, 0);
3771 sv_setsv(*dst++, *src++);
3773 Safefree(tmparyval);
3776 else { /* no, expanding (or same) */
3778 New(452, tmparyval, length, SV*); /* so remember deletion */
3779 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3782 if (diff > 0) { /* expanding */
3784 /* push up or down? */
3786 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3790 Move(src, dst, offset, SV*);
3792 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3794 AvFILLp(ary) += diff;
3797 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3798 av_extend(ary, AvFILLp(ary) + diff);
3799 AvFILLp(ary) += diff;
3802 dst = AvARRAY(ary) + AvFILLp(ary);
3804 for (i = after; i; i--) {
3811 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3812 *dst = NEWSV(46, 0);
3813 sv_setsv(*dst++, *src++);
3815 MARK = ORIGMARK + 1;
3816 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3818 Copy(tmparyval, MARK, length, SV*);
3820 EXTEND_MORTAL(length);
3821 for (i = length, dst = MARK; i; i--) {
3822 sv_2mortal(*dst); /* free them eventualy */
3826 Safefree(tmparyval);
3830 else if (length--) {
3831 *MARK = tmparyval[length];
3834 while (length-- > 0)
3835 SvREFCNT_dec(tmparyval[length]);
3837 Safefree(tmparyval);
3840 *MARK = &PL_sv_undef;
3848 dSP; dMARK; dORIGMARK; dTARGET;
3849 register AV *ary = (AV*)*++MARK;
3850 register SV *sv = &PL_sv_undef;
3853 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3854 *MARK-- = SvTIED_obj((SV*)ary, mg);
3858 call_method("PUSH",G_SCALAR|G_DISCARD);
3863 /* Why no pre-extend of ary here ? */
3864 for (++MARK; MARK <= SP; MARK++) {
3867 sv_setsv(sv, *MARK);
3872 PUSHi( AvFILL(ary) + 1 );
3880 SV *sv = av_pop(av);
3882 (void)sv_2mortal(sv);
3891 SV *sv = av_shift(av);
3896 (void)sv_2mortal(sv);
3903 dSP; dMARK; dORIGMARK; dTARGET;
3904 register AV *ary = (AV*)*++MARK;
3909 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3910 *MARK-- = SvTIED_obj((SV*)ary, mg);
3914 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3919 av_unshift(ary, SP - MARK);
3922 sv_setsv(sv, *++MARK);
3923 (void)av_store(ary, i++, sv);
3927 PUSHi( AvFILL(ary) + 1 );
3937 if (GIMME == G_ARRAY) {
3944 /* safe as long as stack cannot get extended in the above */
3949 register char *down;
3954 SvUTF8_off(TARG); /* decontaminate */
3956 do_join(TARG, &PL_sv_no, MARK, SP);
3958 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3959 up = SvPV_force(TARG, len);
3961 if (DO_UTF8(TARG)) { /* first reverse each character */
3962 U8* s = (U8*)SvPVX(TARG);
3963 U8* send = (U8*)(s + len);
3965 if (UTF8_IS_ASCII(*s)) {
3970 if (!utf8_to_uvchr(s, 0))
3974 down = (char*)(s - 1);
3975 /* reverse this character */
3985 down = SvPVX(TARG) + len - 1;
3991 (void)SvPOK_only_UTF8(TARG);
4000 S_mul128(pTHX_ SV *sv, U8 m)
4003 char *s = SvPV(sv, len);
4007 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4008 SV *tmpNew = newSVpvn("0000000000", 10);
4010 sv_catsv(tmpNew, sv);
4011 SvREFCNT_dec(sv); /* free old sv */
4016 while (!*t) /* trailing '\0'? */
4019 i = ((*t - '0') << 7) + m;
4020 *(t--) = '0' + (i % 10);
4026 /* Explosives and implosives. */
4028 #if 'I' == 73 && 'J' == 74
4029 /* On an ASCII/ISO kind of system */
4030 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4033 Some other sort of character set - use memchr() so we don't match
4036 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4044 I32 start_sp_offset = SP - PL_stack_base;
4045 I32 gimme = GIMME_V;
4049 register char *pat = SvPV(left, llen);
4050 #ifdef PACKED_IS_OCTETS
4051 /* Packed side is assumed to be octets - so force downgrade if it
4052 has been UTF-8 encoded by accident
4054 register char *s = SvPVbyte(right, rlen);
4056 register char *s = SvPV(right, rlen);
4058 char *strend = s + rlen;
4060 register char *patend = pat + llen;
4066 /* These must not be in registers: */
4083 register U32 culong;
4087 #ifdef PERL_NATINT_PACK
4088 int natint; /* native integer */
4089 int unatint; /* unsigned native integer */
4092 if (gimme != G_ARRAY) { /* arrange to do first one only */
4094 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4095 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4097 while (isDIGIT(*patend) || *patend == '*')
4103 while (pat < patend) {
4105 datumtype = *pat++ & 0xFF;
4106 #ifdef PERL_NATINT_PACK
4109 if (isSPACE(datumtype))
4111 if (datumtype == '#') {
4112 while (pat < patend && *pat != '\n')
4117 char *natstr = "sSiIlL";
4119 if (strchr(natstr, datumtype)) {
4120 #ifdef PERL_NATINT_PACK
4126 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4131 else if (*pat == '*') {
4132 len = strend - strbeg; /* long enough */
4136 else if (isDIGIT(*pat)) {
4138 while (isDIGIT(*pat)) {
4139 len = (len * 10) + (*pat++ - '0');
4141 DIE(aTHX_ "Repeat count in unpack overflows");
4145 len = (datumtype != '@');
4149 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4150 case ',': /* grandfather in commas but with a warning */
4151 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4152 Perl_warner(aTHX_ WARN_UNPACK,
4153 "Invalid type in unpack: '%c'", (int)datumtype);
4156 if (len == 1 && pat[-1] != '1')
4165 if (len > strend - strbeg)
4166 DIE(aTHX_ "@ outside of string");
4170 if (len > s - strbeg)
4171 DIE(aTHX_ "X outside of string");
4175 if (len > strend - s)
4176 DIE(aTHX_ "x outside of string");
4180 if (start_sp_offset >= SP - PL_stack_base)
4181 DIE(aTHX_ "/ must follow a numeric type");
4184 pat++; /* ignore '*' for compatibility with pack */
4186 DIE(aTHX_ "/ cannot take a count" );
4193 if (len > strend - s)
4196 goto uchar_checksum;
4197 sv = NEWSV(35, len);
4198 sv_setpvn(sv, s, len);
4200 if (datumtype == 'A' || datumtype == 'Z') {
4201 aptr = s; /* borrow register */
4202 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4207 else { /* 'A' strips both nulls and spaces */
4208 s = SvPVX(sv) + len - 1;
4209 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4213 SvCUR_set(sv, s - SvPVX(sv));
4214 s = aptr; /* unborrow register */
4216 XPUSHs(sv_2mortal(sv));
4220 if (star || len > (strend - s) * 8)
4221 len = (strend - s) * 8;
4224 Newz(601, PL_bitcount, 256, char);
4225 for (bits = 1; bits < 256; bits++) {
4226 if (bits & 1) PL_bitcount[bits]++;
4227 if (bits & 2) PL_bitcount[bits]++;
4228 if (bits & 4) PL_bitcount[bits]++;
4229 if (bits & 8) PL_bitcount[bits]++;
4230 if (bits & 16) PL_bitcount[bits]++;
4231 if (bits & 32) PL_bitcount[bits]++;
4232 if (bits & 64) PL_bitcount[bits]++;
4233 if (bits & 128) PL_bitcount[bits]++;
4237 culong += PL_bitcount[*(unsigned char*)s++];
4242 if (datumtype == 'b') {
4244 if (bits & 1) culong++;
4250 if (bits & 128) culong++;
4257 sv = NEWSV(35, len + 1);
4261 if (datumtype == 'b') {
4263 for (len = 0; len < aint; len++) {
4264 if (len & 7) /*SUPPRESS 595*/
4268 *str++ = '0' + (bits & 1);
4273 for (len = 0; len < aint; len++) {
4278 *str++ = '0' + ((bits & 128) != 0);
4282 XPUSHs(sv_2mortal(sv));
4286 if (star || len > (strend - s) * 2)
4287 len = (strend - s) * 2;
4288 sv = NEWSV(35, len + 1);
4292 if (datumtype == 'h') {
4294 for (len = 0; len < aint; len++) {
4299 *str++ = PL_hexdigit[bits & 15];
4304 for (len = 0; len < aint; len++) {
4309 *str++ = PL_hexdigit[(bits >> 4) & 15];
4313 XPUSHs(sv_2mortal(sv));
4316 if (len > strend - s)
4321 if (aint >= 128) /* fake up signed chars */
4331 if (aint >= 128) /* fake up signed chars */
4334 sv_setiv(sv, (IV)aint);
4335 PUSHs(sv_2mortal(sv));
4340 if (len > strend - s)
4355 sv_setiv(sv, (IV)auint);
4356 PUSHs(sv_2mortal(sv));
4361 if (len > strend - s)
4364 while (len-- > 0 && s < strend) {
4366 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4370 cdouble += (NV)auint;
4378 while (len-- > 0 && s < strend) {
4380 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4384 sv_setuv(sv, (UV)auint);
4385 PUSHs(sv_2mortal(sv));
4390 #if SHORTSIZE == SIZE16
4391 along = (strend - s) / SIZE16;
4393 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4398 #if SHORTSIZE != SIZE16
4402 COPYNN(s, &ashort, sizeof(short));
4413 #if SHORTSIZE > SIZE16
4425 #if SHORTSIZE != SIZE16
4429 COPYNN(s, &ashort, sizeof(short));
4432 sv_setiv(sv, (IV)ashort);
4433 PUSHs(sv_2mortal(sv));
4441 #if SHORTSIZE > SIZE16
4447 sv_setiv(sv, (IV)ashort);
4448 PUSHs(sv_2mortal(sv));
4456 #if SHORTSIZE == SIZE16
4457 along = (strend - s) / SIZE16;
4459 unatint = natint && datumtype == 'S';
4460 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4465 #if SHORTSIZE != SIZE16
4467 unsigned short aushort;
4469 COPYNN(s, &aushort, sizeof(unsigned short));
4470 s += sizeof(unsigned short);
4478 COPY16(s, &aushort);
4481 if (datumtype == 'n')
4482 aushort = PerlSock_ntohs(aushort);
4485 if (datumtype == 'v')
4486 aushort = vtohs(aushort);
4495 #if SHORTSIZE != SIZE16
4497 unsigned short aushort;
4499 COPYNN(s, &aushort, sizeof(unsigned short));
4500 s += sizeof(unsigned short);
4502 sv_setiv(sv, (UV)aushort);
4503 PUSHs(sv_2mortal(sv));
4510 COPY16(s, &aushort);
4514 if (datumtype == 'n')
4515 aushort = PerlSock_ntohs(aushort);
4518 if (datumtype == 'v')
4519 aushort = vtohs(aushort);
4521 sv_setiv(sv, (UV)aushort);
4522 PUSHs(sv_2mortal(sv));
4528 along = (strend - s) / sizeof(int);
4533 Copy(s, &aint, 1, int);
4536 cdouble += (NV)aint;
4545 Copy(s, &aint, 1, int);
4549 /* Without the dummy below unpack("i", pack("i",-1))
4550 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4551 * cc with optimization turned on.
4553 * The bug was detected in
4554 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4555 * with optimization (-O4) turned on.
4556 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4557 * does not have this problem even with -O4.
4559 * This bug was reported as DECC_BUGS 1431
4560 * and tracked internally as GEM_BUGS 7775.
4562 * The bug is fixed in
4563 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4564 * UNIX V4.0F support: DEC C V5.9-006 or later
4565 * UNIX V4.0E support: DEC C V5.8-011 or later
4568 * See also few lines later for the same bug.
4571 sv_setiv(sv, (IV)aint) :
4573 sv_setiv(sv, (IV)aint);
4574 PUSHs(sv_2mortal(sv));
4579 along = (strend - s) / sizeof(unsigned int);
4584 Copy(s, &auint, 1, unsigned int);
4585 s += sizeof(unsigned int);
4587 cdouble += (NV)auint;
4596 Copy(s, &auint, 1, unsigned int);
4597 s += sizeof(unsigned int);
4600 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4601 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4602 * See details few lines earlier. */
4604 sv_setuv(sv, (UV)auint) :
4606 sv_setuv(sv, (UV)auint);
4607 PUSHs(sv_2mortal(sv));
4612 #if LONGSIZE == SIZE32
4613 along = (strend - s) / SIZE32;
4615 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4620 #if LONGSIZE != SIZE32
4623 COPYNN(s, &along, sizeof(long));
4626 cdouble += (NV)along;
4635 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4639 #if LONGSIZE > SIZE32
4640 if (along > 2147483647)
4641 along -= 4294967296;
4645 cdouble += (NV)along;
4654 #if LONGSIZE != SIZE32
4657 COPYNN(s, &along, sizeof(long));
4660 sv_setiv(sv, (IV)along);
4661 PUSHs(sv_2mortal(sv));
4668 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4672 #if LONGSIZE > SIZE32
4673 if (along > 2147483647)
4674 along -= 4294967296;
4678 sv_setiv(sv, (IV)along);
4679 PUSHs(sv_2mortal(sv));
4687 #if LONGSIZE == SIZE32
4688 along = (strend - s) / SIZE32;
4690 unatint = natint && datumtype == 'L';
4691 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4696 #if LONGSIZE != SIZE32
4698 unsigned long aulong;
4700 COPYNN(s, &aulong, sizeof(unsigned long));
4701 s += sizeof(unsigned long);
4703 cdouble += (NV)aulong;
4715 if (datumtype == 'N')
4716 aulong = PerlSock_ntohl(aulong);
4719 if (datumtype == 'V')
4720 aulong = vtohl(aulong);
4723 cdouble += (NV)aulong;
4732 #if LONGSIZE != SIZE32
4734 unsigned long aulong;
4736 COPYNN(s, &aulong, sizeof(unsigned long));
4737 s += sizeof(unsigned long);
4739 sv_setuv(sv, (UV)aulong);
4740 PUSHs(sv_2mortal(sv));
4750 if (datumtype == 'N')
4751 aulong = PerlSock_ntohl(aulong);
4754 if (datumtype == 'V')
4755 aulong = vtohl(aulong);
4758 sv_setuv(sv, (UV)aulong);
4759 PUSHs(sv_2mortal(sv));
4765 along = (strend - s) / sizeof(char*);
4771 if (sizeof(char*) > strend - s)
4774 Copy(s, &aptr, 1, char*);
4780 PUSHs(sv_2mortal(sv));
4790 while ((len > 0) && (s < strend)) {
4791 auv = (auv << 7) | (*s & 0x7f);
4792 if (UTF8_IS_ASCII(*s++)) {
4796 PUSHs(sv_2mortal(sv));
4800 else if (++bytes >= sizeof(UV)) { /* promote to string */
4804 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4805 while (s < strend) {
4806 sv = mul128(sv, *s & 0x7f);
4807 if (!(*s++ & 0x80)) {
4816 PUSHs(sv_2mortal(sv));
4821 if ((s >= strend) && bytes)
4822 DIE(aTHX_ "Unterminated compressed integer");
4827 if (sizeof(char*) > strend - s)
4830 Copy(s, &aptr, 1, char*);
4835 sv_setpvn(sv, aptr, len);
4836 PUSHs(sv_2mortal(sv));
4840 along = (strend - s) / sizeof(Quad_t);
4846 if (s + sizeof(Quad_t) > strend)
4849 Copy(s, &aquad, 1, Quad_t);
4850 s += sizeof(Quad_t);
4853 if (aquad >= IV_MIN && aquad <= IV_MAX)
4854 sv_setiv(sv, (IV)aquad);
4856 sv_setnv(sv, (NV)aquad);
4857 PUSHs(sv_2mortal(sv));
4861 along = (strend - s) / sizeof(Quad_t);
4867 if (s + sizeof(Uquad_t) > strend)
4870 Copy(s, &auquad, 1, Uquad_t);
4871 s += sizeof(Uquad_t);
4874 if (auquad <= UV_MAX)
4875 sv_setuv(sv, (UV)auquad);
4877 sv_setnv(sv, (NV)auquad);
4878 PUSHs(sv_2mortal(sv));
4882 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4885 along = (strend - s) / sizeof(float);
4890 Copy(s, &afloat, 1, float);
4899 Copy(s, &afloat, 1, float);
4902 sv_setnv(sv, (NV)afloat);
4903 PUSHs(sv_2mortal(sv));
4909 along = (strend - s) / sizeof(double);
4914 Copy(s, &adouble, 1, double);
4915 s += sizeof(double);
4923 Copy(s, &adouble, 1, double);
4924 s += sizeof(double);
4926 sv_setnv(sv, (NV)adouble);
4927 PUSHs(sv_2mortal(sv));
4933 * Initialise the decode mapping. By using a table driven
4934 * algorithm, the code will be character-set independent
4935 * (and just as fast as doing character arithmetic)
4937 if (PL_uudmap['M'] == 0) {
4940 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4941 PL_uudmap[(U8)PL_uuemap[i]] = i;
4943 * Because ' ' and '`' map to the same value,
4944 * we need to decode them both the same.
4949 along = (strend - s) * 3 / 4;
4950 sv = NEWSV(42, along);
4953 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4958 len = PL_uudmap[*(U8*)s++] & 077;
4960 if (s < strend && ISUUCHAR(*s))
4961 a = PL_uudmap[*(U8*)s++] & 077;
4964 if (s < strend && ISUUCHAR(*s))
4965 b = PL_uudmap[*(U8*)s++] & 077;
4968 if (s < strend && ISUUCHAR(*s))
4969 c = PL_uudmap[*(U8*)s++] & 077;
4972 if (s < strend && ISUUCHAR(*s))
4973 d = PL_uudmap[*(U8*)s++] & 077;
4976 hunk[0] = (a << 2) | (b >> 4);
4977 hunk[1] = (b << 4) | (c >> 2);
4978 hunk[2] = (c << 6) | d;
4979 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4984 else if (s[1] == '\n') /* possible checksum byte */
4987 XPUSHs(sv_2mortal(sv));
4992 if (strchr("fFdD", datumtype) ||
4993 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4997 while (checksum >= 16) {
5001 while (checksum >= 4) {
5007 along = (1 << checksum) - 1;
5008 while (cdouble < 0.0)
5010 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5011 sv_setnv(sv, cdouble);
5014 if (checksum < 32) {
5015 aulong = (1 << checksum) - 1;
5018 sv_setuv(sv, (UV)culong);
5020 XPUSHs(sv_2mortal(sv));
5024 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5025 PUSHs(&PL_sv_undef);
5030 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5034 *hunk = PL_uuemap[len];
5035 sv_catpvn(sv, hunk, 1);
5038 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5039 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5040 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5041 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5042 sv_catpvn(sv, hunk, 4);
5047 char r = (len > 1 ? s[1] : '\0');
5048 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5049 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5050 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5051 hunk[3] = PL_uuemap[0];
5052 sv_catpvn(sv, hunk, 4);
5054 sv_catpvn(sv, "\n", 1);
5058 S_is_an_int(pTHX_ char *s, STRLEN l)
5061 SV *result = newSVpvn(s, l);
5062 char *result_c = SvPV(result, n_a); /* convenience */
5063 char *out = result_c;
5073 SvREFCNT_dec(result);
5096 SvREFCNT_dec(result);
5102 SvCUR_set(result, out - result_c);
5106 /* pnum must be '\0' terminated */
5108 S_div128(pTHX_ SV *pnum, bool *done)
5111 char *s = SvPV(pnum, len);
5120 i = m * 10 + (*t - '0');
5122 r = (i >> 7); /* r < 10 */
5129 SvCUR_set(pnum, (STRLEN) (t - s));
5136 dSP; dMARK; dORIGMARK; dTARGET;
5137 register SV *cat = TARG;
5140 register char *pat = SvPVx(*++MARK, fromlen);
5142 register char *patend = pat + fromlen;
5147 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5148 static char *space10 = " ";
5150 /* These must not be in registers: */
5165 #ifdef PERL_NATINT_PACK
5166 int natint; /* native integer */
5171 sv_setpvn(cat, "", 0);
5173 while (pat < patend) {
5174 SV *lengthcode = Nullsv;
5175 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5176 datumtype = *pat++ & 0xFF;
5177 #ifdef PERL_NATINT_PACK
5180 if (isSPACE(datumtype)) {
5184 #ifndef PACKED_IS_OCTETS
5185 if (datumtype == 'U' && pat == patcopy+1)
5188 if (datumtype == '#') {
5189 while (pat < patend && *pat != '\n')
5194 char *natstr = "sSiIlL";
5196 if (strchr(natstr, datumtype)) {
5197 #ifdef PERL_NATINT_PACK
5203 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5206 len = strchr("@Xxu", datumtype) ? 0 : items;
5209 else if (isDIGIT(*pat)) {
5211 while (isDIGIT(*pat)) {
5212 len = (len * 10) + (*pat++ - '0');
5214 DIE(aTHX_ "Repeat count in pack overflows");
5221 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5222 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5223 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5224 ? *MARK : &PL_sv_no)
5225 + (*pat == 'Z' ? 1 : 0)));
5229 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5230 case ',': /* grandfather in commas but with a warning */
5231 if (commas++ == 0 && ckWARN(WARN_PACK))
5232 Perl_warner(aTHX_ WARN_PACK,
5233 "Invalid type in pack: '%c'", (int)datumtype);
5236 DIE(aTHX_ "%% may only be used in unpack");
5247 if (SvCUR(cat) < len)
5248 DIE(aTHX_ "X outside of string");
5255 sv_catpvn(cat, null10, 10);
5258 sv_catpvn(cat, null10, len);
5264 aptr = SvPV(fromstr, fromlen);
5265 if (pat[-1] == '*') {
5267 if (datumtype == 'Z')
5270 if (fromlen >= len) {
5271 sv_catpvn(cat, aptr, len);
5272 if (datumtype == 'Z')
5273 *(SvEND(cat)-1) = '\0';
5276 sv_catpvn(cat, aptr, fromlen);
5278 if (datumtype == 'A') {
5280 sv_catpvn(cat, space10, 10);
5283 sv_catpvn(cat, space10, len);
5287 sv_catpvn(cat, null10, 10);
5290 sv_catpvn(cat, null10, len);
5302 str = SvPV(fromstr, fromlen);
5306 SvCUR(cat) += (len+7)/8;
5307 SvGROW(cat, SvCUR(cat) + 1);
5308 aptr = SvPVX(cat) + aint;
5313 if (datumtype == 'B') {
5314 for (len = 0; len++ < aint;) {
5315 items |= *str++ & 1;
5319 *aptr++ = items & 0xff;
5325 for (len = 0; len++ < aint;) {
5331 *aptr++ = items & 0xff;
5337 if (datumtype == 'B')
5338 items <<= 7 - (aint & 7);
5340 items >>= 7 - (aint & 7);
5341 *aptr++ = items & 0xff;
5343 str = SvPVX(cat) + SvCUR(cat);
5358 str = SvPV(fromstr, fromlen);
5362 SvCUR(cat) += (len+1)/2;
5363 SvGROW(cat, SvCUR(cat) + 1);
5364 aptr = SvPVX(cat) + aint;
5369 if (datumtype == 'H') {
5370 for (len = 0; len++ < aint;) {
5372 items |= ((*str++ & 15) + 9) & 15;
5374 items |= *str++ & 15;
5378 *aptr++ = items & 0xff;
5384 for (len = 0; len++ < aint;) {
5386 items |= (((*str++ & 15) + 9) & 15) << 4;
5388 items |= (*str++ & 15) << 4;
5392 *aptr++ = items & 0xff;
5398 *aptr++ = items & 0xff;
5399 str = SvPVX(cat) + SvCUR(cat);
5410 aint = SvIV(fromstr);
5412 sv_catpvn(cat, &achar, sizeof(char));
5418 auint = SvUV(fromstr);
5419 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5420 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5425 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5430 afloat = (float)SvNV(fromstr);
5431 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5438 adouble = (double)SvNV(fromstr);
5439 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5445 ashort = (I16)SvIV(fromstr);
5447 ashort = PerlSock_htons(ashort);
5449 CAT16(cat, &ashort);
5455 ashort = (I16)SvIV(fromstr);
5457 ashort = htovs(ashort);
5459 CAT16(cat, &ashort);
5463 #if SHORTSIZE != SIZE16
5465 unsigned short aushort;
5469 aushort = SvUV(fromstr);
5470 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5480 aushort = (U16)SvUV(fromstr);
5481 CAT16(cat, &aushort);
5487 #if SHORTSIZE != SIZE16
5493 ashort = SvIV(fromstr);
5494 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5502 ashort = (I16)SvIV(fromstr);
5503 CAT16(cat, &ashort);
5510 auint = SvUV(fromstr);
5511 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5517 adouble = Perl_floor(SvNV(fromstr));
5520 DIE(aTHX_ "Cannot compress negative numbers");
5523 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5524 adouble <= 0xffffffff
5526 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5527 adouble <= UV_MAX_cxux
5534 char buf[1 + sizeof(UV)];
5535 char *in = buf + sizeof(buf);
5536 UV auv = U_V(adouble);
5539 *--in = (auv & 0x7f) | 0x80;
5542 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5543 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5545 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5546 char *from, *result, *in;
5551 /* Copy string and check for compliance */
5552 from = SvPV(fromstr, len);
5553 if ((norm = is_an_int(from, len)) == NULL)
5554 DIE(aTHX_ "can compress only unsigned integer");
5556 New('w', result, len, char);
5560 *--in = div128(norm, &done) | 0x80;
5561 result[len - 1] &= 0x7F; /* clear continue bit */
5562 sv_catpvn(cat, in, (result + len) - in);
5564 SvREFCNT_dec(norm); /* free norm */
5566 else if (SvNOKp(fromstr)) {
5567 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5568 char *in = buf + sizeof(buf);
5571 double next = floor(adouble / 128);
5572 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5573 if (in <= buf) /* this cannot happen ;-) */
5574 DIE(aTHX_ "Cannot compress integer");
5577 } while (adouble > 0);
5578 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5579 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5582 DIE(aTHX_ "Cannot compress non integer");
5588 aint = SvIV(fromstr);
5589 sv_catpvn(cat, (char*)&aint, sizeof(int));
5595 aulong = SvUV(fromstr);
5597 aulong = PerlSock_htonl(aulong);
5599 CAT32(cat, &aulong);
5605 aulong = SvUV(fromstr);
5607 aulong = htovl(aulong);
5609 CAT32(cat, &aulong);
5613 #if LONGSIZE != SIZE32
5615 unsigned long aulong;
5619 aulong = SvUV(fromstr);
5620 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5628 aulong = SvUV(fromstr);
5629 CAT32(cat, &aulong);
5634 #if LONGSIZE != SIZE32
5640 along = SvIV(fromstr);
5641 sv_catpvn(cat, (char *)&along, sizeof(long));
5649 along = SvIV(fromstr);
5658 auquad = (Uquad_t)SvUV(fromstr);
5659 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5665 aquad = (Quad_t)SvIV(fromstr);
5666 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5671 len = 1; /* assume SV is correct length */
5676 if (fromstr == &PL_sv_undef)
5680 /* XXX better yet, could spirit away the string to
5681 * a safe spot and hang on to it until the result
5682 * of pack() (and all copies of the result) are
5685 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5686 || (SvPADTMP(fromstr)
5687 && !SvREADONLY(fromstr))))
5689 Perl_warner(aTHX_ WARN_PACK,
5690 "Attempt to pack pointer to temporary value");
5692 if (SvPOK(fromstr) || SvNIOK(fromstr))
5693 aptr = SvPV(fromstr,n_a);
5695 aptr = SvPV_force(fromstr,n_a);
5697 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5702 aptr = SvPV(fromstr, fromlen);
5703 SvGROW(cat, fromlen * 4 / 3);
5708 while (fromlen > 0) {
5715 doencodes(cat, aptr, todo);
5734 register IV limit = POPi; /* note, negative is forever */
5737 register char *s = SvPV(sv, len);
5738 bool do_utf8 = DO_UTF8(sv);
5739 char *strend = s + len;
5741 register REGEXP *rx;
5745 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5746 I32 maxiters = slen + 10;
5749 I32 origlimit = limit;
5752 AV *oldstack = PL_curstack;
5753 I32 gimme = GIMME_V;
5754 I32 oldsave = PL_savestack_ix;
5755 I32 make_mortal = 1;
5756 MAGIC *mg = (MAGIC *) NULL;
5759 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5764 DIE(aTHX_ "panic: pp_split");
5765 rx = pm->op_pmregexp;
5767 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5768 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5770 if (pm->op_pmreplroot) {
5772 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5774 ary = GvAVn((GV*)pm->op_pmreplroot);
5777 else if (gimme != G_ARRAY)
5779 ary = (AV*)PL_curpad[0];
5781 ary = GvAVn(PL_defgv);
5782 #endif /* USE_THREADS */
5785 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5791 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5793 XPUSHs(SvTIED_obj((SV*)ary, mg));
5799 for (i = AvFILLp(ary); i >= 0; i--)
5800 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5802 /* temporarily switch stacks */
5803 SWITCHSTACK(PL_curstack, ary);
5807 base = SP - PL_stack_base;
5809 if (pm->op_pmflags & PMf_SKIPWHITE) {
5810 if (pm->op_pmflags & PMf_LOCALE) {
5811 while (isSPACE_LC(*s))
5819 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5820 SAVEINT(PL_multiline);
5821 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5825 limit = maxiters + 2;
5826 if (pm->op_pmflags & PMf_WHITE) {
5829 while (m < strend &&
5830 !((pm->op_pmflags & PMf_LOCALE)
5831 ? isSPACE_LC(*m) : isSPACE(*m)))
5836 dstr = NEWSV(30, m-s);
5837 sv_setpvn(dstr, s, m-s);
5841 (void)SvUTF8_on(dstr);
5845 while (s < strend &&
5846 ((pm->op_pmflags & PMf_LOCALE)
5847 ? isSPACE_LC(*s) : isSPACE(*s)))
5851 else if (strEQ("^", rx->precomp)) {
5854 for (m = s; m < strend && *m != '\n'; m++) ;
5858 dstr = NEWSV(30, m-s);
5859 sv_setpvn(dstr, s, m-s);
5863 (void)SvUTF8_on(dstr);
5868 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5869 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5870 && (rx->reganch & ROPT_CHECK_ALL)
5871 && !(rx->reganch & ROPT_ANCH)) {
5872 int tail = (rx->reganch & RE_INTUIT_TAIL);
5873 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5876 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5878 char c = *SvPV(csv, n_a);
5881 for (m = s; m < strend && *m != c; m++) ;
5884 dstr = NEWSV(30, m-s);
5885 sv_setpvn(dstr, s, m-s);
5889 (void)SvUTF8_on(dstr);
5891 /* The rx->minlen is in characters but we want to step
5892 * s ahead by bytes. */
5894 s = (char*)utf8_hop((U8*)m, len);
5896 s = m + len; /* Fake \n at the end */
5901 while (s < strend && --limit &&
5902 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5903 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5906 dstr = NEWSV(31, m-s);
5907 sv_setpvn(dstr, s, m-s);
5911 (void)SvUTF8_on(dstr);
5913 /* The rx->minlen is in characters but we want to step
5914 * s ahead by bytes. */
5916 s = (char*)utf8_hop((U8*)m, len);
5918 s = m + len; /* Fake \n at the end */
5923 maxiters += slen * rx->nparens;
5924 while (s < strend && --limit
5925 /* && (!rx->check_substr
5926 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5928 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5929 1 /* minend */, sv, NULL, 0))
5931 TAINT_IF(RX_MATCH_TAINTED(rx));
5932 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5937 strend = s + (strend - m);
5939 m = rx->startp[0] + orig;
5940 dstr = NEWSV(32, m-s);
5941 sv_setpvn(dstr, s, m-s);
5945 (void)SvUTF8_on(dstr);
5948 for (i = 1; i <= rx->nparens; i++) {
5949 s = rx->startp[i] + orig;
5950 m = rx->endp[i] + orig;
5952 dstr = NEWSV(33, m-s);
5953 sv_setpvn(dstr, s, m-s);
5956 dstr = NEWSV(33, 0);
5960 (void)SvUTF8_on(dstr);
5964 s = rx->endp[0] + orig;
5968 LEAVE_SCOPE(oldsave);
5969 iters = (SP - PL_stack_base) - base;
5970 if (iters > maxiters)
5971 DIE(aTHX_ "Split loop");
5973 /* keep field after final delim? */
5974 if (s < strend || (iters && origlimit)) {
5975 STRLEN l = strend - s;
5976 dstr = NEWSV(34, l);
5977 sv_setpvn(dstr, s, l);
5981 (void)SvUTF8_on(dstr);
5985 else if (!origlimit) {
5986 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5992 SWITCHSTACK(ary, oldstack);
5993 if (SvSMAGICAL(ary)) {
5998 if (gimme == G_ARRAY) {
6000 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6008 call_method("PUSH",G_SCALAR|G_DISCARD);
6011 if (gimme == G_ARRAY) {
6012 /* EXTEND should not be needed - we just popped them */
6014 for (i=0; i < iters; i++) {
6015 SV **svp = av_fetch(ary, i, FALSE);
6016 PUSHs((svp) ? *svp : &PL_sv_undef);
6023 if (gimme == G_ARRAY)
6026 if (iters || !pm->op_pmreplroot) {
6036 Perl_unlock_condpair(pTHX_ void *svv)
6038 MAGIC *mg = mg_find((SV*)svv, 'm');
6041 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6042 MUTEX_LOCK(MgMUTEXP(mg));
6043 if (MgOWNER(mg) != thr)
6044 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6046 COND_SIGNAL(MgOWNERCONDP(mg));
6047 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6048 PTR2UV(thr), PTR2UV(svv));)
6049 MUTEX_UNLOCK(MgMUTEXP(mg));
6051 #endif /* USE_THREADS */
6060 #endif /* USE_THREADS */
6061 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6062 || SvTYPE(retsv) == SVt_PVCV) {
6063 retsv = refto(retsv);
6074 if (PL_op->op_private & OPpLVAL_INTRO)
6075 PUSHs(*save_threadsv(PL_op->op_targ));
6077 PUSHs(THREADSV(PL_op->op_targ));
6080 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6081 #endif /* USE_THREADS */