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_INVARIANT(*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 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4793 if ((U8)(*s++) < 0x80) {
4797 PUSHs(sv_2mortal(sv));
4801 else if (++bytes >= sizeof(UV)) { /* promote to string */
4805 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4806 while (s < strend) {
4807 sv = mul128(sv, *s & 0x7f);
4808 if (!(*s++ & 0x80)) {
4817 PUSHs(sv_2mortal(sv));
4822 if ((s >= strend) && bytes)
4823 DIE(aTHX_ "Unterminated compressed integer");
4828 if (sizeof(char*) > strend - s)
4831 Copy(s, &aptr, 1, char*);
4836 sv_setpvn(sv, aptr, len);
4837 PUSHs(sv_2mortal(sv));
4841 along = (strend - s) / sizeof(Quad_t);
4847 if (s + sizeof(Quad_t) > strend)
4850 Copy(s, &aquad, 1, Quad_t);
4851 s += sizeof(Quad_t);
4854 if (aquad >= IV_MIN && aquad <= IV_MAX)
4855 sv_setiv(sv, (IV)aquad);
4857 sv_setnv(sv, (NV)aquad);
4858 PUSHs(sv_2mortal(sv));
4862 along = (strend - s) / sizeof(Quad_t);
4868 if (s + sizeof(Uquad_t) > strend)
4871 Copy(s, &auquad, 1, Uquad_t);
4872 s += sizeof(Uquad_t);
4875 if (auquad <= UV_MAX)
4876 sv_setuv(sv, (UV)auquad);
4878 sv_setnv(sv, (NV)auquad);
4879 PUSHs(sv_2mortal(sv));
4883 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4886 along = (strend - s) / sizeof(float);
4891 Copy(s, &afloat, 1, float);
4900 Copy(s, &afloat, 1, float);
4903 sv_setnv(sv, (NV)afloat);
4904 PUSHs(sv_2mortal(sv));
4910 along = (strend - s) / sizeof(double);
4915 Copy(s, &adouble, 1, double);
4916 s += sizeof(double);
4924 Copy(s, &adouble, 1, double);
4925 s += sizeof(double);
4927 sv_setnv(sv, (NV)adouble);
4928 PUSHs(sv_2mortal(sv));
4934 * Initialise the decode mapping. By using a table driven
4935 * algorithm, the code will be character-set independent
4936 * (and just as fast as doing character arithmetic)
4938 if (PL_uudmap['M'] == 0) {
4941 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4942 PL_uudmap[(U8)PL_uuemap[i]] = i;
4944 * Because ' ' and '`' map to the same value,
4945 * we need to decode them both the same.
4950 along = (strend - s) * 3 / 4;
4951 sv = NEWSV(42, along);
4954 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4959 len = PL_uudmap[*(U8*)s++] & 077;
4961 if (s < strend && ISUUCHAR(*s))
4962 a = PL_uudmap[*(U8*)s++] & 077;
4965 if (s < strend && ISUUCHAR(*s))
4966 b = PL_uudmap[*(U8*)s++] & 077;
4969 if (s < strend && ISUUCHAR(*s))
4970 c = PL_uudmap[*(U8*)s++] & 077;
4973 if (s < strend && ISUUCHAR(*s))
4974 d = PL_uudmap[*(U8*)s++] & 077;
4977 hunk[0] = (a << 2) | (b >> 4);
4978 hunk[1] = (b << 4) | (c >> 2);
4979 hunk[2] = (c << 6) | d;
4980 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4985 else if (s[1] == '\n') /* possible checksum byte */
4988 XPUSHs(sv_2mortal(sv));
4993 if (strchr("fFdD", datumtype) ||
4994 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4998 while (checksum >= 16) {
5002 while (checksum >= 4) {
5008 along = (1 << checksum) - 1;
5009 while (cdouble < 0.0)
5011 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5012 sv_setnv(sv, cdouble);
5015 if (checksum < 32) {
5016 aulong = (1 << checksum) - 1;
5019 sv_setuv(sv, (UV)culong);
5021 XPUSHs(sv_2mortal(sv));
5025 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5026 PUSHs(&PL_sv_undef);
5031 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5035 *hunk = PL_uuemap[len];
5036 sv_catpvn(sv, hunk, 1);
5039 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5040 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5041 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5042 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5043 sv_catpvn(sv, hunk, 4);
5048 char r = (len > 1 ? s[1] : '\0');
5049 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5050 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5051 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5052 hunk[3] = PL_uuemap[0];
5053 sv_catpvn(sv, hunk, 4);
5055 sv_catpvn(sv, "\n", 1);
5059 S_is_an_int(pTHX_ char *s, STRLEN l)
5062 SV *result = newSVpvn(s, l);
5063 char *result_c = SvPV(result, n_a); /* convenience */
5064 char *out = result_c;
5074 SvREFCNT_dec(result);
5097 SvREFCNT_dec(result);
5103 SvCUR_set(result, out - result_c);
5107 /* pnum must be '\0' terminated */
5109 S_div128(pTHX_ SV *pnum, bool *done)
5112 char *s = SvPV(pnum, len);
5121 i = m * 10 + (*t - '0');
5123 r = (i >> 7); /* r < 10 */
5130 SvCUR_set(pnum, (STRLEN) (t - s));
5137 dSP; dMARK; dORIGMARK; dTARGET;
5138 register SV *cat = TARG;
5141 register char *pat = SvPVx(*++MARK, fromlen);
5143 register char *patend = pat + fromlen;
5148 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5149 static char *space10 = " ";
5151 /* These must not be in registers: */
5166 #ifdef PERL_NATINT_PACK
5167 int natint; /* native integer */
5172 sv_setpvn(cat, "", 0);
5174 while (pat < patend) {
5175 SV *lengthcode = Nullsv;
5176 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5177 datumtype = *pat++ & 0xFF;
5178 #ifdef PERL_NATINT_PACK
5181 if (isSPACE(datumtype)) {
5185 #ifndef PACKED_IS_OCTETS
5186 if (datumtype == 'U' && pat == patcopy+1)
5189 if (datumtype == '#') {
5190 while (pat < patend && *pat != '\n')
5195 char *natstr = "sSiIlL";
5197 if (strchr(natstr, datumtype)) {
5198 #ifdef PERL_NATINT_PACK
5204 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5207 len = strchr("@Xxu", datumtype) ? 0 : items;
5210 else if (isDIGIT(*pat)) {
5212 while (isDIGIT(*pat)) {
5213 len = (len * 10) + (*pat++ - '0');
5215 DIE(aTHX_ "Repeat count in pack overflows");
5222 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5223 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5224 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5225 ? *MARK : &PL_sv_no)
5226 + (*pat == 'Z' ? 1 : 0)));
5230 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5231 case ',': /* grandfather in commas but with a warning */
5232 if (commas++ == 0 && ckWARN(WARN_PACK))
5233 Perl_warner(aTHX_ WARN_PACK,
5234 "Invalid type in pack: '%c'", (int)datumtype);
5237 DIE(aTHX_ "%% may only be used in unpack");
5248 if (SvCUR(cat) < len)
5249 DIE(aTHX_ "X outside of string");
5256 sv_catpvn(cat, null10, 10);
5259 sv_catpvn(cat, null10, len);
5265 aptr = SvPV(fromstr, fromlen);
5266 if (pat[-1] == '*') {
5268 if (datumtype == 'Z')
5271 if (fromlen >= len) {
5272 sv_catpvn(cat, aptr, len);
5273 if (datumtype == 'Z')
5274 *(SvEND(cat)-1) = '\0';
5277 sv_catpvn(cat, aptr, fromlen);
5279 if (datumtype == 'A') {
5281 sv_catpvn(cat, space10, 10);
5284 sv_catpvn(cat, space10, len);
5288 sv_catpvn(cat, null10, 10);
5291 sv_catpvn(cat, null10, len);
5303 str = SvPV(fromstr, fromlen);
5307 SvCUR(cat) += (len+7)/8;
5308 SvGROW(cat, SvCUR(cat) + 1);
5309 aptr = SvPVX(cat) + aint;
5314 if (datumtype == 'B') {
5315 for (len = 0; len++ < aint;) {
5316 items |= *str++ & 1;
5320 *aptr++ = items & 0xff;
5326 for (len = 0; len++ < aint;) {
5332 *aptr++ = items & 0xff;
5338 if (datumtype == 'B')
5339 items <<= 7 - (aint & 7);
5341 items >>= 7 - (aint & 7);
5342 *aptr++ = items & 0xff;
5344 str = SvPVX(cat) + SvCUR(cat);
5359 str = SvPV(fromstr, fromlen);
5363 SvCUR(cat) += (len+1)/2;
5364 SvGROW(cat, SvCUR(cat) + 1);
5365 aptr = SvPVX(cat) + aint;
5370 if (datumtype == 'H') {
5371 for (len = 0; len++ < aint;) {
5373 items |= ((*str++ & 15) + 9) & 15;
5375 items |= *str++ & 15;
5379 *aptr++ = items & 0xff;
5385 for (len = 0; len++ < aint;) {
5387 items |= (((*str++ & 15) + 9) & 15) << 4;
5389 items |= (*str++ & 15) << 4;
5393 *aptr++ = items & 0xff;
5399 *aptr++ = items & 0xff;
5400 str = SvPVX(cat) + SvCUR(cat);
5411 aint = SvIV(fromstr);
5413 sv_catpvn(cat, &achar, sizeof(char));
5419 auint = SvUV(fromstr);
5420 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5421 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5426 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5431 afloat = (float)SvNV(fromstr);
5432 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5439 adouble = (double)SvNV(fromstr);
5440 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5446 ashort = (I16)SvIV(fromstr);
5448 ashort = PerlSock_htons(ashort);
5450 CAT16(cat, &ashort);
5456 ashort = (I16)SvIV(fromstr);
5458 ashort = htovs(ashort);
5460 CAT16(cat, &ashort);
5464 #if SHORTSIZE != SIZE16
5466 unsigned short aushort;
5470 aushort = SvUV(fromstr);
5471 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5481 aushort = (U16)SvUV(fromstr);
5482 CAT16(cat, &aushort);
5488 #if SHORTSIZE != SIZE16
5494 ashort = SvIV(fromstr);
5495 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5503 ashort = (I16)SvIV(fromstr);
5504 CAT16(cat, &ashort);
5511 auint = SvUV(fromstr);
5512 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5518 adouble = Perl_floor(SvNV(fromstr));
5521 DIE(aTHX_ "Cannot compress negative numbers");
5524 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5525 adouble <= 0xffffffff
5527 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5528 adouble <= UV_MAX_cxux
5535 char buf[1 + sizeof(UV)];
5536 char *in = buf + sizeof(buf);
5537 UV auv = U_V(adouble);
5540 *--in = (auv & 0x7f) | 0x80;
5543 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5544 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5546 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5547 char *from, *result, *in;
5552 /* Copy string and check for compliance */
5553 from = SvPV(fromstr, len);
5554 if ((norm = is_an_int(from, len)) == NULL)
5555 DIE(aTHX_ "can compress only unsigned integer");
5557 New('w', result, len, char);
5561 *--in = div128(norm, &done) | 0x80;
5562 result[len - 1] &= 0x7F; /* clear continue bit */
5563 sv_catpvn(cat, in, (result + len) - in);
5565 SvREFCNT_dec(norm); /* free norm */
5567 else if (SvNOKp(fromstr)) {
5568 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5569 char *in = buf + sizeof(buf);
5572 double next = floor(adouble / 128);
5573 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5574 if (in <= buf) /* this cannot happen ;-) */
5575 DIE(aTHX_ "Cannot compress integer");
5578 } while (adouble > 0);
5579 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5580 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5583 DIE(aTHX_ "Cannot compress non integer");
5589 aint = SvIV(fromstr);
5590 sv_catpvn(cat, (char*)&aint, sizeof(int));
5596 aulong = SvUV(fromstr);
5598 aulong = PerlSock_htonl(aulong);
5600 CAT32(cat, &aulong);
5606 aulong = SvUV(fromstr);
5608 aulong = htovl(aulong);
5610 CAT32(cat, &aulong);
5614 #if LONGSIZE != SIZE32
5616 unsigned long aulong;
5620 aulong = SvUV(fromstr);
5621 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5629 aulong = SvUV(fromstr);
5630 CAT32(cat, &aulong);
5635 #if LONGSIZE != SIZE32
5641 along = SvIV(fromstr);
5642 sv_catpvn(cat, (char *)&along, sizeof(long));
5650 along = SvIV(fromstr);
5659 auquad = (Uquad_t)SvUV(fromstr);
5660 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5666 aquad = (Quad_t)SvIV(fromstr);
5667 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5672 len = 1; /* assume SV is correct length */
5677 if (fromstr == &PL_sv_undef)
5681 /* XXX better yet, could spirit away the string to
5682 * a safe spot and hang on to it until the result
5683 * of pack() (and all copies of the result) are
5686 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5687 || (SvPADTMP(fromstr)
5688 && !SvREADONLY(fromstr))))
5690 Perl_warner(aTHX_ WARN_PACK,
5691 "Attempt to pack pointer to temporary value");
5693 if (SvPOK(fromstr) || SvNIOK(fromstr))
5694 aptr = SvPV(fromstr,n_a);
5696 aptr = SvPV_force(fromstr,n_a);
5698 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5703 aptr = SvPV(fromstr, fromlen);
5704 SvGROW(cat, fromlen * 4 / 3);
5709 while (fromlen > 0) {
5716 doencodes(cat, aptr, todo);
5735 register IV limit = POPi; /* note, negative is forever */
5738 register char *s = SvPV(sv, len);
5739 bool do_utf8 = DO_UTF8(sv);
5740 char *strend = s + len;
5742 register REGEXP *rx;
5746 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5747 I32 maxiters = slen + 10;
5750 I32 origlimit = limit;
5753 AV *oldstack = PL_curstack;
5754 I32 gimme = GIMME_V;
5755 I32 oldsave = PL_savestack_ix;
5756 I32 make_mortal = 1;
5757 MAGIC *mg = (MAGIC *) NULL;
5760 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5765 DIE(aTHX_ "panic: pp_split");
5766 rx = pm->op_pmregexp;
5768 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5769 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5771 if (pm->op_pmreplroot) {
5773 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5775 ary = GvAVn((GV*)pm->op_pmreplroot);
5778 else if (gimme != G_ARRAY)
5780 ary = (AV*)PL_curpad[0];
5782 ary = GvAVn(PL_defgv);
5783 #endif /* USE_THREADS */
5786 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5792 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5794 XPUSHs(SvTIED_obj((SV*)ary, mg));
5800 for (i = AvFILLp(ary); i >= 0; i--)
5801 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5803 /* temporarily switch stacks */
5804 SWITCHSTACK(PL_curstack, ary);
5808 base = SP - PL_stack_base;
5810 if (pm->op_pmflags & PMf_SKIPWHITE) {
5811 if (pm->op_pmflags & PMf_LOCALE) {
5812 while (isSPACE_LC(*s))
5820 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5821 SAVEINT(PL_multiline);
5822 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5826 limit = maxiters + 2;
5827 if (pm->op_pmflags & PMf_WHITE) {
5830 while (m < strend &&
5831 !((pm->op_pmflags & PMf_LOCALE)
5832 ? isSPACE_LC(*m) : isSPACE(*m)))
5837 dstr = NEWSV(30, m-s);
5838 sv_setpvn(dstr, s, m-s);
5842 (void)SvUTF8_on(dstr);
5846 while (s < strend &&
5847 ((pm->op_pmflags & PMf_LOCALE)
5848 ? isSPACE_LC(*s) : isSPACE(*s)))
5852 else if (strEQ("^", rx->precomp)) {
5855 for (m = s; m < strend && *m != '\n'; m++) ;
5859 dstr = NEWSV(30, m-s);
5860 sv_setpvn(dstr, s, m-s);
5864 (void)SvUTF8_on(dstr);
5869 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5870 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5871 && (rx->reganch & ROPT_CHECK_ALL)
5872 && !(rx->reganch & ROPT_ANCH)) {
5873 int tail = (rx->reganch & RE_INTUIT_TAIL);
5874 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5877 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5879 char c = *SvPV(csv, n_a);
5882 for (m = s; m < strend && *m != c; m++) ;
5885 dstr = NEWSV(30, m-s);
5886 sv_setpvn(dstr, s, m-s);
5890 (void)SvUTF8_on(dstr);
5892 /* The rx->minlen is in characters but we want to step
5893 * s ahead by bytes. */
5895 s = (char*)utf8_hop((U8*)m, len);
5897 s = m + len; /* Fake \n at the end */
5902 while (s < strend && --limit &&
5903 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5904 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5907 dstr = NEWSV(31, m-s);
5908 sv_setpvn(dstr, s, m-s);
5912 (void)SvUTF8_on(dstr);
5914 /* The rx->minlen is in characters but we want to step
5915 * s ahead by bytes. */
5917 s = (char*)utf8_hop((U8*)m, len);
5919 s = m + len; /* Fake \n at the end */
5924 maxiters += slen * rx->nparens;
5925 while (s < strend && --limit
5926 /* && (!rx->check_substr
5927 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5929 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5930 1 /* minend */, sv, NULL, 0))
5932 TAINT_IF(RX_MATCH_TAINTED(rx));
5933 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5938 strend = s + (strend - m);
5940 m = rx->startp[0] + orig;
5941 dstr = NEWSV(32, m-s);
5942 sv_setpvn(dstr, s, m-s);
5946 (void)SvUTF8_on(dstr);
5949 for (i = 1; i <= rx->nparens; i++) {
5950 s = rx->startp[i] + orig;
5951 m = rx->endp[i] + orig;
5953 dstr = NEWSV(33, m-s);
5954 sv_setpvn(dstr, s, m-s);
5957 dstr = NEWSV(33, 0);
5961 (void)SvUTF8_on(dstr);
5965 s = rx->endp[0] + orig;
5969 LEAVE_SCOPE(oldsave);
5970 iters = (SP - PL_stack_base) - base;
5971 if (iters > maxiters)
5972 DIE(aTHX_ "Split loop");
5974 /* keep field after final delim? */
5975 if (s < strend || (iters && origlimit)) {
5976 STRLEN l = strend - s;
5977 dstr = NEWSV(34, l);
5978 sv_setpvn(dstr, s, l);
5982 (void)SvUTF8_on(dstr);
5986 else if (!origlimit) {
5987 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5993 SWITCHSTACK(ary, oldstack);
5994 if (SvSMAGICAL(ary)) {
5999 if (gimme == G_ARRAY) {
6001 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6009 call_method("PUSH",G_SCALAR|G_DISCARD);
6012 if (gimme == G_ARRAY) {
6013 /* EXTEND should not be needed - we just popped them */
6015 for (i=0; i < iters; i++) {
6016 SV **svp = av_fetch(ary, i, FALSE);
6017 PUSHs((svp) ? *svp : &PL_sv_undef);
6024 if (gimme == G_ARRAY)
6027 if (iters || !pm->op_pmreplroot) {
6037 Perl_unlock_condpair(pTHX_ void *svv)
6039 MAGIC *mg = mg_find((SV*)svv, 'm');
6042 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6043 MUTEX_LOCK(MgMUTEXP(mg));
6044 if (MgOWNER(mg) != thr)
6045 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6047 COND_SIGNAL(MgOWNERCONDP(mg));
6048 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6049 PTR2UV(thr), PTR2UV(svv));)
6050 MUTEX_UNLOCK(MgMUTEXP(mg));
6052 #endif /* USE_THREADS */
6061 #endif /* USE_THREADS */
6062 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6063 || SvTYPE(retsv) == SVt_PVCV) {
6064 retsv = refto(retsv);
6075 if (PL_op->op_private & OPpLVAL_INTRO)
6076 PUSHs(*save_threadsv(PL_op->op_targ));
6078 PUSHs(THREADSV(PL_op->op_targ));
6081 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6082 #endif /* USE_THREADS */