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) == ' ')
4043 I32 start_sp_offset = SP - PL_stack_base;
4044 I32 gimme = GIMME_V;
4048 register char *pat = SvPV(left, llen);
4050 /* Packed side is assumed to be octets - so force downgrade if it
4051 has been UTF-8 encoded by accident
4053 register char *s = SvPVbyte(right, rlen);
4055 register char *s = SvPV(right, rlen);
4057 char *strend = s + rlen;
4059 register char *patend = pat + llen;
4065 /* These must not be in registers: */
4082 register U32 culong;
4086 #ifdef PERL_NATINT_PACK
4087 int natint; /* native integer */
4088 int unatint; /* unsigned native integer */
4091 if (gimme != G_ARRAY) { /* arrange to do first one only */
4093 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4094 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4096 while (isDIGIT(*patend) || *patend == '*')
4102 while (pat < patend) {
4104 datumtype = *pat++ & 0xFF;
4105 #ifdef PERL_NATINT_PACK
4108 if (isSPACE(datumtype))
4110 if (datumtype == '#') {
4111 while (pat < patend && *pat != '\n')
4116 char *natstr = "sSiIlL";
4118 if (strchr(natstr, datumtype)) {
4119 #ifdef PERL_NATINT_PACK
4125 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4130 else if (*pat == '*') {
4131 len = strend - strbeg; /* long enough */
4135 else if (isDIGIT(*pat)) {
4137 while (isDIGIT(*pat)) {
4138 len = (len * 10) + (*pat++ - '0');
4140 DIE(aTHX_ "Repeat count in unpack overflows");
4144 len = (datumtype != '@');
4148 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4149 case ',': /* grandfather in commas but with a warning */
4150 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4151 Perl_warner(aTHX_ WARN_UNPACK,
4152 "Invalid type in unpack: '%c'", (int)datumtype);
4155 if (len == 1 && pat[-1] != '1')
4164 if (len > strend - strbeg)
4165 DIE(aTHX_ "@ outside of string");
4169 if (len > s - strbeg)
4170 DIE(aTHX_ "X outside of string");
4174 if (len > strend - s)
4175 DIE(aTHX_ "x outside of string");
4179 if (start_sp_offset >= SP - PL_stack_base)
4180 DIE(aTHX_ "/ must follow a numeric type");
4183 pat++; /* ignore '*' for compatibility with pack */
4185 DIE(aTHX_ "/ cannot take a count" );
4192 if (len > strend - s)
4195 goto uchar_checksum;
4196 sv = NEWSV(35, len);
4197 sv_setpvn(sv, s, len);
4199 if (datumtype == 'A' || datumtype == 'Z') {
4200 aptr = s; /* borrow register */
4201 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4206 else { /* 'A' strips both nulls and spaces */
4207 s = SvPVX(sv) + len - 1;
4208 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4212 SvCUR_set(sv, s - SvPVX(sv));
4213 s = aptr; /* unborrow register */
4215 XPUSHs(sv_2mortal(sv));
4219 if (star || len > (strend - s) * 8)
4220 len = (strend - s) * 8;
4223 Newz(601, PL_bitcount, 256, char);
4224 for (bits = 1; bits < 256; bits++) {
4225 if (bits & 1) PL_bitcount[bits]++;
4226 if (bits & 2) PL_bitcount[bits]++;
4227 if (bits & 4) PL_bitcount[bits]++;
4228 if (bits & 8) PL_bitcount[bits]++;
4229 if (bits & 16) PL_bitcount[bits]++;
4230 if (bits & 32) PL_bitcount[bits]++;
4231 if (bits & 64) PL_bitcount[bits]++;
4232 if (bits & 128) PL_bitcount[bits]++;
4236 culong += PL_bitcount[*(unsigned char*)s++];
4241 if (datumtype == 'b') {
4243 if (bits & 1) culong++;
4249 if (bits & 128) culong++;
4256 sv = NEWSV(35, len + 1);
4260 if (datumtype == 'b') {
4262 for (len = 0; len < aint; len++) {
4263 if (len & 7) /*SUPPRESS 595*/
4267 *str++ = '0' + (bits & 1);
4272 for (len = 0; len < aint; len++) {
4277 *str++ = '0' + ((bits & 128) != 0);
4281 XPUSHs(sv_2mortal(sv));
4285 if (star || len > (strend - s) * 2)
4286 len = (strend - s) * 2;
4287 sv = NEWSV(35, len + 1);
4291 if (datumtype == 'h') {
4293 for (len = 0; len < aint; len++) {
4298 *str++ = PL_hexdigit[bits & 15];
4303 for (len = 0; len < aint; len++) {
4308 *str++ = PL_hexdigit[(bits >> 4) & 15];
4312 XPUSHs(sv_2mortal(sv));
4315 if (len > strend - s)
4320 if (aint >= 128) /* fake up signed chars */
4330 if (aint >= 128) /* fake up signed chars */
4333 sv_setiv(sv, (IV)aint);
4334 PUSHs(sv_2mortal(sv));
4339 if (len > strend - s)
4354 sv_setiv(sv, (IV)auint);
4355 PUSHs(sv_2mortal(sv));
4360 if (len > strend - s)
4363 while (len-- > 0 && s < strend) {
4365 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4369 cdouble += (NV)auint;
4377 while (len-- > 0 && s < strend) {
4379 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4383 sv_setuv(sv, (UV)auint);
4384 PUSHs(sv_2mortal(sv));
4389 #if SHORTSIZE == SIZE16
4390 along = (strend - s) / SIZE16;
4392 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4397 #if SHORTSIZE != SIZE16
4401 COPYNN(s, &ashort, sizeof(short));
4412 #if SHORTSIZE > SIZE16
4424 #if SHORTSIZE != SIZE16
4428 COPYNN(s, &ashort, sizeof(short));
4431 sv_setiv(sv, (IV)ashort);
4432 PUSHs(sv_2mortal(sv));
4440 #if SHORTSIZE > SIZE16
4446 sv_setiv(sv, (IV)ashort);
4447 PUSHs(sv_2mortal(sv));
4455 #if SHORTSIZE == SIZE16
4456 along = (strend - s) / SIZE16;
4458 unatint = natint && datumtype == 'S';
4459 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4464 #if SHORTSIZE != SIZE16
4466 unsigned short aushort;
4468 COPYNN(s, &aushort, sizeof(unsigned short));
4469 s += sizeof(unsigned short);
4477 COPY16(s, &aushort);
4480 if (datumtype == 'n')
4481 aushort = PerlSock_ntohs(aushort);
4484 if (datumtype == 'v')
4485 aushort = vtohs(aushort);
4494 #if SHORTSIZE != SIZE16
4496 unsigned short aushort;
4498 COPYNN(s, &aushort, sizeof(unsigned short));
4499 s += sizeof(unsigned short);
4501 sv_setiv(sv, (UV)aushort);
4502 PUSHs(sv_2mortal(sv));
4509 COPY16(s, &aushort);
4513 if (datumtype == 'n')
4514 aushort = PerlSock_ntohs(aushort);
4517 if (datumtype == 'v')
4518 aushort = vtohs(aushort);
4520 sv_setiv(sv, (UV)aushort);
4521 PUSHs(sv_2mortal(sv));
4527 along = (strend - s) / sizeof(int);
4532 Copy(s, &aint, 1, int);
4535 cdouble += (NV)aint;
4544 Copy(s, &aint, 1, int);
4548 /* Without the dummy below unpack("i", pack("i",-1))
4549 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4550 * cc with optimization turned on.
4552 * The bug was detected in
4553 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4554 * with optimization (-O4) turned on.
4555 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4556 * does not have this problem even with -O4.
4558 * This bug was reported as DECC_BUGS 1431
4559 * and tracked internally as GEM_BUGS 7775.
4561 * The bug is fixed in
4562 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4563 * UNIX V4.0F support: DEC C V5.9-006 or later
4564 * UNIX V4.0E support: DEC C V5.8-011 or later
4567 * See also few lines later for the same bug.
4570 sv_setiv(sv, (IV)aint) :
4572 sv_setiv(sv, (IV)aint);
4573 PUSHs(sv_2mortal(sv));
4578 along = (strend - s) / sizeof(unsigned int);
4583 Copy(s, &auint, 1, unsigned int);
4584 s += sizeof(unsigned int);
4586 cdouble += (NV)auint;
4595 Copy(s, &auint, 1, unsigned int);
4596 s += sizeof(unsigned int);
4599 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4600 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4601 * See details few lines earlier. */
4603 sv_setuv(sv, (UV)auint) :
4605 sv_setuv(sv, (UV)auint);
4606 PUSHs(sv_2mortal(sv));
4611 #if LONGSIZE == SIZE32
4612 along = (strend - s) / SIZE32;
4614 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4619 #if LONGSIZE != SIZE32
4622 COPYNN(s, &along, sizeof(long));
4625 cdouble += (NV)along;
4634 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4638 #if LONGSIZE > SIZE32
4639 if (along > 2147483647)
4640 along -= 4294967296;
4644 cdouble += (NV)along;
4653 #if LONGSIZE != SIZE32
4656 COPYNN(s, &along, sizeof(long));
4659 sv_setiv(sv, (IV)along);
4660 PUSHs(sv_2mortal(sv));
4667 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4671 #if LONGSIZE > SIZE32
4672 if (along > 2147483647)
4673 along -= 4294967296;
4677 sv_setiv(sv, (IV)along);
4678 PUSHs(sv_2mortal(sv));
4686 #if LONGSIZE == SIZE32
4687 along = (strend - s) / SIZE32;
4689 unatint = natint && datumtype == 'L';
4690 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4695 #if LONGSIZE != SIZE32
4697 unsigned long aulong;
4699 COPYNN(s, &aulong, sizeof(unsigned long));
4700 s += sizeof(unsigned long);
4702 cdouble += (NV)aulong;
4714 if (datumtype == 'N')
4715 aulong = PerlSock_ntohl(aulong);
4718 if (datumtype == 'V')
4719 aulong = vtohl(aulong);
4722 cdouble += (NV)aulong;
4731 #if LONGSIZE != SIZE32
4733 unsigned long aulong;
4735 COPYNN(s, &aulong, sizeof(unsigned long));
4736 s += sizeof(unsigned long);
4738 sv_setuv(sv, (UV)aulong);
4739 PUSHs(sv_2mortal(sv));
4749 if (datumtype == 'N')
4750 aulong = PerlSock_ntohl(aulong);
4753 if (datumtype == 'V')
4754 aulong = vtohl(aulong);
4757 sv_setuv(sv, (UV)aulong);
4758 PUSHs(sv_2mortal(sv));
4764 along = (strend - s) / sizeof(char*);
4770 if (sizeof(char*) > strend - s)
4773 Copy(s, &aptr, 1, char*);
4779 PUSHs(sv_2mortal(sv));
4789 while ((len > 0) && (s < strend)) {
4790 auv = (auv << 7) | (*s & 0x7f);
4791 if (UTF8_IS_ASCII(*s++)) {
4795 PUSHs(sv_2mortal(sv));
4799 else if (++bytes >= sizeof(UV)) { /* promote to string */
4803 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4804 while (s < strend) {
4805 sv = mul128(sv, *s & 0x7f);
4806 if (!(*s++ & 0x80)) {
4815 PUSHs(sv_2mortal(sv));
4820 if ((s >= strend) && bytes)
4821 DIE(aTHX_ "Unterminated compressed integer");
4826 if (sizeof(char*) > strend - s)
4829 Copy(s, &aptr, 1, char*);
4834 sv_setpvn(sv, aptr, len);
4835 PUSHs(sv_2mortal(sv));
4839 along = (strend - s) / sizeof(Quad_t);
4845 if (s + sizeof(Quad_t) > strend)
4848 Copy(s, &aquad, 1, Quad_t);
4849 s += sizeof(Quad_t);
4852 if (aquad >= IV_MIN && aquad <= IV_MAX)
4853 sv_setiv(sv, (IV)aquad);
4855 sv_setnv(sv, (NV)aquad);
4856 PUSHs(sv_2mortal(sv));
4860 along = (strend - s) / sizeof(Quad_t);
4866 if (s + sizeof(Uquad_t) > strend)
4869 Copy(s, &auquad, 1, Uquad_t);
4870 s += sizeof(Uquad_t);
4873 if (auquad <= UV_MAX)
4874 sv_setuv(sv, (UV)auquad);
4876 sv_setnv(sv, (NV)auquad);
4877 PUSHs(sv_2mortal(sv));
4881 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4884 along = (strend - s) / sizeof(float);
4889 Copy(s, &afloat, 1, float);
4898 Copy(s, &afloat, 1, float);
4901 sv_setnv(sv, (NV)afloat);
4902 PUSHs(sv_2mortal(sv));
4908 along = (strend - s) / sizeof(double);
4913 Copy(s, &adouble, 1, double);
4914 s += sizeof(double);
4922 Copy(s, &adouble, 1, double);
4923 s += sizeof(double);
4925 sv_setnv(sv, (NV)adouble);
4926 PUSHs(sv_2mortal(sv));
4932 * Initialise the decode mapping. By using a table driven
4933 * algorithm, the code will be character-set independent
4934 * (and just as fast as doing character arithmetic)
4936 if (PL_uudmap['M'] == 0) {
4939 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4940 PL_uudmap[(U8)PL_uuemap[i]] = i;
4942 * Because ' ' and '`' map to the same value,
4943 * we need to decode them both the same.
4948 along = (strend - s) * 3 / 4;
4949 sv = NEWSV(42, along);
4952 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4957 len = PL_uudmap[*(U8*)s++] & 077;
4959 if (s < strend && ISUUCHAR(*s))
4960 a = PL_uudmap[*(U8*)s++] & 077;
4963 if (s < strend && ISUUCHAR(*s))
4964 b = PL_uudmap[*(U8*)s++] & 077;
4967 if (s < strend && ISUUCHAR(*s))
4968 c = PL_uudmap[*(U8*)s++] & 077;
4971 if (s < strend && ISUUCHAR(*s))
4972 d = PL_uudmap[*(U8*)s++] & 077;
4975 hunk[0] = (a << 2) | (b >> 4);
4976 hunk[1] = (b << 4) | (c >> 2);
4977 hunk[2] = (c << 6) | d;
4978 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4983 else if (s[1] == '\n') /* possible checksum byte */
4986 XPUSHs(sv_2mortal(sv));
4991 if (strchr("fFdD", datumtype) ||
4992 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4996 while (checksum >= 16) {
5000 while (checksum >= 4) {
5006 along = (1 << checksum) - 1;
5007 while (cdouble < 0.0)
5009 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5010 sv_setnv(sv, cdouble);
5013 if (checksum < 32) {
5014 aulong = (1 << checksum) - 1;
5017 sv_setuv(sv, (UV)culong);
5019 XPUSHs(sv_2mortal(sv));
5023 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5024 PUSHs(&PL_sv_undef);
5029 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5033 *hunk = PL_uuemap[len];
5034 sv_catpvn(sv, hunk, 1);
5037 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5038 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5039 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5040 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5041 sv_catpvn(sv, hunk, 4);
5046 char r = (len > 1 ? s[1] : '\0');
5047 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5048 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5049 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5050 hunk[3] = PL_uuemap[0];
5051 sv_catpvn(sv, hunk, 4);
5053 sv_catpvn(sv, "\n", 1);
5057 S_is_an_int(pTHX_ char *s, STRLEN l)
5060 SV *result = newSVpvn(s, l);
5061 char *result_c = SvPV(result, n_a); /* convenience */
5062 char *out = result_c;
5072 SvREFCNT_dec(result);
5095 SvREFCNT_dec(result);
5101 SvCUR_set(result, out - result_c);
5105 /* pnum must be '\0' terminated */
5107 S_div128(pTHX_ SV *pnum, bool *done)
5110 char *s = SvPV(pnum, len);
5119 i = m * 10 + (*t - '0');
5121 r = (i >> 7); /* r < 10 */
5128 SvCUR_set(pnum, (STRLEN) (t - s));
5135 dSP; dMARK; dORIGMARK; dTARGET;
5136 register SV *cat = TARG;
5139 register char *pat = SvPVx(*++MARK, fromlen);
5141 register char *patend = pat + fromlen;
5146 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5147 static char *space10 = " ";
5149 /* These must not be in registers: */
5164 #ifdef PERL_NATINT_PACK
5165 int natint; /* native integer */
5170 sv_setpvn(cat, "", 0);
5172 while (pat < patend) {
5173 SV *lengthcode = Nullsv;
5174 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5175 datumtype = *pat++ & 0xFF;
5176 #ifdef PERL_NATINT_PACK
5179 if (isSPACE(datumtype)) {
5183 if (datumtype == 'U' && pat == patcopy+1)
5185 if (datumtype == '#') {
5186 while (pat < patend && *pat != '\n')
5191 char *natstr = "sSiIlL";
5193 if (strchr(natstr, datumtype)) {
5194 #ifdef PERL_NATINT_PACK
5200 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5203 len = strchr("@Xxu", datumtype) ? 0 : items;
5206 else if (isDIGIT(*pat)) {
5208 while (isDIGIT(*pat)) {
5209 len = (len * 10) + (*pat++ - '0');
5211 DIE(aTHX_ "Repeat count in pack overflows");
5218 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5219 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5220 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5221 ? *MARK : &PL_sv_no)
5222 + (*pat == 'Z' ? 1 : 0)));
5226 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5227 case ',': /* grandfather in commas but with a warning */
5228 if (commas++ == 0 && ckWARN(WARN_PACK))
5229 Perl_warner(aTHX_ WARN_PACK,
5230 "Invalid type in pack: '%c'", (int)datumtype);
5233 DIE(aTHX_ "%% may only be used in unpack");
5244 if (SvCUR(cat) < len)
5245 DIE(aTHX_ "X outside of string");
5252 sv_catpvn(cat, null10, 10);
5255 sv_catpvn(cat, null10, len);
5261 aptr = SvPV(fromstr, fromlen);
5262 if (pat[-1] == '*') {
5264 if (datumtype == 'Z')
5267 if (fromlen >= len) {
5268 sv_catpvn(cat, aptr, len);
5269 if (datumtype == 'Z')
5270 *(SvEND(cat)-1) = '\0';
5273 sv_catpvn(cat, aptr, fromlen);
5275 if (datumtype == 'A') {
5277 sv_catpvn(cat, space10, 10);
5280 sv_catpvn(cat, space10, len);
5284 sv_catpvn(cat, null10, 10);
5287 sv_catpvn(cat, null10, len);
5299 str = SvPV(fromstr, fromlen);
5303 SvCUR(cat) += (len+7)/8;
5304 SvGROW(cat, SvCUR(cat) + 1);
5305 aptr = SvPVX(cat) + aint;
5310 if (datumtype == 'B') {
5311 for (len = 0; len++ < aint;) {
5312 items |= *str++ & 1;
5316 *aptr++ = items & 0xff;
5322 for (len = 0; len++ < aint;) {
5328 *aptr++ = items & 0xff;
5334 if (datumtype == 'B')
5335 items <<= 7 - (aint & 7);
5337 items >>= 7 - (aint & 7);
5338 *aptr++ = items & 0xff;
5340 str = SvPVX(cat) + SvCUR(cat);
5355 str = SvPV(fromstr, fromlen);
5359 SvCUR(cat) += (len+1)/2;
5360 SvGROW(cat, SvCUR(cat) + 1);
5361 aptr = SvPVX(cat) + aint;
5366 if (datumtype == 'H') {
5367 for (len = 0; len++ < aint;) {
5369 items |= ((*str++ & 15) + 9) & 15;
5371 items |= *str++ & 15;
5375 *aptr++ = items & 0xff;
5381 for (len = 0; len++ < aint;) {
5383 items |= (((*str++ & 15) + 9) & 15) << 4;
5385 items |= (*str++ & 15) << 4;
5389 *aptr++ = items & 0xff;
5395 *aptr++ = items & 0xff;
5396 str = SvPVX(cat) + SvCUR(cat);
5407 aint = SvIV(fromstr);
5409 sv_catpvn(cat, &achar, sizeof(char));
5415 auint = SvUV(fromstr);
5416 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5417 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5422 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5427 afloat = (float)SvNV(fromstr);
5428 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5435 adouble = (double)SvNV(fromstr);
5436 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5442 ashort = (I16)SvIV(fromstr);
5444 ashort = PerlSock_htons(ashort);
5446 CAT16(cat, &ashort);
5452 ashort = (I16)SvIV(fromstr);
5454 ashort = htovs(ashort);
5456 CAT16(cat, &ashort);
5460 #if SHORTSIZE != SIZE16
5462 unsigned short aushort;
5466 aushort = SvUV(fromstr);
5467 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5477 aushort = (U16)SvUV(fromstr);
5478 CAT16(cat, &aushort);
5484 #if SHORTSIZE != SIZE16
5490 ashort = SvIV(fromstr);
5491 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5499 ashort = (I16)SvIV(fromstr);
5500 CAT16(cat, &ashort);
5507 auint = SvUV(fromstr);
5508 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5514 adouble = Perl_floor(SvNV(fromstr));
5517 DIE(aTHX_ "Cannot compress negative numbers");
5520 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5521 adouble <= 0xffffffff
5523 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5524 adouble <= UV_MAX_cxux
5531 char buf[1 + sizeof(UV)];
5532 char *in = buf + sizeof(buf);
5533 UV auv = U_V(adouble);
5536 *--in = (auv & 0x7f) | 0x80;
5539 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5540 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5542 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5543 char *from, *result, *in;
5548 /* Copy string and check for compliance */
5549 from = SvPV(fromstr, len);
5550 if ((norm = is_an_int(from, len)) == NULL)
5551 DIE(aTHX_ "can compress only unsigned integer");
5553 New('w', result, len, char);
5557 *--in = div128(norm, &done) | 0x80;
5558 result[len - 1] &= 0x7F; /* clear continue bit */
5559 sv_catpvn(cat, in, (result + len) - in);
5561 SvREFCNT_dec(norm); /* free norm */
5563 else if (SvNOKp(fromstr)) {
5564 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5565 char *in = buf + sizeof(buf);
5568 double next = floor(adouble / 128);
5569 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5570 if (in <= buf) /* this cannot happen ;-) */
5571 DIE(aTHX_ "Cannot compress integer");
5574 } while (adouble > 0);
5575 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5576 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5579 DIE(aTHX_ "Cannot compress non integer");
5585 aint = SvIV(fromstr);
5586 sv_catpvn(cat, (char*)&aint, sizeof(int));
5592 aulong = SvUV(fromstr);
5594 aulong = PerlSock_htonl(aulong);
5596 CAT32(cat, &aulong);
5602 aulong = SvUV(fromstr);
5604 aulong = htovl(aulong);
5606 CAT32(cat, &aulong);
5610 #if LONGSIZE != SIZE32
5612 unsigned long aulong;
5616 aulong = SvUV(fromstr);
5617 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5625 aulong = SvUV(fromstr);
5626 CAT32(cat, &aulong);
5631 #if LONGSIZE != SIZE32
5637 along = SvIV(fromstr);
5638 sv_catpvn(cat, (char *)&along, sizeof(long));
5646 along = SvIV(fromstr);
5655 auquad = (Uquad_t)SvUV(fromstr);
5656 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5662 aquad = (Quad_t)SvIV(fromstr);
5663 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5668 len = 1; /* assume SV is correct length */
5673 if (fromstr == &PL_sv_undef)
5677 /* XXX better yet, could spirit away the string to
5678 * a safe spot and hang on to it until the result
5679 * of pack() (and all copies of the result) are
5682 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5683 || (SvPADTMP(fromstr)
5684 && !SvREADONLY(fromstr))))
5686 Perl_warner(aTHX_ WARN_PACK,
5687 "Attempt to pack pointer to temporary value");
5689 if (SvPOK(fromstr) || SvNIOK(fromstr))
5690 aptr = SvPV(fromstr,n_a);
5692 aptr = SvPV_force(fromstr,n_a);
5694 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5699 aptr = SvPV(fromstr, fromlen);
5700 SvGROW(cat, fromlen * 4 / 3);
5705 while (fromlen > 0) {
5712 doencodes(cat, aptr, todo);
5731 register IV limit = POPi; /* note, negative is forever */
5734 register char *s = SvPV(sv, len);
5735 bool do_utf8 = DO_UTF8(sv);
5736 char *strend = s + len;
5738 register REGEXP *rx;
5742 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5743 I32 maxiters = slen + 10;
5746 I32 origlimit = limit;
5749 AV *oldstack = PL_curstack;
5750 I32 gimme = GIMME_V;
5751 I32 oldsave = PL_savestack_ix;
5752 I32 make_mortal = 1;
5753 MAGIC *mg = (MAGIC *) NULL;
5756 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5761 DIE(aTHX_ "panic: pp_split");
5762 rx = pm->op_pmregexp;
5764 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5765 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5767 if (pm->op_pmreplroot) {
5769 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5771 ary = GvAVn((GV*)pm->op_pmreplroot);
5774 else if (gimme != G_ARRAY)
5776 ary = (AV*)PL_curpad[0];
5778 ary = GvAVn(PL_defgv);
5779 #endif /* USE_THREADS */
5782 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5788 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5790 XPUSHs(SvTIED_obj((SV*)ary, mg));
5796 for (i = AvFILLp(ary); i >= 0; i--)
5797 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5799 /* temporarily switch stacks */
5800 SWITCHSTACK(PL_curstack, ary);
5804 base = SP - PL_stack_base;
5806 if (pm->op_pmflags & PMf_SKIPWHITE) {
5807 if (pm->op_pmflags & PMf_LOCALE) {
5808 while (isSPACE_LC(*s))
5816 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5817 SAVEINT(PL_multiline);
5818 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5822 limit = maxiters + 2;
5823 if (pm->op_pmflags & PMf_WHITE) {
5826 while (m < strend &&
5827 !((pm->op_pmflags & PMf_LOCALE)
5828 ? isSPACE_LC(*m) : isSPACE(*m)))
5833 dstr = NEWSV(30, m-s);
5834 sv_setpvn(dstr, s, m-s);
5838 (void)SvUTF8_on(dstr);
5842 while (s < strend &&
5843 ((pm->op_pmflags & PMf_LOCALE)
5844 ? isSPACE_LC(*s) : isSPACE(*s)))
5848 else if (strEQ("^", rx->precomp)) {
5851 for (m = s; m < strend && *m != '\n'; m++) ;
5855 dstr = NEWSV(30, m-s);
5856 sv_setpvn(dstr, s, m-s);
5860 (void)SvUTF8_on(dstr);
5865 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5866 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5867 && (rx->reganch & ROPT_CHECK_ALL)
5868 && !(rx->reganch & ROPT_ANCH)) {
5869 int tail = (rx->reganch & RE_INTUIT_TAIL);
5870 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5873 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5875 char c = *SvPV(csv, n_a);
5878 for (m = s; m < strend && *m != c; m++) ;
5881 dstr = NEWSV(30, m-s);
5882 sv_setpvn(dstr, s, m-s);
5886 (void)SvUTF8_on(dstr);
5888 /* The rx->minlen is in characters but we want to step
5889 * s ahead by bytes. */
5891 s = (char*)utf8_hop((U8*)m, len);
5893 s = m + len; /* Fake \n at the end */
5898 while (s < strend && --limit &&
5899 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5900 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5903 dstr = NEWSV(31, m-s);
5904 sv_setpvn(dstr, s, m-s);
5908 (void)SvUTF8_on(dstr);
5910 /* The rx->minlen is in characters but we want to step
5911 * s ahead by bytes. */
5913 s = (char*)utf8_hop((U8*)m, len);
5915 s = m + len; /* Fake \n at the end */
5920 maxiters += slen * rx->nparens;
5921 while (s < strend && --limit
5922 /* && (!rx->check_substr
5923 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5925 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5926 1 /* minend */, sv, NULL, 0))
5928 TAINT_IF(RX_MATCH_TAINTED(rx));
5929 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5934 strend = s + (strend - m);
5936 m = rx->startp[0] + orig;
5937 dstr = NEWSV(32, m-s);
5938 sv_setpvn(dstr, s, m-s);
5942 (void)SvUTF8_on(dstr);
5945 for (i = 1; i <= rx->nparens; i++) {
5946 s = rx->startp[i] + orig;
5947 m = rx->endp[i] + orig;
5949 dstr = NEWSV(33, m-s);
5950 sv_setpvn(dstr, s, m-s);
5953 dstr = NEWSV(33, 0);
5957 (void)SvUTF8_on(dstr);
5961 s = rx->endp[0] + orig;
5965 LEAVE_SCOPE(oldsave);
5966 iters = (SP - PL_stack_base) - base;
5967 if (iters > maxiters)
5968 DIE(aTHX_ "Split loop");
5970 /* keep field after final delim? */
5971 if (s < strend || (iters && origlimit)) {
5972 STRLEN l = strend - s;
5973 dstr = NEWSV(34, l);
5974 sv_setpvn(dstr, s, l);
5978 (void)SvUTF8_on(dstr);
5982 else if (!origlimit) {
5983 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5989 SWITCHSTACK(ary, oldstack);
5990 if (SvSMAGICAL(ary)) {
5995 if (gimme == G_ARRAY) {
5997 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6005 call_method("PUSH",G_SCALAR|G_DISCARD);
6008 if (gimme == G_ARRAY) {
6009 /* EXTEND should not be needed - we just popped them */
6011 for (i=0; i < iters; i++) {
6012 SV **svp = av_fetch(ary, i, FALSE);
6013 PUSHs((svp) ? *svp : &PL_sv_undef);
6020 if (gimme == G_ARRAY)
6023 if (iters || !pm->op_pmreplroot) {
6033 Perl_unlock_condpair(pTHX_ void *svv)
6035 MAGIC *mg = mg_find((SV*)svv, 'm');
6038 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6039 MUTEX_LOCK(MgMUTEXP(mg));
6040 if (MgOWNER(mg) != thr)
6041 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6043 COND_SIGNAL(MgOWNERCONDP(mg));
6044 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6045 PTR2UV(thr), PTR2UV(svv));)
6046 MUTEX_UNLOCK(MgMUTEXP(mg));
6048 #endif /* USE_THREADS */
6057 #endif /* USE_THREADS */
6058 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6059 || SvTYPE(retsv) == SVt_PVCV) {
6060 retsv = refto(retsv);
6071 if (PL_op->op_private & OPpLVAL_INTRO)
6072 PUSHs(*save_threadsv(PL_op->op_targ));
6074 PUSHs(THREADSV(PL_op->op_targ));
6077 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6078 #endif /* USE_THREADS */