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;
2704 int num_args = PL_op->op_private & 7;
2705 bool repl_need_utf8_upgrade = FALSE;
2706 bool repl_is_utf8 = FALSE;
2708 SvTAINTED_off(TARG); /* decontaminate */
2709 SvUTF8_off(TARG); /* decontaminate */
2713 repl = SvPV(repl_sv, repl_len);
2714 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2724 sv_utf8_upgrade(sv);
2726 else if (DO_UTF8(sv))
2727 repl_need_utf8_upgrade = TRUE;
2729 tmps = SvPV(sv, curlen);
2731 utf8_curlen = sv_len_utf8(sv);
2732 if (utf8_curlen == curlen)
2735 curlen = utf8_curlen;
2740 if (pos >= arybase) {
2758 else if (len >= 0) {
2760 if (rem > (I32)curlen)
2775 Perl_croak(aTHX_ "substr outside of string");
2776 if (ckWARN(WARN_SUBSTR))
2777 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2784 sv_pos_u2b(sv, &pos, &rem);
2786 sv_setpvn(TARG, tmps, rem);
2790 SV* repl_sv_copy = NULL;
2792 if (repl_need_utf8_upgrade) {
2793 repl_sv_copy = newSVsv(repl_sv);
2794 sv_utf8_upgrade(repl_sv_copy);
2795 repl = SvPV(repl_sv_copy, repl_len);
2796 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2798 sv_insert(sv, pos, rem, repl, repl_len);
2802 SvREFCNT_dec(repl_sv_copy);
2804 else if (lvalue) { /* it's an lvalue! */
2805 if (!SvGMAGICAL(sv)) {
2809 if (ckWARN(WARN_SUBSTR))
2810 Perl_warner(aTHX_ WARN_SUBSTR,
2811 "Attempt to use reference as lvalue in substr");
2813 if (SvOK(sv)) /* is it defined ? */
2814 (void)SvPOK_only_UTF8(sv);
2816 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2819 if (SvTYPE(TARG) < SVt_PVLV) {
2820 sv_upgrade(TARG, SVt_PVLV);
2821 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2825 if (LvTARG(TARG) != sv) {
2827 SvREFCNT_dec(LvTARG(TARG));
2828 LvTARG(TARG) = SvREFCNT_inc(sv);
2830 LvTARGOFF(TARG) = upos;
2831 LvTARGLEN(TARG) = urem;
2835 PUSHs(TARG); /* avoid SvSETMAGIC here */
2842 register IV size = POPi;
2843 register IV offset = POPi;
2844 register SV *src = POPs;
2845 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2847 SvTAINTED_off(TARG); /* decontaminate */
2848 if (lvalue) { /* it's an lvalue! */
2849 if (SvTYPE(TARG) < SVt_PVLV) {
2850 sv_upgrade(TARG, SVt_PVLV);
2851 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2854 if (LvTARG(TARG) != src) {
2856 SvREFCNT_dec(LvTARG(TARG));
2857 LvTARG(TARG) = SvREFCNT_inc(src);
2859 LvTARGOFF(TARG) = offset;
2860 LvTARGLEN(TARG) = size;
2863 sv_setuv(TARG, do_vecget(src, offset, size));
2878 I32 arybase = PL_curcop->cop_arybase;
2883 offset = POPi - arybase;
2886 tmps = SvPV(big, biglen);
2887 if (offset > 0 && DO_UTF8(big))
2888 sv_pos_u2b(big, &offset, 0);
2891 else if (offset > biglen)
2893 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2894 (unsigned char*)tmps + biglen, little, 0)))
2897 retval = tmps2 - tmps;
2898 if (retval > 0 && DO_UTF8(big))
2899 sv_pos_b2u(big, &retval);
2900 PUSHi(retval + arybase);
2915 I32 arybase = PL_curcop->cop_arybase;
2921 tmps2 = SvPV(little, llen);
2922 tmps = SvPV(big, blen);
2926 if (offset > 0 && DO_UTF8(big))
2927 sv_pos_u2b(big, &offset, 0);
2928 offset = offset - arybase + llen;
2932 else if (offset > blen)
2934 if (!(tmps2 = rninstr(tmps, tmps + offset,
2935 tmps2, tmps2 + llen)))
2938 retval = tmps2 - tmps;
2939 if (retval > 0 && DO_UTF8(big))
2940 sv_pos_b2u(big, &retval);
2941 PUSHi(retval + arybase);
2947 dSP; dMARK; dORIGMARK; dTARGET;
2948 do_sprintf(TARG, SP-MARK, MARK+1);
2949 TAINT_IF(SvTAINTED(TARG));
2960 U8 *s = (U8*)SvPVx(argsv, len);
2962 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2972 (void)SvUPGRADE(TARG,SVt_PV);
2974 if (value > 255 && !IN_BYTE) {
2975 SvGROW(TARG, UNISKIP(value)+1);
2976 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
2977 SvCUR_set(TARG, tmps - SvPVX(TARG));
2979 (void)SvPOK_only(TARG);
2990 (void)SvPOK_only(TARG);
2997 dSP; dTARGET; dPOPTOPssrl;
3000 char *tmps = SvPV(left, n_a);
3002 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3004 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3008 "The crypt() function is unimplemented due to excessive paranoia.");
3021 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3023 U8 tmpbuf[UTF8_MAXLEN+1];
3027 if (PL_op->op_private & OPpLOCALE) {
3030 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3033 uv = toTITLE_utf8(s);
3035 tend = uvchr_to_utf8(tmpbuf, uv);
3037 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3039 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3040 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3045 s = (U8*)SvPV_force(sv, slen);
3046 Copy(tmpbuf, s, ulen, U8);
3050 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3052 SvUTF8_off(TARG); /* decontaminate */
3057 s = (U8*)SvPV_force(sv, slen);
3059 if (PL_op->op_private & OPpLOCALE) {
3062 *s = toUPPER_LC(*s);
3080 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3082 U8 tmpbuf[UTF8_MAXLEN+1];
3086 if (PL_op->op_private & OPpLOCALE) {
3089 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3092 uv = toLOWER_utf8(s);
3094 tend = uvchr_to_utf8(tmpbuf, uv);
3096 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3098 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3099 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3104 s = (U8*)SvPV_force(sv, slen);
3105 Copy(tmpbuf, s, ulen, U8);
3109 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3111 SvUTF8_off(TARG); /* decontaminate */
3116 s = (U8*)SvPV_force(sv, slen);
3118 if (PL_op->op_private & OPpLOCALE) {
3121 *s = toLOWER_LC(*s);
3145 s = (U8*)SvPV(sv,len);
3147 SvUTF8_off(TARG); /* decontaminate */
3148 sv_setpvn(TARG, "", 0);
3152 (void)SvUPGRADE(TARG, SVt_PV);
3153 SvGROW(TARG, (len * 2) + 1);
3154 (void)SvPOK_only(TARG);
3155 d = (U8*)SvPVX(TARG);
3157 if (PL_op->op_private & OPpLOCALE) {
3161 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3167 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3173 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3178 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3180 SvUTF8_off(TARG); /* decontaminate */
3185 s = (U8*)SvPV_force(sv, len);
3187 register U8 *send = s + len;
3189 if (PL_op->op_private & OPpLOCALE) {
3192 for (; s < send; s++)
3193 *s = toUPPER_LC(*s);
3196 for (; s < send; s++)
3219 s = (U8*)SvPV(sv,len);
3221 SvUTF8_off(TARG); /* decontaminate */
3222 sv_setpvn(TARG, "", 0);
3226 (void)SvUPGRADE(TARG, SVt_PV);
3227 SvGROW(TARG, (len * 2) + 1);
3228 (void)SvPOK_only(TARG);
3229 d = (U8*)SvPVX(TARG);
3231 if (PL_op->op_private & OPpLOCALE) {
3235 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3241 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3247 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3252 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3254 SvUTF8_off(TARG); /* decontaminate */
3260 s = (U8*)SvPV_force(sv, len);
3262 register U8 *send = s + len;
3264 if (PL_op->op_private & OPpLOCALE) {
3267 for (; s < send; s++)
3268 *s = toLOWER_LC(*s);
3271 for (; s < send; s++)
3286 register char *s = SvPV(sv,len);
3289 SvUTF8_off(TARG); /* decontaminate */
3291 (void)SvUPGRADE(TARG, SVt_PV);
3292 SvGROW(TARG, (len * 2) + 1);
3296 if (UTF8_IS_CONTINUED(*s)) {
3297 STRLEN ulen = UTF8SKIP(s);
3321 SvCUR_set(TARG, d - SvPVX(TARG));
3322 (void)SvPOK_only_UTF8(TARG);
3325 sv_setpvn(TARG, s, len);
3327 if (SvSMAGICAL(TARG))
3336 dSP; dMARK; dORIGMARK;
3338 register AV* av = (AV*)POPs;
3339 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3340 I32 arybase = PL_curcop->cop_arybase;
3343 if (SvTYPE(av) == SVt_PVAV) {
3344 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3346 for (svp = MARK + 1; svp <= SP; svp++) {
3351 if (max > AvMAX(av))
3354 while (++MARK <= SP) {
3355 elem = SvIVx(*MARK);
3359 svp = av_fetch(av, elem, lval);
3361 if (!svp || *svp == &PL_sv_undef)
3362 DIE(aTHX_ PL_no_aelem, elem);
3363 if (PL_op->op_private & OPpLVAL_INTRO)
3364 save_aelem(av, elem, svp);
3366 *MARK = svp ? *svp : &PL_sv_undef;
3369 if (GIMME != G_ARRAY) {
3377 /* Associative arrays. */
3382 HV *hash = (HV*)POPs;
3384 I32 gimme = GIMME_V;
3385 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3388 /* might clobber stack_sp */
3389 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3394 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3395 if (gimme == G_ARRAY) {
3398 /* might clobber stack_sp */
3400 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3405 else if (gimme == G_SCALAR)
3424 I32 gimme = GIMME_V;
3425 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3429 if (PL_op->op_private & OPpSLICE) {
3433 hvtype = SvTYPE(hv);
3434 if (hvtype == SVt_PVHV) { /* hash element */
3435 while (++MARK <= SP) {
3436 sv = hv_delete_ent(hv, *MARK, discard, 0);
3437 *MARK = sv ? sv : &PL_sv_undef;
3440 else if (hvtype == SVt_PVAV) {
3441 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3442 while (++MARK <= SP) {
3443 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3444 *MARK = sv ? sv : &PL_sv_undef;
3447 else { /* pseudo-hash element */
3448 while (++MARK <= SP) {
3449 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3450 *MARK = sv ? sv : &PL_sv_undef;
3455 DIE(aTHX_ "Not a HASH reference");
3458 else if (gimme == G_SCALAR) {
3467 if (SvTYPE(hv) == SVt_PVHV)
3468 sv = hv_delete_ent(hv, keysv, discard, 0);
3469 else if (SvTYPE(hv) == SVt_PVAV) {
3470 if (PL_op->op_flags & OPf_SPECIAL)
3471 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3473 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3476 DIE(aTHX_ "Not a HASH reference");
3491 if (PL_op->op_private & OPpEXISTS_SUB) {
3495 cv = sv_2cv(sv, &hv, &gv, FALSE);
3498 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3504 if (SvTYPE(hv) == SVt_PVHV) {
3505 if (hv_exists_ent(hv, tmpsv, 0))
3508 else if (SvTYPE(hv) == SVt_PVAV) {
3509 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3510 if (av_exists((AV*)hv, SvIV(tmpsv)))
3513 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3517 DIE(aTHX_ "Not a HASH reference");
3524 dSP; dMARK; dORIGMARK;
3525 register HV *hv = (HV*)POPs;
3526 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3527 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3529 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3530 DIE(aTHX_ "Can't localize pseudo-hash element");
3532 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3533 while (++MARK <= SP) {
3536 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3538 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3539 svp = he ? &HeVAL(he) : 0;
3542 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3545 if (!svp || *svp == &PL_sv_undef) {
3547 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3549 if (PL_op->op_private & OPpLVAL_INTRO) {
3551 save_helem(hv, keysv, svp);
3554 char *key = SvPV(keysv, keylen);
3555 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3559 *MARK = svp ? *svp : &PL_sv_undef;
3562 if (GIMME != G_ARRAY) {
3570 /* List operators. */
3575 if (GIMME != G_ARRAY) {
3577 *MARK = *SP; /* unwanted list, return last item */
3579 *MARK = &PL_sv_undef;
3588 SV **lastrelem = PL_stack_sp;
3589 SV **lastlelem = PL_stack_base + POPMARK;
3590 SV **firstlelem = PL_stack_base + POPMARK + 1;
3591 register SV **firstrelem = lastlelem + 1;
3592 I32 arybase = PL_curcop->cop_arybase;
3593 I32 lval = PL_op->op_flags & OPf_MOD;
3594 I32 is_something_there = lval;
3596 register I32 max = lastrelem - lastlelem;
3597 register SV **lelem;
3600 if (GIMME != G_ARRAY) {
3601 ix = SvIVx(*lastlelem);
3606 if (ix < 0 || ix >= max)
3607 *firstlelem = &PL_sv_undef;
3609 *firstlelem = firstrelem[ix];
3615 SP = firstlelem - 1;
3619 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3625 if (ix < 0 || ix >= max)
3626 *lelem = &PL_sv_undef;
3628 is_something_there = TRUE;
3629 if (!(*lelem = firstrelem[ix]))
3630 *lelem = &PL_sv_undef;
3633 if (is_something_there)
3636 SP = firstlelem - 1;
3642 dSP; dMARK; dORIGMARK;
3643 I32 items = SP - MARK;
3644 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3645 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3652 dSP; dMARK; dORIGMARK;
3653 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3657 SV *val = NEWSV(46, 0);
3659 sv_setsv(val, *++MARK);
3660 else if (ckWARN(WARN_MISC))
3661 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3662 (void)hv_store_ent(hv,key,val,0);
3671 dSP; dMARK; dORIGMARK;
3672 register AV *ary = (AV*)*++MARK;
3676 register I32 offset;
3677 register I32 length;
3684 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3685 *MARK-- = SvTIED_obj((SV*)ary, mg);
3689 call_method("SPLICE",GIMME_V);
3698 offset = i = SvIVx(*MARK);
3700 offset += AvFILLp(ary) + 1;
3702 offset -= PL_curcop->cop_arybase;
3704 DIE(aTHX_ PL_no_aelem, i);
3706 length = SvIVx(*MARK++);
3708 length += AvFILLp(ary) - offset + 1;
3714 length = AvMAX(ary) + 1; /* close enough to infinity */
3718 length = AvMAX(ary) + 1;
3720 if (offset > AvFILLp(ary) + 1)
3721 offset = AvFILLp(ary) + 1;
3722 after = AvFILLp(ary) + 1 - (offset + length);
3723 if (after < 0) { /* not that much array */
3724 length += after; /* offset+length now in array */
3730 /* At this point, MARK .. SP-1 is our new LIST */
3733 diff = newlen - length;
3734 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3737 if (diff < 0) { /* shrinking the area */
3739 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3740 Copy(MARK, tmparyval, newlen, SV*);
3743 MARK = ORIGMARK + 1;
3744 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3745 MEXTEND(MARK, length);
3746 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3748 EXTEND_MORTAL(length);
3749 for (i = length, dst = MARK; i; i--) {
3750 sv_2mortal(*dst); /* free them eventualy */
3757 *MARK = AvARRAY(ary)[offset+length-1];
3760 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3761 SvREFCNT_dec(*dst++); /* free them now */
3764 AvFILLp(ary) += diff;
3766 /* pull up or down? */
3768 if (offset < after) { /* easier to pull up */
3769 if (offset) { /* esp. if nothing to pull */
3770 src = &AvARRAY(ary)[offset-1];
3771 dst = src - diff; /* diff is negative */
3772 for (i = offset; i > 0; i--) /* can't trust Copy */
3776 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3780 if (after) { /* anything to pull down? */
3781 src = AvARRAY(ary) + offset + length;
3782 dst = src + diff; /* diff is negative */
3783 Move(src, dst, after, SV*);
3785 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3786 /* avoid later double free */
3790 dst[--i] = &PL_sv_undef;
3793 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3795 *dst = NEWSV(46, 0);
3796 sv_setsv(*dst++, *src++);
3798 Safefree(tmparyval);
3801 else { /* no, expanding (or same) */
3803 New(452, tmparyval, length, SV*); /* so remember deletion */
3804 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3807 if (diff > 0) { /* expanding */
3809 /* push up or down? */
3811 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3815 Move(src, dst, offset, SV*);
3817 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3819 AvFILLp(ary) += diff;
3822 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3823 av_extend(ary, AvFILLp(ary) + diff);
3824 AvFILLp(ary) += diff;
3827 dst = AvARRAY(ary) + AvFILLp(ary);
3829 for (i = after; i; i--) {
3836 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3837 *dst = NEWSV(46, 0);
3838 sv_setsv(*dst++, *src++);
3840 MARK = ORIGMARK + 1;
3841 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3843 Copy(tmparyval, MARK, length, SV*);
3845 EXTEND_MORTAL(length);
3846 for (i = length, dst = MARK; i; i--) {
3847 sv_2mortal(*dst); /* free them eventualy */
3851 Safefree(tmparyval);
3855 else if (length--) {
3856 *MARK = tmparyval[length];
3859 while (length-- > 0)
3860 SvREFCNT_dec(tmparyval[length]);
3862 Safefree(tmparyval);
3865 *MARK = &PL_sv_undef;
3873 dSP; dMARK; dORIGMARK; dTARGET;
3874 register AV *ary = (AV*)*++MARK;
3875 register SV *sv = &PL_sv_undef;
3878 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3879 *MARK-- = SvTIED_obj((SV*)ary, mg);
3883 call_method("PUSH",G_SCALAR|G_DISCARD);
3888 /* Why no pre-extend of ary here ? */
3889 for (++MARK; MARK <= SP; MARK++) {
3892 sv_setsv(sv, *MARK);
3897 PUSHi( AvFILL(ary) + 1 );
3905 SV *sv = av_pop(av);
3907 (void)sv_2mortal(sv);
3916 SV *sv = av_shift(av);
3921 (void)sv_2mortal(sv);
3928 dSP; dMARK; dORIGMARK; dTARGET;
3929 register AV *ary = (AV*)*++MARK;
3934 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3935 *MARK-- = SvTIED_obj((SV*)ary, mg);
3939 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3944 av_unshift(ary, SP - MARK);
3947 sv_setsv(sv, *++MARK);
3948 (void)av_store(ary, i++, sv);
3952 PUSHi( AvFILL(ary) + 1 );
3962 if (GIMME == G_ARRAY) {
3969 /* safe as long as stack cannot get extended in the above */
3974 register char *down;
3979 SvUTF8_off(TARG); /* decontaminate */
3981 do_join(TARG, &PL_sv_no, MARK, SP);
3983 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3984 up = SvPV_force(TARG, len);
3986 if (DO_UTF8(TARG)) { /* first reverse each character */
3987 U8* s = (U8*)SvPVX(TARG);
3988 U8* send = (U8*)(s + len);
3990 if (UTF8_IS_INVARIANT(*s)) {
3995 if (!utf8_to_uvchr(s, 0))
3999 down = (char*)(s - 1);
4000 /* reverse this character */
4010 down = SvPVX(TARG) + len - 1;
4016 (void)SvPOK_only_UTF8(TARG);
4025 S_mul128(pTHX_ SV *sv, U8 m)
4028 char *s = SvPV(sv, len);
4032 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4033 SV *tmpNew = newSVpvn("0000000000", 10);
4035 sv_catsv(tmpNew, sv);
4036 SvREFCNT_dec(sv); /* free old sv */
4041 while (!*t) /* trailing '\0'? */
4044 i = ((*t - '0') << 7) + m;
4045 *(t--) = '0' + (i % 10);
4051 /* Explosives and implosives. */
4053 #if 'I' == 73 && 'J' == 74
4054 /* On an ASCII/ISO kind of system */
4055 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4058 Some other sort of character set - use memchr() so we don't match
4061 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4069 I32 start_sp_offset = SP - PL_stack_base;
4070 I32 gimme = GIMME_V;
4074 register char *pat = SvPV(left, llen);
4075 #ifdef PACKED_IS_OCTETS
4076 /* Packed side is assumed to be octets - so force downgrade if it
4077 has been UTF-8 encoded by accident
4079 register char *s = SvPVbyte(right, rlen);
4081 register char *s = SvPV(right, rlen);
4083 char *strend = s + rlen;
4085 register char *patend = pat + llen;
4091 /* These must not be in registers: */
4108 register U32 culong;
4112 #ifdef PERL_NATINT_PACK
4113 int natint; /* native integer */
4114 int unatint; /* unsigned native integer */
4117 if (gimme != G_ARRAY) { /* arrange to do first one only */
4119 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4120 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4122 while (isDIGIT(*patend) || *patend == '*')
4128 while (pat < patend) {
4130 datumtype = *pat++ & 0xFF;
4131 #ifdef PERL_NATINT_PACK
4134 if (isSPACE(datumtype))
4136 if (datumtype == '#') {
4137 while (pat < patend && *pat != '\n')
4142 char *natstr = "sSiIlL";
4144 if (strchr(natstr, datumtype)) {
4145 #ifdef PERL_NATINT_PACK
4151 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4156 else if (*pat == '*') {
4157 len = strend - strbeg; /* long enough */
4161 else if (isDIGIT(*pat)) {
4163 while (isDIGIT(*pat)) {
4164 len = (len * 10) + (*pat++ - '0');
4166 DIE(aTHX_ "Repeat count in unpack overflows");
4170 len = (datumtype != '@');
4174 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4175 case ',': /* grandfather in commas but with a warning */
4176 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4177 Perl_warner(aTHX_ WARN_UNPACK,
4178 "Invalid type in unpack: '%c'", (int)datumtype);
4181 if (len == 1 && pat[-1] != '1')
4190 if (len > strend - strbeg)
4191 DIE(aTHX_ "@ outside of string");
4195 if (len > s - strbeg)
4196 DIE(aTHX_ "X outside of string");
4200 if (len > strend - s)
4201 DIE(aTHX_ "x outside of string");
4205 if (start_sp_offset >= SP - PL_stack_base)
4206 DIE(aTHX_ "/ must follow a numeric type");
4209 pat++; /* ignore '*' for compatibility with pack */
4211 DIE(aTHX_ "/ cannot take a count" );
4218 if (len > strend - s)
4221 goto uchar_checksum;
4222 sv = NEWSV(35, len);
4223 sv_setpvn(sv, s, len);
4225 if (datumtype == 'A' || datumtype == 'Z') {
4226 aptr = s; /* borrow register */
4227 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4232 else { /* 'A' strips both nulls and spaces */
4233 s = SvPVX(sv) + len - 1;
4234 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4238 SvCUR_set(sv, s - SvPVX(sv));
4239 s = aptr; /* unborrow register */
4241 XPUSHs(sv_2mortal(sv));
4245 if (star || len > (strend - s) * 8)
4246 len = (strend - s) * 8;
4249 Newz(601, PL_bitcount, 256, char);
4250 for (bits = 1; bits < 256; bits++) {
4251 if (bits & 1) PL_bitcount[bits]++;
4252 if (bits & 2) PL_bitcount[bits]++;
4253 if (bits & 4) PL_bitcount[bits]++;
4254 if (bits & 8) PL_bitcount[bits]++;
4255 if (bits & 16) PL_bitcount[bits]++;
4256 if (bits & 32) PL_bitcount[bits]++;
4257 if (bits & 64) PL_bitcount[bits]++;
4258 if (bits & 128) PL_bitcount[bits]++;
4262 culong += PL_bitcount[*(unsigned char*)s++];
4267 if (datumtype == 'b') {
4269 if (bits & 1) culong++;
4275 if (bits & 128) culong++;
4282 sv = NEWSV(35, len + 1);
4286 if (datumtype == 'b') {
4288 for (len = 0; len < aint; len++) {
4289 if (len & 7) /*SUPPRESS 595*/
4293 *str++ = '0' + (bits & 1);
4298 for (len = 0; len < aint; len++) {
4303 *str++ = '0' + ((bits & 128) != 0);
4307 XPUSHs(sv_2mortal(sv));
4311 if (star || len > (strend - s) * 2)
4312 len = (strend - s) * 2;
4313 sv = NEWSV(35, len + 1);
4317 if (datumtype == 'h') {
4319 for (len = 0; len < aint; len++) {
4324 *str++ = PL_hexdigit[bits & 15];
4329 for (len = 0; len < aint; len++) {
4334 *str++ = PL_hexdigit[(bits >> 4) & 15];
4338 XPUSHs(sv_2mortal(sv));
4341 if (len > strend - s)
4346 if (aint >= 128) /* fake up signed chars */
4356 if (aint >= 128) /* fake up signed chars */
4359 sv_setiv(sv, (IV)aint);
4360 PUSHs(sv_2mortal(sv));
4365 if (len > strend - s)
4380 sv_setiv(sv, (IV)auint);
4381 PUSHs(sv_2mortal(sv));
4386 if (len > strend - s)
4389 while (len-- > 0 && s < strend) {
4391 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4395 cdouble += (NV)auint;
4403 while (len-- > 0 && s < strend) {
4405 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4409 sv_setuv(sv, (UV)auint);
4410 PUSHs(sv_2mortal(sv));
4415 #if SHORTSIZE == SIZE16
4416 along = (strend - s) / SIZE16;
4418 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4423 #if SHORTSIZE != SIZE16
4427 COPYNN(s, &ashort, sizeof(short));
4438 #if SHORTSIZE > SIZE16
4450 #if SHORTSIZE != SIZE16
4454 COPYNN(s, &ashort, sizeof(short));
4457 sv_setiv(sv, (IV)ashort);
4458 PUSHs(sv_2mortal(sv));
4466 #if SHORTSIZE > SIZE16
4472 sv_setiv(sv, (IV)ashort);
4473 PUSHs(sv_2mortal(sv));
4481 #if SHORTSIZE == SIZE16
4482 along = (strend - s) / SIZE16;
4484 unatint = natint && datumtype == 'S';
4485 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4490 #if SHORTSIZE != SIZE16
4492 unsigned short aushort;
4494 COPYNN(s, &aushort, sizeof(unsigned short));
4495 s += sizeof(unsigned short);
4503 COPY16(s, &aushort);
4506 if (datumtype == 'n')
4507 aushort = PerlSock_ntohs(aushort);
4510 if (datumtype == 'v')
4511 aushort = vtohs(aushort);
4520 #if SHORTSIZE != SIZE16
4522 unsigned short aushort;
4524 COPYNN(s, &aushort, sizeof(unsigned short));
4525 s += sizeof(unsigned short);
4527 sv_setiv(sv, (UV)aushort);
4528 PUSHs(sv_2mortal(sv));
4535 COPY16(s, &aushort);
4539 if (datumtype == 'n')
4540 aushort = PerlSock_ntohs(aushort);
4543 if (datumtype == 'v')
4544 aushort = vtohs(aushort);
4546 sv_setiv(sv, (UV)aushort);
4547 PUSHs(sv_2mortal(sv));
4553 along = (strend - s) / sizeof(int);
4558 Copy(s, &aint, 1, int);
4561 cdouble += (NV)aint;
4570 Copy(s, &aint, 1, int);
4574 /* Without the dummy below unpack("i", pack("i",-1))
4575 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4576 * cc with optimization turned on.
4578 * The bug was detected in
4579 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4580 * with optimization (-O4) turned on.
4581 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4582 * does not have this problem even with -O4.
4584 * This bug was reported as DECC_BUGS 1431
4585 * and tracked internally as GEM_BUGS 7775.
4587 * The bug is fixed in
4588 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4589 * UNIX V4.0F support: DEC C V5.9-006 or later
4590 * UNIX V4.0E support: DEC C V5.8-011 or later
4593 * See also few lines later for the same bug.
4596 sv_setiv(sv, (IV)aint) :
4598 sv_setiv(sv, (IV)aint);
4599 PUSHs(sv_2mortal(sv));
4604 along = (strend - s) / sizeof(unsigned int);
4609 Copy(s, &auint, 1, unsigned int);
4610 s += sizeof(unsigned int);
4612 cdouble += (NV)auint;
4621 Copy(s, &auint, 1, unsigned int);
4622 s += sizeof(unsigned int);
4625 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4626 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4627 * See details few lines earlier. */
4629 sv_setuv(sv, (UV)auint) :
4631 sv_setuv(sv, (UV)auint);
4632 PUSHs(sv_2mortal(sv));
4637 #if LONGSIZE == SIZE32
4638 along = (strend - s) / SIZE32;
4640 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4645 #if LONGSIZE != SIZE32
4648 COPYNN(s, &along, sizeof(long));
4651 cdouble += (NV)along;
4660 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4664 #if LONGSIZE > SIZE32
4665 if (along > 2147483647)
4666 along -= 4294967296;
4670 cdouble += (NV)along;
4679 #if LONGSIZE != SIZE32
4682 COPYNN(s, &along, sizeof(long));
4685 sv_setiv(sv, (IV)along);
4686 PUSHs(sv_2mortal(sv));
4693 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4697 #if LONGSIZE > SIZE32
4698 if (along > 2147483647)
4699 along -= 4294967296;
4703 sv_setiv(sv, (IV)along);
4704 PUSHs(sv_2mortal(sv));
4712 #if LONGSIZE == SIZE32
4713 along = (strend - s) / SIZE32;
4715 unatint = natint && datumtype == 'L';
4716 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4721 #if LONGSIZE != SIZE32
4723 unsigned long aulong;
4725 COPYNN(s, &aulong, sizeof(unsigned long));
4726 s += sizeof(unsigned long);
4728 cdouble += (NV)aulong;
4740 if (datumtype == 'N')
4741 aulong = PerlSock_ntohl(aulong);
4744 if (datumtype == 'V')
4745 aulong = vtohl(aulong);
4748 cdouble += (NV)aulong;
4757 #if LONGSIZE != SIZE32
4759 unsigned long aulong;
4761 COPYNN(s, &aulong, sizeof(unsigned long));
4762 s += sizeof(unsigned long);
4764 sv_setuv(sv, (UV)aulong);
4765 PUSHs(sv_2mortal(sv));
4775 if (datumtype == 'N')
4776 aulong = PerlSock_ntohl(aulong);
4779 if (datumtype == 'V')
4780 aulong = vtohl(aulong);
4783 sv_setuv(sv, (UV)aulong);
4784 PUSHs(sv_2mortal(sv));
4790 along = (strend - s) / sizeof(char*);
4796 if (sizeof(char*) > strend - s)
4799 Copy(s, &aptr, 1, char*);
4805 PUSHs(sv_2mortal(sv));
4815 while ((len > 0) && (s < strend)) {
4816 auv = (auv << 7) | (*s & 0x7f);
4817 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4818 if ((U8)(*s++) < 0x80) {
4822 PUSHs(sv_2mortal(sv));
4826 else if (++bytes >= sizeof(UV)) { /* promote to string */
4830 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4831 while (s < strend) {
4832 sv = mul128(sv, *s & 0x7f);
4833 if (!(*s++ & 0x80)) {
4842 PUSHs(sv_2mortal(sv));
4847 if ((s >= strend) && bytes)
4848 DIE(aTHX_ "Unterminated compressed integer");
4853 if (sizeof(char*) > strend - s)
4856 Copy(s, &aptr, 1, char*);
4861 sv_setpvn(sv, aptr, len);
4862 PUSHs(sv_2mortal(sv));
4866 along = (strend - s) / sizeof(Quad_t);
4872 if (s + sizeof(Quad_t) > strend)
4875 Copy(s, &aquad, 1, Quad_t);
4876 s += sizeof(Quad_t);
4879 if (aquad >= IV_MIN && aquad <= IV_MAX)
4880 sv_setiv(sv, (IV)aquad);
4882 sv_setnv(sv, (NV)aquad);
4883 PUSHs(sv_2mortal(sv));
4887 along = (strend - s) / sizeof(Quad_t);
4893 if (s + sizeof(Uquad_t) > strend)
4896 Copy(s, &auquad, 1, Uquad_t);
4897 s += sizeof(Uquad_t);
4900 if (auquad <= UV_MAX)
4901 sv_setuv(sv, (UV)auquad);
4903 sv_setnv(sv, (NV)auquad);
4904 PUSHs(sv_2mortal(sv));
4908 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4911 along = (strend - s) / sizeof(float);
4916 Copy(s, &afloat, 1, float);
4925 Copy(s, &afloat, 1, float);
4928 sv_setnv(sv, (NV)afloat);
4929 PUSHs(sv_2mortal(sv));
4935 along = (strend - s) / sizeof(double);
4940 Copy(s, &adouble, 1, double);
4941 s += sizeof(double);
4949 Copy(s, &adouble, 1, double);
4950 s += sizeof(double);
4952 sv_setnv(sv, (NV)adouble);
4953 PUSHs(sv_2mortal(sv));
4959 * Initialise the decode mapping. By using a table driven
4960 * algorithm, the code will be character-set independent
4961 * (and just as fast as doing character arithmetic)
4963 if (PL_uudmap['M'] == 0) {
4966 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4967 PL_uudmap[(U8)PL_uuemap[i]] = i;
4969 * Because ' ' and '`' map to the same value,
4970 * we need to decode them both the same.
4975 along = (strend - s) * 3 / 4;
4976 sv = NEWSV(42, along);
4979 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4984 len = PL_uudmap[*(U8*)s++] & 077;
4986 if (s < strend && ISUUCHAR(*s))
4987 a = PL_uudmap[*(U8*)s++] & 077;
4990 if (s < strend && ISUUCHAR(*s))
4991 b = PL_uudmap[*(U8*)s++] & 077;
4994 if (s < strend && ISUUCHAR(*s))
4995 c = PL_uudmap[*(U8*)s++] & 077;
4998 if (s < strend && ISUUCHAR(*s))
4999 d = PL_uudmap[*(U8*)s++] & 077;
5002 hunk[0] = (a << 2) | (b >> 4);
5003 hunk[1] = (b << 4) | (c >> 2);
5004 hunk[2] = (c << 6) | d;
5005 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5010 else if (s[1] == '\n') /* possible checksum byte */
5013 XPUSHs(sv_2mortal(sv));
5018 if (strchr("fFdD", datumtype) ||
5019 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5023 while (checksum >= 16) {
5027 while (checksum >= 4) {
5033 along = (1 << checksum) - 1;
5034 while (cdouble < 0.0)
5036 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5037 sv_setnv(sv, cdouble);
5040 if (checksum < 32) {
5041 aulong = (1 << checksum) - 1;
5044 sv_setuv(sv, (UV)culong);
5046 XPUSHs(sv_2mortal(sv));
5050 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5051 PUSHs(&PL_sv_undef);
5056 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5060 *hunk = PL_uuemap[len];
5061 sv_catpvn(sv, hunk, 1);
5064 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5065 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5066 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5067 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5068 sv_catpvn(sv, hunk, 4);
5073 char r = (len > 1 ? s[1] : '\0');
5074 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5075 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5076 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5077 hunk[3] = PL_uuemap[0];
5078 sv_catpvn(sv, hunk, 4);
5080 sv_catpvn(sv, "\n", 1);
5084 S_is_an_int(pTHX_ char *s, STRLEN l)
5087 SV *result = newSVpvn(s, l);
5088 char *result_c = SvPV(result, n_a); /* convenience */
5089 char *out = result_c;
5099 SvREFCNT_dec(result);
5122 SvREFCNT_dec(result);
5128 SvCUR_set(result, out - result_c);
5132 /* pnum must be '\0' terminated */
5134 S_div128(pTHX_ SV *pnum, bool *done)
5137 char *s = SvPV(pnum, len);
5146 i = m * 10 + (*t - '0');
5148 r = (i >> 7); /* r < 10 */
5155 SvCUR_set(pnum, (STRLEN) (t - s));
5162 dSP; dMARK; dORIGMARK; dTARGET;
5163 register SV *cat = TARG;
5166 register char *pat = SvPVx(*++MARK, fromlen);
5168 register char *patend = pat + fromlen;
5173 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5174 static char *space10 = " ";
5176 /* These must not be in registers: */
5191 #ifdef PERL_NATINT_PACK
5192 int natint; /* native integer */
5197 sv_setpvn(cat, "", 0);
5199 while (pat < patend) {
5200 SV *lengthcode = Nullsv;
5201 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5202 datumtype = *pat++ & 0xFF;
5203 #ifdef PERL_NATINT_PACK
5206 if (isSPACE(datumtype)) {
5210 #ifndef PACKED_IS_OCTETS
5211 if (datumtype == 'U' && pat == patcopy+1)
5214 if (datumtype == '#') {
5215 while (pat < patend && *pat != '\n')
5220 char *natstr = "sSiIlL";
5222 if (strchr(natstr, datumtype)) {
5223 #ifdef PERL_NATINT_PACK
5229 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5232 len = strchr("@Xxu", datumtype) ? 0 : items;
5235 else if (isDIGIT(*pat)) {
5237 while (isDIGIT(*pat)) {
5238 len = (len * 10) + (*pat++ - '0');
5240 DIE(aTHX_ "Repeat count in pack overflows");
5247 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5248 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5249 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5250 ? *MARK : &PL_sv_no)
5251 + (*pat == 'Z' ? 1 : 0)));
5255 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5256 case ',': /* grandfather in commas but with a warning */
5257 if (commas++ == 0 && ckWARN(WARN_PACK))
5258 Perl_warner(aTHX_ WARN_PACK,
5259 "Invalid type in pack: '%c'", (int)datumtype);
5262 DIE(aTHX_ "%% may only be used in unpack");
5273 if (SvCUR(cat) < len)
5274 DIE(aTHX_ "X outside of string");
5281 sv_catpvn(cat, null10, 10);
5284 sv_catpvn(cat, null10, len);
5290 aptr = SvPV(fromstr, fromlen);
5291 if (pat[-1] == '*') {
5293 if (datumtype == 'Z')
5296 if (fromlen >= len) {
5297 sv_catpvn(cat, aptr, len);
5298 if (datumtype == 'Z')
5299 *(SvEND(cat)-1) = '\0';
5302 sv_catpvn(cat, aptr, fromlen);
5304 if (datumtype == 'A') {
5306 sv_catpvn(cat, space10, 10);
5309 sv_catpvn(cat, space10, len);
5313 sv_catpvn(cat, null10, 10);
5316 sv_catpvn(cat, null10, len);
5328 str = SvPV(fromstr, fromlen);
5332 SvCUR(cat) += (len+7)/8;
5333 SvGROW(cat, SvCUR(cat) + 1);
5334 aptr = SvPVX(cat) + aint;
5339 if (datumtype == 'B') {
5340 for (len = 0; len++ < aint;) {
5341 items |= *str++ & 1;
5345 *aptr++ = items & 0xff;
5351 for (len = 0; len++ < aint;) {
5357 *aptr++ = items & 0xff;
5363 if (datumtype == 'B')
5364 items <<= 7 - (aint & 7);
5366 items >>= 7 - (aint & 7);
5367 *aptr++ = items & 0xff;
5369 str = SvPVX(cat) + SvCUR(cat);
5384 str = SvPV(fromstr, fromlen);
5388 SvCUR(cat) += (len+1)/2;
5389 SvGROW(cat, SvCUR(cat) + 1);
5390 aptr = SvPVX(cat) + aint;
5395 if (datumtype == 'H') {
5396 for (len = 0; len++ < aint;) {
5398 items |= ((*str++ & 15) + 9) & 15;
5400 items |= *str++ & 15;
5404 *aptr++ = items & 0xff;
5410 for (len = 0; len++ < aint;) {
5412 items |= (((*str++ & 15) + 9) & 15) << 4;
5414 items |= (*str++ & 15) << 4;
5418 *aptr++ = items & 0xff;
5424 *aptr++ = items & 0xff;
5425 str = SvPVX(cat) + SvCUR(cat);
5436 aint = SvIV(fromstr);
5438 sv_catpvn(cat, &achar, sizeof(char));
5444 auint = SvUV(fromstr);
5445 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5446 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5451 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5456 afloat = (float)SvNV(fromstr);
5457 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5464 adouble = (double)SvNV(fromstr);
5465 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5471 ashort = (I16)SvIV(fromstr);
5473 ashort = PerlSock_htons(ashort);
5475 CAT16(cat, &ashort);
5481 ashort = (I16)SvIV(fromstr);
5483 ashort = htovs(ashort);
5485 CAT16(cat, &ashort);
5489 #if SHORTSIZE != SIZE16
5491 unsigned short aushort;
5495 aushort = SvUV(fromstr);
5496 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5506 aushort = (U16)SvUV(fromstr);
5507 CAT16(cat, &aushort);
5513 #if SHORTSIZE != SIZE16
5519 ashort = SvIV(fromstr);
5520 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5528 ashort = (I16)SvIV(fromstr);
5529 CAT16(cat, &ashort);
5536 auint = SvUV(fromstr);
5537 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5543 adouble = Perl_floor(SvNV(fromstr));
5546 DIE(aTHX_ "Cannot compress negative numbers");
5549 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5550 adouble <= 0xffffffff
5552 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5553 adouble <= UV_MAX_cxux
5560 char buf[1 + sizeof(UV)];
5561 char *in = buf + sizeof(buf);
5562 UV auv = U_V(adouble);
5565 *--in = (auv & 0x7f) | 0x80;
5568 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5569 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5571 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5572 char *from, *result, *in;
5577 /* Copy string and check for compliance */
5578 from = SvPV(fromstr, len);
5579 if ((norm = is_an_int(from, len)) == NULL)
5580 DIE(aTHX_ "can compress only unsigned integer");
5582 New('w', result, len, char);
5586 *--in = div128(norm, &done) | 0x80;
5587 result[len - 1] &= 0x7F; /* clear continue bit */
5588 sv_catpvn(cat, in, (result + len) - in);
5590 SvREFCNT_dec(norm); /* free norm */
5592 else if (SvNOKp(fromstr)) {
5593 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5594 char *in = buf + sizeof(buf);
5597 double next = floor(adouble / 128);
5598 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5599 if (in <= buf) /* this cannot happen ;-) */
5600 DIE(aTHX_ "Cannot compress integer");
5603 } while (adouble > 0);
5604 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5605 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5608 DIE(aTHX_ "Cannot compress non integer");
5614 aint = SvIV(fromstr);
5615 sv_catpvn(cat, (char*)&aint, sizeof(int));
5621 aulong = SvUV(fromstr);
5623 aulong = PerlSock_htonl(aulong);
5625 CAT32(cat, &aulong);
5631 aulong = SvUV(fromstr);
5633 aulong = htovl(aulong);
5635 CAT32(cat, &aulong);
5639 #if LONGSIZE != SIZE32
5641 unsigned long aulong;
5645 aulong = SvUV(fromstr);
5646 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5654 aulong = SvUV(fromstr);
5655 CAT32(cat, &aulong);
5660 #if LONGSIZE != SIZE32
5666 along = SvIV(fromstr);
5667 sv_catpvn(cat, (char *)&along, sizeof(long));
5675 along = SvIV(fromstr);
5684 auquad = (Uquad_t)SvUV(fromstr);
5685 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5691 aquad = (Quad_t)SvIV(fromstr);
5692 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5697 len = 1; /* assume SV is correct length */
5702 if (fromstr == &PL_sv_undef)
5706 /* XXX better yet, could spirit away the string to
5707 * a safe spot and hang on to it until the result
5708 * of pack() (and all copies of the result) are
5711 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5712 || (SvPADTMP(fromstr)
5713 && !SvREADONLY(fromstr))))
5715 Perl_warner(aTHX_ WARN_PACK,
5716 "Attempt to pack pointer to temporary value");
5718 if (SvPOK(fromstr) || SvNIOK(fromstr))
5719 aptr = SvPV(fromstr,n_a);
5721 aptr = SvPV_force(fromstr,n_a);
5723 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5728 aptr = SvPV(fromstr, fromlen);
5729 SvGROW(cat, fromlen * 4 / 3);
5734 while (fromlen > 0) {
5741 doencodes(cat, aptr, todo);
5760 register IV limit = POPi; /* note, negative is forever */
5763 register char *s = SvPV(sv, len);
5764 bool do_utf8 = DO_UTF8(sv);
5765 char *strend = s + len;
5767 register REGEXP *rx;
5771 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5772 I32 maxiters = slen + 10;
5775 I32 origlimit = limit;
5778 AV *oldstack = PL_curstack;
5779 I32 gimme = GIMME_V;
5780 I32 oldsave = PL_savestack_ix;
5781 I32 make_mortal = 1;
5782 MAGIC *mg = (MAGIC *) NULL;
5785 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5790 DIE(aTHX_ "panic: pp_split");
5791 rx = pm->op_pmregexp;
5793 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5794 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5796 if (pm->op_pmreplroot) {
5798 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5800 ary = GvAVn((GV*)pm->op_pmreplroot);
5803 else if (gimme != G_ARRAY)
5805 ary = (AV*)PL_curpad[0];
5807 ary = GvAVn(PL_defgv);
5808 #endif /* USE_THREADS */
5811 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5817 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5819 XPUSHs(SvTIED_obj((SV*)ary, mg));
5825 for (i = AvFILLp(ary); i >= 0; i--)
5826 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5828 /* temporarily switch stacks */
5829 SWITCHSTACK(PL_curstack, ary);
5833 base = SP - PL_stack_base;
5835 if (pm->op_pmflags & PMf_SKIPWHITE) {
5836 if (pm->op_pmflags & PMf_LOCALE) {
5837 while (isSPACE_LC(*s))
5845 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5846 SAVEINT(PL_multiline);
5847 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5851 limit = maxiters + 2;
5852 if (pm->op_pmflags & PMf_WHITE) {
5855 while (m < strend &&
5856 !((pm->op_pmflags & PMf_LOCALE)
5857 ? isSPACE_LC(*m) : isSPACE(*m)))
5862 dstr = NEWSV(30, m-s);
5863 sv_setpvn(dstr, s, m-s);
5867 (void)SvUTF8_on(dstr);
5871 while (s < strend &&
5872 ((pm->op_pmflags & PMf_LOCALE)
5873 ? isSPACE_LC(*s) : isSPACE(*s)))
5877 else if (strEQ("^", rx->precomp)) {
5880 for (m = s; m < strend && *m != '\n'; m++) ;
5884 dstr = NEWSV(30, m-s);
5885 sv_setpvn(dstr, s, m-s);
5889 (void)SvUTF8_on(dstr);
5894 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5895 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5896 && (rx->reganch & ROPT_CHECK_ALL)
5897 && !(rx->reganch & ROPT_ANCH)) {
5898 int tail = (rx->reganch & RE_INTUIT_TAIL);
5899 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5902 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5904 char c = *SvPV(csv, n_a);
5907 for (m = s; m < strend && *m != c; m++) ;
5910 dstr = NEWSV(30, m-s);
5911 sv_setpvn(dstr, s, m-s);
5915 (void)SvUTF8_on(dstr);
5917 /* The rx->minlen is in characters but we want to step
5918 * s ahead by bytes. */
5920 s = (char*)utf8_hop((U8*)m, len);
5922 s = m + len; /* Fake \n at the end */
5927 while (s < strend && --limit &&
5928 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5929 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5932 dstr = NEWSV(31, m-s);
5933 sv_setpvn(dstr, s, m-s);
5937 (void)SvUTF8_on(dstr);
5939 /* The rx->minlen is in characters but we want to step
5940 * s ahead by bytes. */
5942 s = (char*)utf8_hop((U8*)m, len);
5944 s = m + len; /* Fake \n at the end */
5949 maxiters += slen * rx->nparens;
5950 while (s < strend && --limit
5951 /* && (!rx->check_substr
5952 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5954 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5955 1 /* minend */, sv, NULL, 0))
5957 TAINT_IF(RX_MATCH_TAINTED(rx));
5958 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5963 strend = s + (strend - m);
5965 m = rx->startp[0] + orig;
5966 dstr = NEWSV(32, m-s);
5967 sv_setpvn(dstr, s, m-s);
5971 (void)SvUTF8_on(dstr);
5974 for (i = 1; i <= rx->nparens; i++) {
5975 s = rx->startp[i] + orig;
5976 m = rx->endp[i] + orig;
5978 dstr = NEWSV(33, m-s);
5979 sv_setpvn(dstr, s, m-s);
5982 dstr = NEWSV(33, 0);
5986 (void)SvUTF8_on(dstr);
5990 s = rx->endp[0] + orig;
5994 LEAVE_SCOPE(oldsave);
5995 iters = (SP - PL_stack_base) - base;
5996 if (iters > maxiters)
5997 DIE(aTHX_ "Split loop");
5999 /* keep field after final delim? */
6000 if (s < strend || (iters && origlimit)) {
6001 STRLEN l = strend - s;
6002 dstr = NEWSV(34, l);
6003 sv_setpvn(dstr, s, l);
6007 (void)SvUTF8_on(dstr);
6011 else if (!origlimit) {
6012 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6018 SWITCHSTACK(ary, oldstack);
6019 if (SvSMAGICAL(ary)) {
6024 if (gimme == G_ARRAY) {
6026 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6034 call_method("PUSH",G_SCALAR|G_DISCARD);
6037 if (gimme == G_ARRAY) {
6038 /* EXTEND should not be needed - we just popped them */
6040 for (i=0; i < iters; i++) {
6041 SV **svp = av_fetch(ary, i, FALSE);
6042 PUSHs((svp) ? *svp : &PL_sv_undef);
6049 if (gimme == G_ARRAY)
6052 if (iters || !pm->op_pmreplroot) {
6062 Perl_unlock_condpair(pTHX_ void *svv)
6064 MAGIC *mg = mg_find((SV*)svv, 'm');
6067 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6068 MUTEX_LOCK(MgMUTEXP(mg));
6069 if (MgOWNER(mg) != thr)
6070 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6072 COND_SIGNAL(MgOWNERCONDP(mg));
6073 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6074 PTR2UV(thr), PTR2UV(svv));)
6075 MUTEX_UNLOCK(MgMUTEXP(mg));
6077 #endif /* USE_THREADS */
6086 #endif /* USE_THREADS */
6087 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6088 || SvTYPE(retsv) == SVt_PVCV) {
6089 retsv = refto(retsv);
6100 if (PL_op->op_private & OPpLVAL_INTRO)
6101 PUSHs(*save_threadsv(PL_op->op_targ));
6103 PUSHs(THREADSV(PL_op->op_targ));
6106 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6107 #endif /* USE_THREADS */