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 djSP; 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 djSP; dMARK; dTARGET;
758 SETi(do_chomp(TOPs));
764 djSP; dMARK; dTARGET;
765 register I32 count = 0;
768 count += do_chomp(POPs);
779 if (!sv || !SvANY(sv))
781 switch (SvTYPE(sv)) {
783 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
787 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
791 if (CvROOT(sv) || CvXSUB(sv))
808 if (!PL_op->op_private) {
817 if (SvTHINKFIRST(sv))
820 switch (SvTYPE(sv)) {
830 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
831 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
832 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
836 /* let user-undef'd sub keep its identity */
837 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
844 SvSetMagicSV(sv, &PL_sv_undef);
848 Newz(602, gp, 1, GP);
849 GvGP(sv) = gp_ref(gp);
850 GvSV(sv) = NEWSV(72,0);
851 GvLINE(sv) = CopLINE(PL_curcop);
857 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
860 SvPV_set(sv, Nullch);
873 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
874 DIE(aTHX_ PL_no_modify);
875 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
876 SvIVX(TOPs) != IV_MIN)
879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
890 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
891 DIE(aTHX_ PL_no_modify);
892 sv_setsv(TARG, TOPs);
893 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
894 SvIVX(TOPs) != IV_MAX)
897 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
911 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
912 DIE(aTHX_ PL_no_modify);
913 sv_setsv(TARG, TOPs);
914 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
915 SvIVX(TOPs) != IV_MIN)
918 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
927 /* Ordinary operators. */
931 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
934 SETn( Perl_pow( left, right) );
941 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
942 #ifdef PERL_PRESERVE_IVUV
945 /* Unless the left argument is integer in range we are going to have to
946 use NV maths. Hence only attempt to coerce the right argument if
947 we know the left is integer. */
948 /* Left operand is defined, so is it IV? */
951 bool auvok = SvUOK(TOPm1s);
952 bool buvok = SvUOK(TOPs);
953 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
954 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
961 alow = SvUVX(TOPm1s);
963 IV aiv = SvIVX(TOPm1s);
966 auvok = TRUE; /* effectively it's a UV now */
968 alow = -aiv; /* abs, auvok == false records sign */
974 IV biv = SvIVX(TOPs);
977 buvok = TRUE; /* effectively it's a UV now */
979 blow = -biv; /* abs, buvok == false records sign */
983 /* If this does sign extension on unsigned it's time for plan B */
984 ahigh = alow >> (4 * sizeof (UV));
986 bhigh = blow >> (4 * sizeof (UV));
988 if (ahigh && bhigh) {
989 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
990 which is overflow. Drop to NVs below. */
991 } else if (!ahigh && !bhigh) {
992 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
993 so the unsigned multiply cannot overflow. */
994 UV product = alow * blow;
995 if (auvok == buvok) {
996 /* -ve * -ve or +ve * +ve gives a +ve result. */
1000 } else if (product <= (UV)IV_MIN) {
1001 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1002 /* -ve result, which could overflow an IV */
1006 } /* else drop to NVs below. */
1008 /* One operand is large, 1 small */
1011 /* swap the operands */
1013 bhigh = blow; /* bhigh now the temp var for the swap */
1017 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1018 multiplies can't overflow. shift can, add can, -ve can. */
1019 product_middle = ahigh * blow;
1020 if (!(product_middle & topmask)) {
1021 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1023 product_middle <<= (4 * sizeof (UV));
1024 product_low = alow * blow;
1026 /* as for pp_add, UV + something mustn't get smaller.
1027 IIRC ANSI mandates this wrapping *behaviour* for
1028 unsigned whatever the actual representation*/
1029 product_low += product_middle;
1030 if (product_low >= product_middle) {
1031 /* didn't overflow */
1032 if (auvok == buvok) {
1033 /* -ve * -ve or +ve * +ve gives a +ve result. */
1035 SETu( product_low );
1037 } else if (product_low <= (UV)IV_MIN) {
1038 /* 2s complement assumption again */
1039 /* -ve result, which could overflow an IV */
1041 SETi( -product_low );
1043 } /* else drop to NVs below. */
1045 } /* product_middle too large */
1046 } /* ahigh && bhigh */
1047 } /* SvIOK(TOPm1s) */
1052 SETn( left * right );
1059 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1064 DIE(aTHX_ "Illegal division by zero");
1066 /* insure that 20./5. == 4. */
1069 if ((NV)I_V(left) == left &&
1070 (NV)I_V(right) == right &&
1071 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1075 value = left / right;
1079 value = left / right;
1088 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1094 bool use_double = 0;
1098 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1100 right = (right_neg = (i < 0)) ? -i : i;
1105 right_neg = dright < 0;
1110 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1112 left = (left_neg = (i < 0)) ? -i : i;
1120 left_neg = dleft < 0;
1129 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1131 # define CAST_D2UV(d) U_V(d)
1133 # define CAST_D2UV(d) ((UV)(d))
1135 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1136 * or, in other words, precision of UV more than of NV.
1137 * But in fact the approach below turned out to be an
1138 * optimization - floor() may be slow */
1139 if (dright <= UV_MAX && dleft <= UV_MAX) {
1140 right = CAST_D2UV(dright);
1141 left = CAST_D2UV(dleft);
1146 /* Backward-compatibility clause: */
1147 dright = Perl_floor(dright + 0.5);
1148 dleft = Perl_floor(dleft + 0.5);
1151 DIE(aTHX_ "Illegal modulus zero");
1153 dans = Perl_fmod(dleft, dright);
1154 if ((left_neg != right_neg) && dans)
1155 dans = dright - dans;
1158 sv_setnv(TARG, dans);
1165 DIE(aTHX_ "Illegal modulus zero");
1168 if ((left_neg != right_neg) && ans)
1171 /* XXX may warn: unary minus operator applied to unsigned type */
1172 /* could change -foo to be (~foo)+1 instead */
1173 if (ans <= ~((UV)IV_MAX)+1)
1174 sv_setiv(TARG, ~ans+1);
1176 sv_setnv(TARG, -(NV)ans);
1179 sv_setuv(TARG, ans);
1188 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1190 register IV count = POPi;
1191 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1193 I32 items = SP - MARK;
1196 max = items * count;
1205 repeatcpy((char*)(MARK + items), (char*)MARK,
1206 items * sizeof(SV*), count - 1);
1209 else if (count <= 0)
1212 else { /* Note: mark already snarfed by pp_list */
1217 SvSetSV(TARG, tmpstr);
1218 SvPV_force(TARG, len);
1219 isutf = DO_UTF8(TARG);
1224 SvGROW(TARG, (count * len) + 1);
1225 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1226 SvCUR(TARG) *= count;
1228 *SvEND(TARG) = '\0';
1231 (void)SvPOK_only_UTF8(TARG);
1233 (void)SvPOK_only(TARG);
1242 djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1243 useleft = USE_LEFT(TOPm1s);
1244 #ifdef PERL_PRESERVE_IVUV
1245 /* We must see if we can perform the addition with integers if possible,
1246 as the integer code detects overflow while the NV code doesn't.
1247 If either argument hasn't had a numeric conversion yet attempt to get
1248 the IV. It's important to do this now, rather than just assuming that
1249 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1250 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1251 integer in case the second argument is IV=9223372036854775806
1252 We can (now) rely on sv_2iv to do the right thing, only setting the
1253 public IOK flag if the value in the NV (or PV) slot is truly integer.
1255 A side effect is that this also aggressively prefers integer maths over
1256 fp maths for integer values. */
1259 /* Unless the left argument is integer in range we are going to have to
1260 use NV maths. Hence only attempt to coerce the right argument if
1261 we know the left is integer. */
1263 /* left operand is undef, treat as zero. + 0 is identity. */
1265 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
1266 if (value <= (UV)IV_MIN) {
1267 /* 2s complement assumption. */
1270 } /* else drop through into NVs below */
1277 /* Left operand is defined, so is it IV? */
1278 SvIV_please(TOPm1s);
1279 if (SvIOK(TOPm1s)) {
1280 bool auvok = SvUOK(TOPm1s);
1281 bool buvok = SvUOK(TOPs);
1283 if (!auvok && !buvok) { /* ## IV - IV ## */
1284 IV aiv = SvIVX(TOPm1s);
1285 IV biv = SvIVX(TOPs);
1286 IV result = aiv - biv;
1288 if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
1293 /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
1294 /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
1295 /* -ve - +ve can only overflow too negative. */
1296 /* leaving +ve - -ve, which will go UV */
1297 if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
1298 /* 2s complement assumption for IV_MIN */
1299 UV result = (UV)aiv + (UV)-biv;
1300 /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
1301 overflow UV (2s complement assumption */
1302 assert (result >= (UV) aiv);
1307 /* Overflow, drop through to NVs */
1308 } else if (auvok && buvok) { /* ## UV - UV ## */
1309 UV auv = SvUVX(TOPm1s);
1310 UV buv = SvUVX(TOPs);
1318 /* Blatant 2s complement assumption. */
1319 result = (IV)(auv - buv);
1325 /* Overflow on IV - IV, drop through to NVs */
1326 } else if (auvok) { /* ## Mixed UV - IV ## */
1327 UV auv = SvUVX(TOPm1s);
1328 IV biv = SvIVX(TOPs);
1331 /* 2s complement assumptions for IV_MIN */
1332 UV result = auv + ((UV)-biv);
1333 /* UV + UV can only get bigger... */
1334 if (result >= auv) {
1339 /* and if it gets too big for UV then it's NV time. */
1340 } else if (auv > (UV)IV_MAX) {
1341 /* I think I'm making an implicit 2s complement
1342 assumption that IV_MIN == -IV_MAX - 1 */
1344 UV result = auv - (UV)biv;
1345 assert (result <= auv);
1351 IV result = (IV)auv - biv;
1352 assert (result <= (IV)auv);
1357 } else { /* ## Mixed IV - UV ## */
1358 IV aiv = SvIVX(TOPm1s);
1359 UV buv = SvUVX(TOPs);
1360 IV result = aiv - (IV)buv; /* 2s complement assumption. */
1362 /* result must not get larger. */
1363 if (result <= aiv) {
1367 } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
1376 /* left operand is undef, treat as zero - value */
1380 SETn( TOPn - value );
1387 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1390 if (PL_op->op_private & HINT_INTEGER) {
1404 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1407 if (PL_op->op_private & HINT_INTEGER) {
1421 djSP; tryAMAGICbinSET(lt,0);
1422 #ifdef PERL_PRESERVE_IVUV
1425 SvIV_please(TOPm1s);
1426 if (SvIOK(TOPm1s)) {
1427 bool auvok = SvUOK(TOPm1s);
1428 bool buvok = SvUOK(TOPs);
1430 if (!auvok && !buvok) { /* ## IV < IV ## */
1431 IV aiv = SvIVX(TOPm1s);
1432 IV biv = SvIVX(TOPs);
1435 SETs(boolSV(aiv < biv));
1438 if (auvok && buvok) { /* ## UV < UV ## */
1439 UV auv = SvUVX(TOPm1s);
1440 UV buv = SvUVX(TOPs);
1443 SETs(boolSV(auv < buv));
1446 if (auvok) { /* ## UV < IV ## */
1453 /* As (a) is a UV, it's >=0, so it cannot be < */
1458 if (auv >= (UV) IV_MAX) {
1459 /* As (b) is an IV, it cannot be > IV_MAX */
1463 SETs(boolSV(auv < (UV)biv));
1466 { /* ## IV < UV ## */
1470 aiv = SvIVX(TOPm1s);
1472 /* As (b) is a UV, it's >=0, so it must be < */
1479 if (buv > (UV) IV_MAX) {
1480 /* As (a) is an IV, it cannot be > IV_MAX */
1484 SETs(boolSV((UV)aiv < buv));
1492 SETs(boolSV(TOPn < value));
1499 djSP; tryAMAGICbinSET(gt,0);
1500 #ifdef PERL_PRESERVE_IVUV
1503 SvIV_please(TOPm1s);
1504 if (SvIOK(TOPm1s)) {
1505 bool auvok = SvUOK(TOPm1s);
1506 bool buvok = SvUOK(TOPs);
1508 if (!auvok && !buvok) { /* ## IV > IV ## */
1509 IV aiv = SvIVX(TOPm1s);
1510 IV biv = SvIVX(TOPs);
1513 SETs(boolSV(aiv > biv));
1516 if (auvok && buvok) { /* ## UV > UV ## */
1517 UV auv = SvUVX(TOPm1s);
1518 UV buv = SvUVX(TOPs);
1521 SETs(boolSV(auv > buv));
1524 if (auvok) { /* ## UV > IV ## */
1531 /* As (a) is a UV, it's >=0, so it must be > */
1536 if (auv > (UV) IV_MAX) {
1537 /* As (b) is an IV, it cannot be > IV_MAX */
1541 SETs(boolSV(auv > (UV)biv));
1544 { /* ## IV > UV ## */
1548 aiv = SvIVX(TOPm1s);
1550 /* As (b) is a UV, it's >=0, so it cannot be > */
1557 if (buv >= (UV) IV_MAX) {
1558 /* As (a) is an IV, it cannot be > IV_MAX */
1562 SETs(boolSV((UV)aiv > buv));
1570 SETs(boolSV(TOPn > value));
1577 djSP; tryAMAGICbinSET(le,0);
1578 #ifdef PERL_PRESERVE_IVUV
1581 SvIV_please(TOPm1s);
1582 if (SvIOK(TOPm1s)) {
1583 bool auvok = SvUOK(TOPm1s);
1584 bool buvok = SvUOK(TOPs);
1586 if (!auvok && !buvok) { /* ## IV <= IV ## */
1587 IV aiv = SvIVX(TOPm1s);
1588 IV biv = SvIVX(TOPs);
1591 SETs(boolSV(aiv <= biv));
1594 if (auvok && buvok) { /* ## UV <= UV ## */
1595 UV auv = SvUVX(TOPm1s);
1596 UV buv = SvUVX(TOPs);
1599 SETs(boolSV(auv <= buv));
1602 if (auvok) { /* ## UV <= IV ## */
1609 /* As (a) is a UV, it's >=0, so a cannot be <= */
1614 if (auv > (UV) IV_MAX) {
1615 /* As (b) is an IV, it cannot be > IV_MAX */
1619 SETs(boolSV(auv <= (UV)biv));
1622 { /* ## IV <= UV ## */
1626 aiv = SvIVX(TOPm1s);
1628 /* As (b) is a UV, it's >=0, so a must be <= */
1635 if (buv >= (UV) IV_MAX) {
1636 /* As (a) is an IV, it cannot be > IV_MAX */
1640 SETs(boolSV((UV)aiv <= buv));
1648 SETs(boolSV(TOPn <= value));
1655 djSP; tryAMAGICbinSET(ge,0);
1656 #ifdef PERL_PRESERVE_IVUV
1659 SvIV_please(TOPm1s);
1660 if (SvIOK(TOPm1s)) {
1661 bool auvok = SvUOK(TOPm1s);
1662 bool buvok = SvUOK(TOPs);
1664 if (!auvok && !buvok) { /* ## IV >= IV ## */
1665 IV aiv = SvIVX(TOPm1s);
1666 IV biv = SvIVX(TOPs);
1669 SETs(boolSV(aiv >= biv));
1672 if (auvok && buvok) { /* ## UV >= UV ## */
1673 UV auv = SvUVX(TOPm1s);
1674 UV buv = SvUVX(TOPs);
1677 SETs(boolSV(auv >= buv));
1680 if (auvok) { /* ## UV >= IV ## */
1687 /* As (a) is a UV, it's >=0, so it must be >= */
1692 if (auv >= (UV) IV_MAX) {
1693 /* As (b) is an IV, it cannot be > IV_MAX */
1697 SETs(boolSV(auv >= (UV)biv));
1700 { /* ## IV >= UV ## */
1704 aiv = SvIVX(TOPm1s);
1706 /* As (b) is a UV, it's >=0, so a cannot be >= */
1713 if (buv > (UV) IV_MAX) {
1714 /* As (a) is an IV, it cannot be > IV_MAX */
1718 SETs(boolSV((UV)aiv >= buv));
1726 SETs(boolSV(TOPn >= value));
1733 djSP; tryAMAGICbinSET(ne,0);
1734 #ifdef PERL_PRESERVE_IVUV
1737 SvIV_please(TOPm1s);
1738 if (SvIOK(TOPm1s)) {
1739 bool auvok = SvUOK(TOPm1s);
1740 bool buvok = SvUOK(TOPs);
1742 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1743 IV aiv = SvIVX(TOPm1s);
1744 IV biv = SvIVX(TOPs);
1747 SETs(boolSV(aiv != biv));
1750 if (auvok && buvok) { /* ## UV != UV ## */
1751 UV auv = SvUVX(TOPm1s);
1752 UV buv = SvUVX(TOPs);
1755 SETs(boolSV(auv != buv));
1758 { /* ## Mixed IV,UV ## */
1762 /* != is commutative so swap if needed (save code) */
1764 /* swap. top of stack (b) is the iv */
1768 /* As (a) is a UV, it's >0, so it cannot be == */
1777 /* As (b) is a UV, it's >0, so it cannot be == */
1781 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1783 /* we know iv is >= 0 */
1784 if (uv > (UV) IV_MAX) {
1788 SETs(boolSV((UV)iv != uv));
1796 SETs(boolSV(TOPn != value));
1803 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1804 #ifdef PERL_PRESERVE_IVUV
1805 /* Fortunately it seems NaN isn't IOK */
1808 SvIV_please(TOPm1s);
1809 if (SvIOK(TOPm1s)) {
1810 bool leftuvok = SvUOK(TOPm1s);
1811 bool rightuvok = SvUOK(TOPs);
1813 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1814 IV leftiv = SvIVX(TOPm1s);
1815 IV rightiv = SvIVX(TOPs);
1817 if (leftiv > rightiv)
1819 else if (leftiv < rightiv)
1823 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1824 UV leftuv = SvUVX(TOPm1s);
1825 UV rightuv = SvUVX(TOPs);
1827 if (leftuv > rightuv)
1829 else if (leftuv < rightuv)
1833 } else if (leftuvok) { /* ## UV <=> IV ## */
1837 rightiv = SvIVX(TOPs);
1839 /* As (a) is a UV, it's >=0, so it cannot be < */
1842 leftuv = SvUVX(TOPm1s);
1843 if (leftuv > (UV) IV_MAX) {
1844 /* As (b) is an IV, it cannot be > IV_MAX */
1846 } else if (leftuv > (UV)rightiv) {
1848 } else if (leftuv < (UV)rightiv) {
1854 } else { /* ## IV <=> UV ## */
1858 leftiv = SvIVX(TOPm1s);
1860 /* As (b) is a UV, it's >=0, so it must be < */
1863 rightuv = SvUVX(TOPs);
1864 if (rightuv > (UV) IV_MAX) {
1865 /* As (a) is an IV, it cannot be > IV_MAX */
1867 } else if (leftiv > (UV)rightuv) {
1869 } else if (leftiv < (UV)rightuv) {
1887 if (Perl_isnan(left) || Perl_isnan(right)) {
1891 value = (left > right) - (left < right);
1895 else if (left < right)
1897 else if (left > right)
1911 djSP; tryAMAGICbinSET(slt,0);
1914 int cmp = ((PL_op->op_private & OPpLOCALE)
1915 ? sv_cmp_locale(left, right)
1916 : sv_cmp(left, right));
1917 SETs(boolSV(cmp < 0));
1924 djSP; tryAMAGICbinSET(sgt,0);
1927 int cmp = ((PL_op->op_private & OPpLOCALE)
1928 ? sv_cmp_locale(left, right)
1929 : sv_cmp(left, right));
1930 SETs(boolSV(cmp > 0));
1937 djSP; tryAMAGICbinSET(sle,0);
1940 int cmp = ((PL_op->op_private & OPpLOCALE)
1941 ? sv_cmp_locale(left, right)
1942 : sv_cmp(left, right));
1943 SETs(boolSV(cmp <= 0));
1950 djSP; tryAMAGICbinSET(sge,0);
1953 int cmp = ((PL_op->op_private & OPpLOCALE)
1954 ? sv_cmp_locale(left, right)
1955 : sv_cmp(left, right));
1956 SETs(boolSV(cmp >= 0));
1963 djSP; tryAMAGICbinSET(seq,0);
1966 SETs(boolSV(sv_eq(left, right)));
1973 djSP; tryAMAGICbinSET(sne,0);
1976 SETs(boolSV(!sv_eq(left, right)));
1983 djSP; dTARGET; tryAMAGICbin(scmp,0);
1986 int cmp = ((PL_op->op_private & OPpLOCALE)
1987 ? sv_cmp_locale(left, right)
1988 : sv_cmp(left, right));
1996 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1999 if (SvNIOKp(left) || SvNIOKp(right)) {
2000 if (PL_op->op_private & HINT_INTEGER) {
2001 IV i = SvIV(left) & SvIV(right);
2005 UV u = SvUV(left) & SvUV(right);
2010 do_vop(PL_op->op_type, TARG, left, right);
2019 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2022 if (SvNIOKp(left) || SvNIOKp(right)) {
2023 if (PL_op->op_private & HINT_INTEGER) {
2024 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2028 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2033 do_vop(PL_op->op_type, TARG, left, right);
2042 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2045 if (SvNIOKp(left) || SvNIOKp(right)) {
2046 if (PL_op->op_private & HINT_INTEGER) {
2047 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2051 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2056 do_vop(PL_op->op_type, TARG, left, right);
2065 djSP; dTARGET; tryAMAGICun(neg);
2068 int flags = SvFLAGS(sv);
2071 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2072 /* It's publicly an integer, or privately an integer-not-float */
2075 if (SvIVX(sv) == IV_MIN) {
2076 /* 2s complement assumption. */
2077 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2080 else if (SvUVX(sv) <= IV_MAX) {
2085 else if (SvIVX(sv) != IV_MIN) {
2089 #ifdef PERL_PRESERVE_IVUV
2098 else if (SvPOKp(sv)) {
2100 char *s = SvPV(sv, len);
2101 if (isIDFIRST(*s)) {
2102 sv_setpvn(TARG, "-", 1);
2105 else if (*s == '+' || *s == '-') {
2107 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2109 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2110 sv_setpvn(TARG, "-", 1);
2116 goto oops_its_an_int;
2117 sv_setnv(TARG, -SvNV(sv));
2129 djSP; tryAMAGICunSET(not);
2130 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2136 djSP; dTARGET; tryAMAGICun(compl);
2140 if (PL_op->op_private & HINT_INTEGER) {
2155 tmps = (U8*)SvPV_force(TARG, len);
2158 /* Calculate exact length, let's not estimate. */
2167 while (tmps < send) {
2168 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2169 tmps += UTF8SKIP(tmps);
2170 targlen += UNISKIP(~c);
2176 /* Now rewind strings and write them. */
2180 Newz(0, result, targlen + 1, U8);
2181 while (tmps < send) {
2182 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2183 tmps += UTF8SKIP(tmps);
2184 result = uv_to_utf8(result, ~c);
2188 sv_setpvn(TARG, (char*)result, targlen);
2192 Newz(0, result, nchar + 1, U8);
2193 while (tmps < send) {
2194 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
2195 tmps += UTF8SKIP(tmps);
2200 sv_setpvn(TARG, (char*)result, nchar);
2208 register long *tmpl;
2209 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2212 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2217 for ( ; anum > 0; anum--, tmps++)
2226 /* integer versions of some of the above */
2230 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2233 SETi( left * right );
2240 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2244 DIE(aTHX_ "Illegal division by zero");
2245 value = POPi / value;
2253 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2257 DIE(aTHX_ "Illegal modulus zero");
2258 SETi( left % right );
2265 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2268 SETi( left + right );
2275 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2278 SETi( left - right );
2285 djSP; tryAMAGICbinSET(lt,0);
2288 SETs(boolSV(left < right));
2295 djSP; tryAMAGICbinSET(gt,0);
2298 SETs(boolSV(left > right));
2305 djSP; tryAMAGICbinSET(le,0);
2308 SETs(boolSV(left <= right));
2315 djSP; tryAMAGICbinSET(ge,0);
2318 SETs(boolSV(left >= right));
2325 djSP; tryAMAGICbinSET(eq,0);
2328 SETs(boolSV(left == right));
2335 djSP; tryAMAGICbinSET(ne,0);
2338 SETs(boolSV(left != right));
2345 djSP; dTARGET; tryAMAGICbin(ncmp,0);
2352 else if (left < right)
2363 djSP; dTARGET; tryAMAGICun(neg);
2368 /* High falutin' math. */
2372 djSP; dTARGET; tryAMAGICbin(atan2,0);
2375 SETn(Perl_atan2(left, right));
2382 djSP; dTARGET; tryAMAGICun(sin);
2386 value = Perl_sin(value);
2394 djSP; dTARGET; tryAMAGICun(cos);
2398 value = Perl_cos(value);
2404 /* Support Configure command-line overrides for rand() functions.
2405 After 5.005, perhaps we should replace this by Configure support
2406 for drand48(), random(), or rand(). For 5.005, though, maintain
2407 compatibility by calling rand() but allow the user to override it.
2408 See INSTALL for details. --Andy Dougherty 15 July 1998
2410 /* Now it's after 5.005, and Configure supports drand48() and random(),
2411 in addition to rand(). So the overrides should not be needed any more.
2412 --Jarkko Hietaniemi 27 September 1998
2415 #ifndef HAS_DRAND48_PROTO
2416 extern double drand48 (void);
2429 if (!PL_srand_called) {
2430 (void)seedDrand01((Rand_seed_t)seed());
2431 PL_srand_called = TRUE;
2446 (void)seedDrand01((Rand_seed_t)anum);
2447 PL_srand_called = TRUE;
2456 * This is really just a quick hack which grabs various garbage
2457 * values. It really should be a real hash algorithm which
2458 * spreads the effect of every input bit onto every output bit,
2459 * if someone who knows about such things would bother to write it.
2460 * Might be a good idea to add that function to CORE as well.
2461 * No numbers below come from careful analysis or anything here,
2462 * except they are primes and SEED_C1 > 1E6 to get a full-width
2463 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2464 * probably be bigger too.
2467 # define SEED_C1 1000003
2468 #define SEED_C4 73819
2470 # define SEED_C1 25747
2471 #define SEED_C4 20639
2475 #define SEED_C5 26107
2477 #ifndef PERL_NO_DEV_RANDOM
2482 # include <starlet.h>
2483 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2484 * in 100-ns units, typically incremented ever 10 ms. */
2485 unsigned int when[2];
2487 # ifdef HAS_GETTIMEOFDAY
2488 struct timeval when;
2494 /* This test is an escape hatch, this symbol isn't set by Configure. */
2495 #ifndef PERL_NO_DEV_RANDOM
2496 #ifndef PERL_RANDOM_DEVICE
2497 /* /dev/random isn't used by default because reads from it will block
2498 * if there isn't enough entropy available. You can compile with
2499 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2500 * is enough real entropy to fill the seed. */
2501 # define PERL_RANDOM_DEVICE "/dev/urandom"
2503 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2505 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2514 _ckvmssts(sys$gettim(when));
2515 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2517 # ifdef HAS_GETTIMEOFDAY
2518 gettimeofday(&when,(struct timezone *) 0);
2519 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2522 u = (U32)SEED_C1 * when;
2525 u += SEED_C3 * (U32)PerlProc_getpid();
2526 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2527 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2528 u += SEED_C5 * (U32)PTR2UV(&when);
2535 djSP; dTARGET; tryAMAGICun(exp);
2539 value = Perl_exp(value);
2547 djSP; dTARGET; tryAMAGICun(log);
2552 SET_NUMERIC_STANDARD();
2553 DIE(aTHX_ "Can't take log of %g", value);
2555 value = Perl_log(value);
2563 djSP; dTARGET; tryAMAGICun(sqrt);
2568 SET_NUMERIC_STANDARD();
2569 DIE(aTHX_ "Can't take sqrt of %g", value);
2571 value = Perl_sqrt(value);
2582 IV iv = TOPi; /* attempt to convert to IV if possible. */
2583 /* XXX it's arguable that compiler casting to IV might be subtly
2584 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2585 else preferring IV has introduced a subtle behaviour change bug. OTOH
2586 relying on floating point to be accurate is a bug. */
2597 if (value < (NV)UV_MAX + 0.5) {
2600 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2601 (void)Perl_modf(value, &value);
2603 double tmp = (double)value;
2604 (void)Perl_modf(tmp, &tmp);
2610 if (value > (NV)IV_MIN - 0.5) {
2613 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2614 (void)Perl_modf(-value, &value);
2617 double tmp = (double)value;
2618 (void)Perl_modf(-tmp, &tmp);
2631 djSP; dTARGET; tryAMAGICun(abs);
2633 /* This will cache the NV value if string isn't actually integer */
2637 /* IVX is precise */
2639 SETu(TOPu); /* force it to be numeric only */
2647 /* 2s complement assumption. Also, not really needed as
2648 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2671 argtype = 1; /* allow underscores */
2672 XPUSHn(scan_hex(tmps, 99, &argtype));
2685 while (*tmps && isSPACE(*tmps))
2689 argtype = 1; /* allow underscores */
2691 value = scan_hex(++tmps, 99, &argtype);
2692 else if (*tmps == 'b')
2693 value = scan_bin(++tmps, 99, &argtype);
2695 value = scan_oct(tmps, 99, &argtype);
2708 SETi(sv_len_utf8(sv));
2724 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2726 I32 arybase = PL_curcop->cop_arybase;
2729 int num_args = PL_op->op_private & 7;
2731 SvTAINTED_off(TARG); /* decontaminate */
2732 SvUTF8_off(TARG); /* decontaminate */
2736 repl = SvPV(sv, repl_len);
2743 tmps = SvPV(sv, curlen);
2745 utfcurlen = sv_len_utf8(sv);
2746 if (utfcurlen == curlen)
2754 if (pos >= arybase) {
2772 else if (len >= 0) {
2774 if (rem > (I32)curlen)
2789 Perl_croak(aTHX_ "substr outside of string");
2790 if (ckWARN(WARN_SUBSTR))
2791 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2798 sv_pos_u2b(sv, &pos, &rem);
2800 sv_setpvn(TARG, tmps, rem);
2804 sv_insert(sv, pos, rem, repl, repl_len);
2805 else if (lvalue) { /* it's an lvalue! */
2806 if (!SvGMAGICAL(sv)) {
2810 if (ckWARN(WARN_SUBSTR))
2811 Perl_warner(aTHX_ WARN_SUBSTR,
2812 "Attempt to use reference as lvalue in substr");
2814 if (SvOK(sv)) /* is it defined ? */
2815 (void)SvPOK_only_UTF8(sv);
2817 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2820 if (SvTYPE(TARG) < SVt_PVLV) {
2821 sv_upgrade(TARG, SVt_PVLV);
2822 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2826 if (LvTARG(TARG) != sv) {
2828 SvREFCNT_dec(LvTARG(TARG));
2829 LvTARG(TARG) = SvREFCNT_inc(sv);
2831 LvTARGOFF(TARG) = upos;
2832 LvTARGLEN(TARG) = urem;
2836 PUSHs(TARG); /* avoid SvSETMAGIC here */
2843 register IV size = POPi;
2844 register IV offset = POPi;
2845 register SV *src = POPs;
2846 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2848 SvTAINTED_off(TARG); /* decontaminate */
2849 if (lvalue) { /* it's an lvalue! */
2850 if (SvTYPE(TARG) < SVt_PVLV) {
2851 sv_upgrade(TARG, SVt_PVLV);
2852 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2855 if (LvTARG(TARG) != src) {
2857 SvREFCNT_dec(LvTARG(TARG));
2858 LvTARG(TARG) = SvREFCNT_inc(src);
2860 LvTARGOFF(TARG) = offset;
2861 LvTARGLEN(TARG) = size;
2864 sv_setuv(TARG, do_vecget(src, offset, size));
2879 I32 arybase = PL_curcop->cop_arybase;
2884 offset = POPi - arybase;
2887 tmps = SvPV(big, biglen);
2888 if (offset > 0 && DO_UTF8(big))
2889 sv_pos_u2b(big, &offset, 0);
2892 else if (offset > biglen)
2894 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2895 (unsigned char*)tmps + biglen, little, 0)))
2898 retval = tmps2 - tmps;
2899 if (retval > 0 && DO_UTF8(big))
2900 sv_pos_b2u(big, &retval);
2901 PUSHi(retval + arybase);
2916 I32 arybase = PL_curcop->cop_arybase;
2922 tmps2 = SvPV(little, llen);
2923 tmps = SvPV(big, blen);
2927 if (offset > 0 && DO_UTF8(big))
2928 sv_pos_u2b(big, &offset, 0);
2929 offset = offset - arybase + llen;
2933 else if (offset > blen)
2935 if (!(tmps2 = rninstr(tmps, tmps + offset,
2936 tmps2, tmps2 + llen)))
2939 retval = tmps2 - tmps;
2940 if (retval > 0 && DO_UTF8(big))
2941 sv_pos_b2u(big, &retval);
2942 PUSHi(retval + arybase);
2948 djSP; dMARK; dORIGMARK; dTARGET;
2949 do_sprintf(TARG, SP-MARK, MARK+1);
2950 TAINT_IF(SvTAINTED(TARG));
2961 U8 *s = (U8*)SvPVx(argsv, len);
2963 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
2973 (void)SvUPGRADE(TARG,SVt_PV);
2975 if (value > 255 && !IN_BYTE) {
2976 SvGROW(TARG, UNISKIP(value)+1);
2977 tmps = (char*)uv_to_utf8((U8*)SvPVX(TARG), value);
2978 SvCUR_set(TARG, tmps - SvPVX(TARG));
2980 (void)SvPOK_only(TARG);
2991 (void)SvPOK_only(TARG);
2998 djSP; dTARGET; dPOPTOPssrl;
3001 char *tmps = SvPV(left, n_a);
3003 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3005 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3009 "The crypt() function is unimplemented due to excessive paranoia.");
3022 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3024 U8 tmpbuf[UTF8_MAXLEN+1];
3026 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3028 if (PL_op->op_private & OPpLOCALE) {
3031 uv = toTITLE_LC_uni(uv);
3034 uv = toTITLE_utf8(s);
3036 tend = uv_to_utf8(tmpbuf, uv);
3038 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3040 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3041 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3046 s = (U8*)SvPV_force(sv, slen);
3047 Copy(tmpbuf, s, ulen, U8);
3051 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3053 SvUTF8_off(TARG); /* decontaminate */
3058 s = (U8*)SvPV_force(sv, slen);
3060 if (PL_op->op_private & OPpLOCALE) {
3063 *s = toUPPER_LC(*s);
3081 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3083 U8 tmpbuf[UTF8_MAXLEN+1];
3085 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3087 if (PL_op->op_private & OPpLOCALE) {
3090 uv = toLOWER_LC_uni(uv);
3093 uv = toLOWER_utf8(s);
3095 tend = uv_to_utf8(tmpbuf, uv);
3097 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3099 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3100 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3105 s = (U8*)SvPV_force(sv, slen);
3106 Copy(tmpbuf, s, ulen, U8);
3110 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3112 SvUTF8_off(TARG); /* decontaminate */
3117 s = (U8*)SvPV_force(sv, slen);
3119 if (PL_op->op_private & OPpLOCALE) {
3122 *s = toLOWER_LC(*s);
3146 s = (U8*)SvPV(sv,len);
3148 SvUTF8_off(TARG); /* decontaminate */
3149 sv_setpvn(TARG, "", 0);
3153 (void)SvUPGRADE(TARG, SVt_PV);
3154 SvGROW(TARG, (len * 2) + 1);
3155 (void)SvPOK_only(TARG);
3156 d = (U8*)SvPVX(TARG);
3158 if (PL_op->op_private & OPpLOCALE) {
3162 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3168 d = uv_to_utf8(d, toUPPER_utf8( s ));
3174 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3179 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3181 SvUTF8_off(TARG); /* decontaminate */
3186 s = (U8*)SvPV_force(sv, len);
3188 register U8 *send = s + len;
3190 if (PL_op->op_private & OPpLOCALE) {
3193 for (; s < send; s++)
3194 *s = toUPPER_LC(*s);
3197 for (; s < send; s++)
3220 s = (U8*)SvPV(sv,len);
3222 SvUTF8_off(TARG); /* decontaminate */
3223 sv_setpvn(TARG, "", 0);
3227 (void)SvUPGRADE(TARG, SVt_PV);
3228 SvGROW(TARG, (len * 2) + 1);
3229 (void)SvPOK_only(TARG);
3230 d = (U8*)SvPVX(TARG);
3232 if (PL_op->op_private & OPpLOCALE) {
3236 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3242 d = uv_to_utf8(d, toLOWER_utf8(s));
3248 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3253 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3255 SvUTF8_off(TARG); /* decontaminate */
3261 s = (U8*)SvPV_force(sv, len);
3263 register U8 *send = s + len;
3265 if (PL_op->op_private & OPpLOCALE) {
3268 for (; s < send; s++)
3269 *s = toLOWER_LC(*s);
3272 for (; s < send; s++)
3287 register char *s = SvPV(sv,len);
3290 SvUTF8_off(TARG); /* decontaminate */
3292 (void)SvUPGRADE(TARG, SVt_PV);
3293 SvGROW(TARG, (len * 2) + 1);
3297 if (UTF8_IS_CONTINUED(*s)) {
3298 STRLEN ulen = UTF8SKIP(s);
3322 SvCUR_set(TARG, d - SvPVX(TARG));
3323 (void)SvPOK_only_UTF8(TARG);
3326 sv_setpvn(TARG, s, len);
3328 if (SvSMAGICAL(TARG))
3337 djSP; dMARK; dORIGMARK;
3339 register AV* av = (AV*)POPs;
3340 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3341 I32 arybase = PL_curcop->cop_arybase;
3344 if (SvTYPE(av) == SVt_PVAV) {
3345 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3347 for (svp = MARK + 1; svp <= SP; svp++) {
3352 if (max > AvMAX(av))
3355 while (++MARK <= SP) {
3356 elem = SvIVx(*MARK);
3360 svp = av_fetch(av, elem, lval);
3362 if (!svp || *svp == &PL_sv_undef)
3363 DIE(aTHX_ PL_no_aelem, elem);
3364 if (PL_op->op_private & OPpLVAL_INTRO)
3365 save_aelem(av, elem, svp);
3367 *MARK = svp ? *svp : &PL_sv_undef;
3370 if (GIMME != G_ARRAY) {
3378 /* Associative arrays. */
3383 HV *hash = (HV*)POPs;
3385 I32 gimme = GIMME_V;
3386 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3389 /* might clobber stack_sp */
3390 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3395 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3396 if (gimme == G_ARRAY) {
3399 /* might clobber stack_sp */
3401 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3406 else if (gimme == G_SCALAR)
3425 I32 gimme = GIMME_V;
3426 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3430 if (PL_op->op_private & OPpSLICE) {
3434 hvtype = SvTYPE(hv);
3435 if (hvtype == SVt_PVHV) { /* hash element */
3436 while (++MARK <= SP) {
3437 sv = hv_delete_ent(hv, *MARK, discard, 0);
3438 *MARK = sv ? sv : &PL_sv_undef;
3441 else if (hvtype == SVt_PVAV) {
3442 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3443 while (++MARK <= SP) {
3444 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3445 *MARK = sv ? sv : &PL_sv_undef;
3448 else { /* pseudo-hash element */
3449 while (++MARK <= SP) {
3450 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3451 *MARK = sv ? sv : &PL_sv_undef;
3456 DIE(aTHX_ "Not a HASH reference");
3459 else if (gimme == G_SCALAR) {
3468 if (SvTYPE(hv) == SVt_PVHV)
3469 sv = hv_delete_ent(hv, keysv, discard, 0);
3470 else if (SvTYPE(hv) == SVt_PVAV) {
3471 if (PL_op->op_flags & OPf_SPECIAL)
3472 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3474 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3477 DIE(aTHX_ "Not a HASH reference");
3492 if (PL_op->op_private & OPpEXISTS_SUB) {
3496 cv = sv_2cv(sv, &hv, &gv, FALSE);
3499 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3505 if (SvTYPE(hv) == SVt_PVHV) {
3506 if (hv_exists_ent(hv, tmpsv, 0))
3509 else if (SvTYPE(hv) == SVt_PVAV) {
3510 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3511 if (av_exists((AV*)hv, SvIV(tmpsv)))
3514 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3518 DIE(aTHX_ "Not a HASH reference");
3525 djSP; dMARK; dORIGMARK;
3526 register HV *hv = (HV*)POPs;
3527 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3528 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3530 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3531 DIE(aTHX_ "Can't localize pseudo-hash element");
3533 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3534 while (++MARK <= SP) {
3537 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3539 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3540 svp = he ? &HeVAL(he) : 0;
3543 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3546 if (!svp || *svp == &PL_sv_undef) {
3548 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3550 if (PL_op->op_private & OPpLVAL_INTRO) {
3552 save_helem(hv, keysv, svp);
3555 char *key = SvPV(keysv, keylen);
3556 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3560 *MARK = svp ? *svp : &PL_sv_undef;
3563 if (GIMME != G_ARRAY) {
3571 /* List operators. */
3576 if (GIMME != G_ARRAY) {
3578 *MARK = *SP; /* unwanted list, return last item */
3580 *MARK = &PL_sv_undef;
3589 SV **lastrelem = PL_stack_sp;
3590 SV **lastlelem = PL_stack_base + POPMARK;
3591 SV **firstlelem = PL_stack_base + POPMARK + 1;
3592 register SV **firstrelem = lastlelem + 1;
3593 I32 arybase = PL_curcop->cop_arybase;
3594 I32 lval = PL_op->op_flags & OPf_MOD;
3595 I32 is_something_there = lval;
3597 register I32 max = lastrelem - lastlelem;
3598 register SV **lelem;
3601 if (GIMME != G_ARRAY) {
3602 ix = SvIVx(*lastlelem);
3607 if (ix < 0 || ix >= max)
3608 *firstlelem = &PL_sv_undef;
3610 *firstlelem = firstrelem[ix];
3616 SP = firstlelem - 1;
3620 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3626 if (ix < 0 || ix >= max)
3627 *lelem = &PL_sv_undef;
3629 is_something_there = TRUE;
3630 if (!(*lelem = firstrelem[ix]))
3631 *lelem = &PL_sv_undef;
3634 if (is_something_there)
3637 SP = firstlelem - 1;
3643 djSP; dMARK; dORIGMARK;
3644 I32 items = SP - MARK;
3645 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3646 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3653 djSP; dMARK; dORIGMARK;
3654 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3658 SV *val = NEWSV(46, 0);
3660 sv_setsv(val, *++MARK);
3661 else if (ckWARN(WARN_MISC))
3662 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3663 (void)hv_store_ent(hv,key,val,0);
3672 djSP; dMARK; dORIGMARK;
3673 register AV *ary = (AV*)*++MARK;
3677 register I32 offset;
3678 register I32 length;
3685 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3686 *MARK-- = SvTIED_obj((SV*)ary, mg);
3690 call_method("SPLICE",GIMME_V);
3699 offset = i = SvIVx(*MARK);
3701 offset += AvFILLp(ary) + 1;
3703 offset -= PL_curcop->cop_arybase;
3705 DIE(aTHX_ PL_no_aelem, i);
3707 length = SvIVx(*MARK++);
3709 length += AvFILLp(ary) - offset + 1;
3715 length = AvMAX(ary) + 1; /* close enough to infinity */
3719 length = AvMAX(ary) + 1;
3721 if (offset > AvFILLp(ary) + 1)
3722 offset = AvFILLp(ary) + 1;
3723 after = AvFILLp(ary) + 1 - (offset + length);
3724 if (after < 0) { /* not that much array */
3725 length += after; /* offset+length now in array */
3731 /* At this point, MARK .. SP-1 is our new LIST */
3734 diff = newlen - length;
3735 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3738 if (diff < 0) { /* shrinking the area */
3740 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3741 Copy(MARK, tmparyval, newlen, SV*);
3744 MARK = ORIGMARK + 1;
3745 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3746 MEXTEND(MARK, length);
3747 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3749 EXTEND_MORTAL(length);
3750 for (i = length, dst = MARK; i; i--) {
3751 sv_2mortal(*dst); /* free them eventualy */
3758 *MARK = AvARRAY(ary)[offset+length-1];
3761 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3762 SvREFCNT_dec(*dst++); /* free them now */
3765 AvFILLp(ary) += diff;
3767 /* pull up or down? */
3769 if (offset < after) { /* easier to pull up */
3770 if (offset) { /* esp. if nothing to pull */
3771 src = &AvARRAY(ary)[offset-1];
3772 dst = src - diff; /* diff is negative */
3773 for (i = offset; i > 0; i--) /* can't trust Copy */
3777 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3781 if (after) { /* anything to pull down? */
3782 src = AvARRAY(ary) + offset + length;
3783 dst = src + diff; /* diff is negative */
3784 Move(src, dst, after, SV*);
3786 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3787 /* avoid later double free */
3791 dst[--i] = &PL_sv_undef;
3794 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3796 *dst = NEWSV(46, 0);
3797 sv_setsv(*dst++, *src++);
3799 Safefree(tmparyval);
3802 else { /* no, expanding (or same) */
3804 New(452, tmparyval, length, SV*); /* so remember deletion */
3805 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3808 if (diff > 0) { /* expanding */
3810 /* push up or down? */
3812 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3816 Move(src, dst, offset, SV*);
3818 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3820 AvFILLp(ary) += diff;
3823 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3824 av_extend(ary, AvFILLp(ary) + diff);
3825 AvFILLp(ary) += diff;
3828 dst = AvARRAY(ary) + AvFILLp(ary);
3830 for (i = after; i; i--) {
3837 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3838 *dst = NEWSV(46, 0);
3839 sv_setsv(*dst++, *src++);
3841 MARK = ORIGMARK + 1;
3842 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3844 Copy(tmparyval, MARK, length, SV*);
3846 EXTEND_MORTAL(length);
3847 for (i = length, dst = MARK; i; i--) {
3848 sv_2mortal(*dst); /* free them eventualy */
3852 Safefree(tmparyval);
3856 else if (length--) {
3857 *MARK = tmparyval[length];
3860 while (length-- > 0)
3861 SvREFCNT_dec(tmparyval[length]);
3863 Safefree(tmparyval);
3866 *MARK = &PL_sv_undef;
3874 djSP; dMARK; dORIGMARK; dTARGET;
3875 register AV *ary = (AV*)*++MARK;
3876 register SV *sv = &PL_sv_undef;
3879 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3880 *MARK-- = SvTIED_obj((SV*)ary, mg);
3884 call_method("PUSH",G_SCALAR|G_DISCARD);
3889 /* Why no pre-extend of ary here ? */
3890 for (++MARK; MARK <= SP; MARK++) {
3893 sv_setsv(sv, *MARK);
3898 PUSHi( AvFILL(ary) + 1 );
3906 SV *sv = av_pop(av);
3908 (void)sv_2mortal(sv);
3917 SV *sv = av_shift(av);
3922 (void)sv_2mortal(sv);
3929 djSP; dMARK; dORIGMARK; dTARGET;
3930 register AV *ary = (AV*)*++MARK;
3935 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3936 *MARK-- = SvTIED_obj((SV*)ary, mg);
3940 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3945 av_unshift(ary, SP - MARK);
3948 sv_setsv(sv, *++MARK);
3949 (void)av_store(ary, i++, sv);
3953 PUSHi( AvFILL(ary) + 1 );
3963 if (GIMME == G_ARRAY) {
3970 /* safe as long as stack cannot get extended in the above */
3975 register char *down;
3980 SvUTF8_off(TARG); /* decontaminate */
3982 do_join(TARG, &PL_sv_no, MARK, SP);
3984 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3985 up = SvPV_force(TARG, len);
3987 if (DO_UTF8(TARG)) { /* first reverse each character */
3988 U8* s = (U8*)SvPVX(TARG);
3989 U8* send = (U8*)(s + len);
3991 if (UTF8_IS_ASCII(*s)) {
3996 if (!utf8_to_uv_simple(s, 0))
4000 down = (char*)(s - 1);
4001 /* reverse this character */
4011 down = SvPVX(TARG) + len - 1;
4017 (void)SvPOK_only_UTF8(TARG);
4026 S_mul128(pTHX_ SV *sv, U8 m)
4029 char *s = SvPV(sv, len);
4033 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4034 SV *tmpNew = newSVpvn("0000000000", 10);
4036 sv_catsv(tmpNew, sv);
4037 SvREFCNT_dec(sv); /* free old sv */
4042 while (!*t) /* trailing '\0'? */
4045 i = ((*t - '0') << 7) + m;
4046 *(t--) = '0' + (i % 10);
4052 /* Explosives and implosives. */
4054 #if 'I' == 73 && 'J' == 74
4055 /* On an ASCII/ISO kind of system */
4056 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4059 Some other sort of character set - use memchr() so we don't match
4062 #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 register char *s = SvPV(right, rlen);
4076 char *strend = s + rlen;
4078 register char *patend = pat + llen;
4084 /* These must not be in registers: */
4101 register U32 culong;
4105 #ifdef PERL_NATINT_PACK
4106 int natint; /* native integer */
4107 int unatint; /* unsigned native integer */
4110 if (gimme != G_ARRAY) { /* arrange to do first one only */
4112 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4113 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4115 while (isDIGIT(*patend) || *patend == '*')
4121 while (pat < patend) {
4123 datumtype = *pat++ & 0xFF;
4124 #ifdef PERL_NATINT_PACK
4127 if (isSPACE(datumtype))
4129 if (datumtype == '#') {
4130 while (pat < patend && *pat != '\n')
4135 char *natstr = "sSiIlL";
4137 if (strchr(natstr, datumtype)) {
4138 #ifdef PERL_NATINT_PACK
4144 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4149 else if (*pat == '*') {
4150 len = strend - strbeg; /* long enough */
4154 else if (isDIGIT(*pat)) {
4156 while (isDIGIT(*pat)) {
4157 len = (len * 10) + (*pat++ - '0');
4159 DIE(aTHX_ "Repeat count in unpack overflows");
4163 len = (datumtype != '@');
4167 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4168 case ',': /* grandfather in commas but with a warning */
4169 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4170 Perl_warner(aTHX_ WARN_UNPACK,
4171 "Invalid type in unpack: '%c'", (int)datumtype);
4174 if (len == 1 && pat[-1] != '1')
4183 if (len > strend - strbeg)
4184 DIE(aTHX_ "@ outside of string");
4188 if (len > s - strbeg)
4189 DIE(aTHX_ "X outside of string");
4193 if (len > strend - s)
4194 DIE(aTHX_ "x outside of string");
4198 if (start_sp_offset >= SP - PL_stack_base)
4199 DIE(aTHX_ "/ must follow a numeric type");
4202 pat++; /* ignore '*' for compatibility with pack */
4204 DIE(aTHX_ "/ cannot take a count" );
4211 if (len > strend - s)
4214 goto uchar_checksum;
4215 sv = NEWSV(35, len);
4216 sv_setpvn(sv, s, len);
4218 if (datumtype == 'A' || datumtype == 'Z') {
4219 aptr = s; /* borrow register */
4220 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4225 else { /* 'A' strips both nulls and spaces */
4226 s = SvPVX(sv) + len - 1;
4227 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4231 SvCUR_set(sv, s - SvPVX(sv));
4232 s = aptr; /* unborrow register */
4234 XPUSHs(sv_2mortal(sv));
4238 if (star || len > (strend - s) * 8)
4239 len = (strend - s) * 8;
4242 Newz(601, PL_bitcount, 256, char);
4243 for (bits = 1; bits < 256; bits++) {
4244 if (bits & 1) PL_bitcount[bits]++;
4245 if (bits & 2) PL_bitcount[bits]++;
4246 if (bits & 4) PL_bitcount[bits]++;
4247 if (bits & 8) PL_bitcount[bits]++;
4248 if (bits & 16) PL_bitcount[bits]++;
4249 if (bits & 32) PL_bitcount[bits]++;
4250 if (bits & 64) PL_bitcount[bits]++;
4251 if (bits & 128) PL_bitcount[bits]++;
4255 culong += PL_bitcount[*(unsigned char*)s++];
4260 if (datumtype == 'b') {
4262 if (bits & 1) culong++;
4268 if (bits & 128) culong++;
4275 sv = NEWSV(35, len + 1);
4279 if (datumtype == 'b') {
4281 for (len = 0; len < aint; len++) {
4282 if (len & 7) /*SUPPRESS 595*/
4286 *str++ = '0' + (bits & 1);
4291 for (len = 0; len < aint; len++) {
4296 *str++ = '0' + ((bits & 128) != 0);
4300 XPUSHs(sv_2mortal(sv));
4304 if (star || len > (strend - s) * 2)
4305 len = (strend - s) * 2;
4306 sv = NEWSV(35, len + 1);
4310 if (datumtype == 'h') {
4312 for (len = 0; len < aint; len++) {
4317 *str++ = PL_hexdigit[bits & 15];
4322 for (len = 0; len < aint; len++) {
4327 *str++ = PL_hexdigit[(bits >> 4) & 15];
4331 XPUSHs(sv_2mortal(sv));
4334 if (len > strend - s)
4339 if (aint >= 128) /* fake up signed chars */
4349 if (aint >= 128) /* fake up signed chars */
4352 sv_setiv(sv, (IV)aint);
4353 PUSHs(sv_2mortal(sv));
4358 if (len > strend - s)
4373 sv_setiv(sv, (IV)auint);
4374 PUSHs(sv_2mortal(sv));
4379 if (len > strend - s)
4382 while (len-- > 0 && s < strend) {
4384 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4388 cdouble += (NV)auint;
4396 while (len-- > 0 && s < strend) {
4398 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4402 sv_setuv(sv, (UV)auint);
4403 PUSHs(sv_2mortal(sv));
4408 #if SHORTSIZE == SIZE16
4409 along = (strend - s) / SIZE16;
4411 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4416 #if SHORTSIZE != SIZE16
4420 COPYNN(s, &ashort, sizeof(short));
4431 #if SHORTSIZE > SIZE16
4443 #if SHORTSIZE != SIZE16
4447 COPYNN(s, &ashort, sizeof(short));
4450 sv_setiv(sv, (IV)ashort);
4451 PUSHs(sv_2mortal(sv));
4459 #if SHORTSIZE > SIZE16
4465 sv_setiv(sv, (IV)ashort);
4466 PUSHs(sv_2mortal(sv));
4474 #if SHORTSIZE == SIZE16
4475 along = (strend - s) / SIZE16;
4477 unatint = natint && datumtype == 'S';
4478 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4483 #if SHORTSIZE != SIZE16
4485 unsigned short aushort;
4487 COPYNN(s, &aushort, sizeof(unsigned short));
4488 s += sizeof(unsigned short);
4496 COPY16(s, &aushort);
4499 if (datumtype == 'n')
4500 aushort = PerlSock_ntohs(aushort);
4503 if (datumtype == 'v')
4504 aushort = vtohs(aushort);
4513 #if SHORTSIZE != SIZE16
4515 unsigned short aushort;
4517 COPYNN(s, &aushort, sizeof(unsigned short));
4518 s += sizeof(unsigned short);
4520 sv_setiv(sv, (UV)aushort);
4521 PUSHs(sv_2mortal(sv));
4528 COPY16(s, &aushort);
4532 if (datumtype == 'n')
4533 aushort = PerlSock_ntohs(aushort);
4536 if (datumtype == 'v')
4537 aushort = vtohs(aushort);
4539 sv_setiv(sv, (UV)aushort);
4540 PUSHs(sv_2mortal(sv));
4546 along = (strend - s) / sizeof(int);
4551 Copy(s, &aint, 1, int);
4554 cdouble += (NV)aint;
4563 Copy(s, &aint, 1, int);
4567 /* Without the dummy below unpack("i", pack("i",-1))
4568 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4569 * cc with optimization turned on.
4571 * The bug was detected in
4572 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4573 * with optimization (-O4) turned on.
4574 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4575 * does not have this problem even with -O4.
4577 * This bug was reported as DECC_BUGS 1431
4578 * and tracked internally as GEM_BUGS 7775.
4580 * The bug is fixed in
4581 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4582 * UNIX V4.0F support: DEC C V5.9-006 or later
4583 * UNIX V4.0E support: DEC C V5.8-011 or later
4586 * See also few lines later for the same bug.
4589 sv_setiv(sv, (IV)aint) :
4591 sv_setiv(sv, (IV)aint);
4592 PUSHs(sv_2mortal(sv));
4597 along = (strend - s) / sizeof(unsigned int);
4602 Copy(s, &auint, 1, unsigned int);
4603 s += sizeof(unsigned int);
4605 cdouble += (NV)auint;
4614 Copy(s, &auint, 1, unsigned int);
4615 s += sizeof(unsigned int);
4618 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4619 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4620 * See details few lines earlier. */
4622 sv_setuv(sv, (UV)auint) :
4624 sv_setuv(sv, (UV)auint);
4625 PUSHs(sv_2mortal(sv));
4630 #if LONGSIZE == SIZE32
4631 along = (strend - s) / SIZE32;
4633 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4638 #if LONGSIZE != SIZE32
4641 COPYNN(s, &along, sizeof(long));
4644 cdouble += (NV)along;
4653 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4657 #if LONGSIZE > SIZE32
4658 if (along > 2147483647)
4659 along -= 4294967296;
4663 cdouble += (NV)along;
4672 #if LONGSIZE != SIZE32
4675 COPYNN(s, &along, sizeof(long));
4678 sv_setiv(sv, (IV)along);
4679 PUSHs(sv_2mortal(sv));
4686 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4690 #if LONGSIZE > SIZE32
4691 if (along > 2147483647)
4692 along -= 4294967296;
4696 sv_setiv(sv, (IV)along);
4697 PUSHs(sv_2mortal(sv));
4705 #if LONGSIZE == SIZE32
4706 along = (strend - s) / SIZE32;
4708 unatint = natint && datumtype == 'L';
4709 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4714 #if LONGSIZE != SIZE32
4716 unsigned long aulong;
4718 COPYNN(s, &aulong, sizeof(unsigned long));
4719 s += sizeof(unsigned long);
4721 cdouble += (NV)aulong;
4733 if (datumtype == 'N')
4734 aulong = PerlSock_ntohl(aulong);
4737 if (datumtype == 'V')
4738 aulong = vtohl(aulong);
4741 cdouble += (NV)aulong;
4750 #if LONGSIZE != SIZE32
4752 unsigned long aulong;
4754 COPYNN(s, &aulong, sizeof(unsigned long));
4755 s += sizeof(unsigned long);
4757 sv_setuv(sv, (UV)aulong);
4758 PUSHs(sv_2mortal(sv));
4768 if (datumtype == 'N')
4769 aulong = PerlSock_ntohl(aulong);
4772 if (datumtype == 'V')
4773 aulong = vtohl(aulong);
4776 sv_setuv(sv, (UV)aulong);
4777 PUSHs(sv_2mortal(sv));
4783 along = (strend - s) / sizeof(char*);
4789 if (sizeof(char*) > strend - s)
4792 Copy(s, &aptr, 1, char*);
4798 PUSHs(sv_2mortal(sv));
4808 while ((len > 0) && (s < strend)) {
4809 auv = (auv << 7) | (*s & 0x7f);
4810 if (UTF8_IS_ASCII(*s++)) {
4814 PUSHs(sv_2mortal(sv));
4818 else if (++bytes >= sizeof(UV)) { /* promote to string */
4822 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4823 while (s < strend) {
4824 sv = mul128(sv, *s & 0x7f);
4825 if (!(*s++ & 0x80)) {
4834 PUSHs(sv_2mortal(sv));
4839 if ((s >= strend) && bytes)
4840 DIE(aTHX_ "Unterminated compressed integer");
4845 if (sizeof(char*) > strend - s)
4848 Copy(s, &aptr, 1, char*);
4853 sv_setpvn(sv, aptr, len);
4854 PUSHs(sv_2mortal(sv));
4858 along = (strend - s) / sizeof(Quad_t);
4864 if (s + sizeof(Quad_t) > strend)
4867 Copy(s, &aquad, 1, Quad_t);
4868 s += sizeof(Quad_t);
4871 if (aquad >= IV_MIN && aquad <= IV_MAX)
4872 sv_setiv(sv, (IV)aquad);
4874 sv_setnv(sv, (NV)aquad);
4875 PUSHs(sv_2mortal(sv));
4879 along = (strend - s) / sizeof(Quad_t);
4885 if (s + sizeof(Uquad_t) > strend)
4888 Copy(s, &auquad, 1, Uquad_t);
4889 s += sizeof(Uquad_t);
4892 if (auquad <= UV_MAX)
4893 sv_setuv(sv, (UV)auquad);
4895 sv_setnv(sv, (NV)auquad);
4896 PUSHs(sv_2mortal(sv));
4900 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4903 along = (strend - s) / sizeof(float);
4908 Copy(s, &afloat, 1, float);
4917 Copy(s, &afloat, 1, float);
4920 sv_setnv(sv, (NV)afloat);
4921 PUSHs(sv_2mortal(sv));
4927 along = (strend - s) / sizeof(double);
4932 Copy(s, &adouble, 1, double);
4933 s += sizeof(double);
4941 Copy(s, &adouble, 1, double);
4942 s += sizeof(double);
4944 sv_setnv(sv, (NV)adouble);
4945 PUSHs(sv_2mortal(sv));
4951 * Initialise the decode mapping. By using a table driven
4952 * algorithm, the code will be character-set independent
4953 * (and just as fast as doing character arithmetic)
4955 if (PL_uudmap['M'] == 0) {
4958 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4959 PL_uudmap[(U8)PL_uuemap[i]] = i;
4961 * Because ' ' and '`' map to the same value,
4962 * we need to decode them both the same.
4967 along = (strend - s) * 3 / 4;
4968 sv = NEWSV(42, along);
4971 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4976 len = PL_uudmap[*(U8*)s++] & 077;
4978 if (s < strend && ISUUCHAR(*s))
4979 a = PL_uudmap[*(U8*)s++] & 077;
4982 if (s < strend && ISUUCHAR(*s))
4983 b = PL_uudmap[*(U8*)s++] & 077;
4986 if (s < strend && ISUUCHAR(*s))
4987 c = PL_uudmap[*(U8*)s++] & 077;
4990 if (s < strend && ISUUCHAR(*s))
4991 d = PL_uudmap[*(U8*)s++] & 077;
4994 hunk[0] = (a << 2) | (b >> 4);
4995 hunk[1] = (b << 4) | (c >> 2);
4996 hunk[2] = (c << 6) | d;
4997 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5002 else if (s[1] == '\n') /* possible checksum byte */
5005 XPUSHs(sv_2mortal(sv));
5010 if (strchr("fFdD", datumtype) ||
5011 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5015 while (checksum >= 16) {
5019 while (checksum >= 4) {
5025 along = (1 << checksum) - 1;
5026 while (cdouble < 0.0)
5028 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5029 sv_setnv(sv, cdouble);
5032 if (checksum < 32) {
5033 aulong = (1 << checksum) - 1;
5036 sv_setuv(sv, (UV)culong);
5038 XPUSHs(sv_2mortal(sv));
5042 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5043 PUSHs(&PL_sv_undef);
5048 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5052 *hunk = PL_uuemap[len];
5053 sv_catpvn(sv, hunk, 1);
5056 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5057 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5058 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5059 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5060 sv_catpvn(sv, hunk, 4);
5065 char r = (len > 1 ? s[1] : '\0');
5066 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5067 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5068 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5069 hunk[3] = PL_uuemap[0];
5070 sv_catpvn(sv, hunk, 4);
5072 sv_catpvn(sv, "\n", 1);
5076 S_is_an_int(pTHX_ char *s, STRLEN l)
5079 SV *result = newSVpvn(s, l);
5080 char *result_c = SvPV(result, n_a); /* convenience */
5081 char *out = result_c;
5091 SvREFCNT_dec(result);
5114 SvREFCNT_dec(result);
5120 SvCUR_set(result, out - result_c);
5124 /* pnum must be '\0' terminated */
5126 S_div128(pTHX_ SV *pnum, bool *done)
5129 char *s = SvPV(pnum, len);
5138 i = m * 10 + (*t - '0');
5140 r = (i >> 7); /* r < 10 */
5147 SvCUR_set(pnum, (STRLEN) (t - s));
5154 djSP; dMARK; dORIGMARK; dTARGET;
5155 register SV *cat = TARG;
5158 register char *pat = SvPVx(*++MARK, fromlen);
5160 register char *patend = pat + fromlen;
5165 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5166 static char *space10 = " ";
5168 /* These must not be in registers: */
5183 #ifdef PERL_NATINT_PACK
5184 int natint; /* native integer */
5189 sv_setpvn(cat, "", 0);
5191 while (pat < patend) {
5192 SV *lengthcode = Nullsv;
5193 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5194 datumtype = *pat++ & 0xFF;
5195 #ifdef PERL_NATINT_PACK
5198 if (isSPACE(datumtype)) {
5202 if (datumtype == 'U' && pat == patcopy+1)
5204 if (datumtype == '#') {
5205 while (pat < patend && *pat != '\n')
5210 char *natstr = "sSiIlL";
5212 if (strchr(natstr, datumtype)) {
5213 #ifdef PERL_NATINT_PACK
5219 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5222 len = strchr("@Xxu", datumtype) ? 0 : items;
5225 else if (isDIGIT(*pat)) {
5227 while (isDIGIT(*pat)) {
5228 len = (len * 10) + (*pat++ - '0');
5230 DIE(aTHX_ "Repeat count in pack overflows");
5237 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5238 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5239 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5240 ? *MARK : &PL_sv_no)
5241 + (*pat == 'Z' ? 1 : 0)));
5245 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5246 case ',': /* grandfather in commas but with a warning */
5247 if (commas++ == 0 && ckWARN(WARN_PACK))
5248 Perl_warner(aTHX_ WARN_PACK,
5249 "Invalid type in pack: '%c'", (int)datumtype);
5252 DIE(aTHX_ "%% may only be used in unpack");
5263 if (SvCUR(cat) < len)
5264 DIE(aTHX_ "X outside of string");
5271 sv_catpvn(cat, null10, 10);
5274 sv_catpvn(cat, null10, len);
5280 aptr = SvPV(fromstr, fromlen);
5281 if (pat[-1] == '*') {
5283 if (datumtype == 'Z')
5286 if (fromlen >= len) {
5287 sv_catpvn(cat, aptr, len);
5288 if (datumtype == 'Z')
5289 *(SvEND(cat)-1) = '\0';
5292 sv_catpvn(cat, aptr, fromlen);
5294 if (datumtype == 'A') {
5296 sv_catpvn(cat, space10, 10);
5299 sv_catpvn(cat, space10, len);
5303 sv_catpvn(cat, null10, 10);
5306 sv_catpvn(cat, null10, len);
5318 str = SvPV(fromstr, fromlen);
5322 SvCUR(cat) += (len+7)/8;
5323 SvGROW(cat, SvCUR(cat) + 1);
5324 aptr = SvPVX(cat) + aint;
5329 if (datumtype == 'B') {
5330 for (len = 0; len++ < aint;) {
5331 items |= *str++ & 1;
5335 *aptr++ = items & 0xff;
5341 for (len = 0; len++ < aint;) {
5347 *aptr++ = items & 0xff;
5353 if (datumtype == 'B')
5354 items <<= 7 - (aint & 7);
5356 items >>= 7 - (aint & 7);
5357 *aptr++ = items & 0xff;
5359 str = SvPVX(cat) + SvCUR(cat);
5374 str = SvPV(fromstr, fromlen);
5378 SvCUR(cat) += (len+1)/2;
5379 SvGROW(cat, SvCUR(cat) + 1);
5380 aptr = SvPVX(cat) + aint;
5385 if (datumtype == 'H') {
5386 for (len = 0; len++ < aint;) {
5388 items |= ((*str++ & 15) + 9) & 15;
5390 items |= *str++ & 15;
5394 *aptr++ = items & 0xff;
5400 for (len = 0; len++ < aint;) {
5402 items |= (((*str++ & 15) + 9) & 15) << 4;
5404 items |= (*str++ & 15) << 4;
5408 *aptr++ = items & 0xff;
5414 *aptr++ = items & 0xff;
5415 str = SvPVX(cat) + SvCUR(cat);
5426 aint = SvIV(fromstr);
5428 sv_catpvn(cat, &achar, sizeof(char));
5434 auint = SvUV(fromstr);
5435 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5436 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
5441 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5446 afloat = (float)SvNV(fromstr);
5447 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5454 adouble = (double)SvNV(fromstr);
5455 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5461 ashort = (I16)SvIV(fromstr);
5463 ashort = PerlSock_htons(ashort);
5465 CAT16(cat, &ashort);
5471 ashort = (I16)SvIV(fromstr);
5473 ashort = htovs(ashort);
5475 CAT16(cat, &ashort);
5479 #if SHORTSIZE != SIZE16
5481 unsigned short aushort;
5485 aushort = SvUV(fromstr);
5486 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5496 aushort = (U16)SvUV(fromstr);
5497 CAT16(cat, &aushort);
5503 #if SHORTSIZE != SIZE16
5509 ashort = SvIV(fromstr);
5510 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5518 ashort = (I16)SvIV(fromstr);
5519 CAT16(cat, &ashort);
5526 auint = SvUV(fromstr);
5527 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5533 adouble = Perl_floor(SvNV(fromstr));
5536 DIE(aTHX_ "Cannot compress negative numbers");
5539 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5540 adouble <= 0xffffffff
5542 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5543 adouble <= UV_MAX_cxux
5550 char buf[1 + sizeof(UV)];
5551 char *in = buf + sizeof(buf);
5552 UV auv = U_V(adouble);
5555 *--in = (auv & 0x7f) | 0x80;
5558 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5559 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5561 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5562 char *from, *result, *in;
5567 /* Copy string and check for compliance */
5568 from = SvPV(fromstr, len);
5569 if ((norm = is_an_int(from, len)) == NULL)
5570 DIE(aTHX_ "can compress only unsigned integer");
5572 New('w', result, len, char);
5576 *--in = div128(norm, &done) | 0x80;
5577 result[len - 1] &= 0x7F; /* clear continue bit */
5578 sv_catpvn(cat, in, (result + len) - in);
5580 SvREFCNT_dec(norm); /* free norm */
5582 else if (SvNOKp(fromstr)) {
5583 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5584 char *in = buf + sizeof(buf);
5587 double next = floor(adouble / 128);
5588 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5589 if (in <= buf) /* this cannot happen ;-) */
5590 DIE(aTHX_ "Cannot compress integer");
5593 } while (adouble > 0);
5594 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5595 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5598 DIE(aTHX_ "Cannot compress non integer");
5604 aint = SvIV(fromstr);
5605 sv_catpvn(cat, (char*)&aint, sizeof(int));
5611 aulong = SvUV(fromstr);
5613 aulong = PerlSock_htonl(aulong);
5615 CAT32(cat, &aulong);
5621 aulong = SvUV(fromstr);
5623 aulong = htovl(aulong);
5625 CAT32(cat, &aulong);
5629 #if LONGSIZE != SIZE32
5631 unsigned long aulong;
5635 aulong = SvUV(fromstr);
5636 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5644 aulong = SvUV(fromstr);
5645 CAT32(cat, &aulong);
5650 #if LONGSIZE != SIZE32
5656 along = SvIV(fromstr);
5657 sv_catpvn(cat, (char *)&along, sizeof(long));
5665 along = SvIV(fromstr);
5674 auquad = (Uquad_t)SvUV(fromstr);
5675 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5681 aquad = (Quad_t)SvIV(fromstr);
5682 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5687 len = 1; /* assume SV is correct length */
5692 if (fromstr == &PL_sv_undef)
5696 /* XXX better yet, could spirit away the string to
5697 * a safe spot and hang on to it until the result
5698 * of pack() (and all copies of the result) are
5701 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5702 || (SvPADTMP(fromstr)
5703 && !SvREADONLY(fromstr))))
5705 Perl_warner(aTHX_ WARN_PACK,
5706 "Attempt to pack pointer to temporary value");
5708 if (SvPOK(fromstr) || SvNIOK(fromstr))
5709 aptr = SvPV(fromstr,n_a);
5711 aptr = SvPV_force(fromstr,n_a);
5713 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5718 aptr = SvPV(fromstr, fromlen);
5719 SvGROW(cat, fromlen * 4 / 3);
5724 while (fromlen > 0) {
5731 doencodes(cat, aptr, todo);
5750 register IV limit = POPi; /* note, negative is forever */
5753 register char *s = SvPV(sv, len);
5754 bool do_utf8 = DO_UTF8(sv);
5755 char *strend = s + len;
5757 register REGEXP *rx;
5761 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5762 I32 maxiters = slen + 10;
5765 I32 origlimit = limit;
5768 AV *oldstack = PL_curstack;
5769 I32 gimme = GIMME_V;
5770 I32 oldsave = PL_savestack_ix;
5771 I32 make_mortal = 1;
5772 MAGIC *mg = (MAGIC *) NULL;
5775 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5780 DIE(aTHX_ "panic: pp_split");
5781 rx = pm->op_pmregexp;
5783 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5784 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5786 if (pm->op_pmreplroot) {
5788 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5790 ary = GvAVn((GV*)pm->op_pmreplroot);
5793 else if (gimme != G_ARRAY)
5795 ary = (AV*)PL_curpad[0];
5797 ary = GvAVn(PL_defgv);
5798 #endif /* USE_THREADS */
5801 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5807 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5809 XPUSHs(SvTIED_obj((SV*)ary, mg));
5815 for (i = AvFILLp(ary); i >= 0; i--)
5816 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5818 /* temporarily switch stacks */
5819 SWITCHSTACK(PL_curstack, ary);
5823 base = SP - PL_stack_base;
5825 if (pm->op_pmflags & PMf_SKIPWHITE) {
5826 if (pm->op_pmflags & PMf_LOCALE) {
5827 while (isSPACE_LC(*s))
5835 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5836 SAVEINT(PL_multiline);
5837 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5841 limit = maxiters + 2;
5842 if (pm->op_pmflags & PMf_WHITE) {
5845 while (m < strend &&
5846 !((pm->op_pmflags & PMf_LOCALE)
5847 ? isSPACE_LC(*m) : isSPACE(*m)))
5852 dstr = NEWSV(30, m-s);
5853 sv_setpvn(dstr, s, m-s);
5857 (void)SvUTF8_on(dstr);
5861 while (s < strend &&
5862 ((pm->op_pmflags & PMf_LOCALE)
5863 ? isSPACE_LC(*s) : isSPACE(*s)))
5867 else if (strEQ("^", rx->precomp)) {
5870 for (m = s; m < strend && *m != '\n'; m++) ;
5874 dstr = NEWSV(30, m-s);
5875 sv_setpvn(dstr, s, m-s);
5879 (void)SvUTF8_on(dstr);
5884 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5885 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5886 && (rx->reganch & ROPT_CHECK_ALL)
5887 && !(rx->reganch & ROPT_ANCH)) {
5888 int tail = (rx->reganch & RE_INTUIT_TAIL);
5889 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5892 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5894 char c = *SvPV(csv, n_a);
5897 for (m = s; m < strend && *m != c; m++) ;
5900 dstr = NEWSV(30, m-s);
5901 sv_setpvn(dstr, s, m-s);
5905 (void)SvUTF8_on(dstr);
5907 /* The rx->minlen is in characters but we want to step
5908 * s ahead by bytes. */
5910 s = (char*)utf8_hop((U8*)m, len);
5912 s = m + len; /* Fake \n at the end */
5917 while (s < strend && --limit &&
5918 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5919 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5922 dstr = NEWSV(31, m-s);
5923 sv_setpvn(dstr, s, m-s);
5927 (void)SvUTF8_on(dstr);
5929 /* The rx->minlen is in characters but we want to step
5930 * s ahead by bytes. */
5932 s = (char*)utf8_hop((U8*)m, len);
5934 s = m + len; /* Fake \n at the end */
5939 maxiters += slen * rx->nparens;
5940 while (s < strend && --limit
5941 /* && (!rx->check_substr
5942 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5944 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5945 1 /* minend */, sv, NULL, 0))
5947 TAINT_IF(RX_MATCH_TAINTED(rx));
5948 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5953 strend = s + (strend - m);
5955 m = rx->startp[0] + orig;
5956 dstr = NEWSV(32, m-s);
5957 sv_setpvn(dstr, s, m-s);
5961 (void)SvUTF8_on(dstr);
5964 for (i = 1; i <= rx->nparens; i++) {
5965 s = rx->startp[i] + orig;
5966 m = rx->endp[i] + orig;
5968 dstr = NEWSV(33, m-s);
5969 sv_setpvn(dstr, s, m-s);
5972 dstr = NEWSV(33, 0);
5976 (void)SvUTF8_on(dstr);
5980 s = rx->endp[0] + orig;
5984 LEAVE_SCOPE(oldsave);
5985 iters = (SP - PL_stack_base) - base;
5986 if (iters > maxiters)
5987 DIE(aTHX_ "Split loop");
5989 /* keep field after final delim? */
5990 if (s < strend || (iters && origlimit)) {
5991 STRLEN l = strend - s;
5992 dstr = NEWSV(34, l);
5993 sv_setpvn(dstr, s, l);
5997 (void)SvUTF8_on(dstr);
6001 else if (!origlimit) {
6002 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6008 SWITCHSTACK(ary, oldstack);
6009 if (SvSMAGICAL(ary)) {
6014 if (gimme == G_ARRAY) {
6016 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6024 call_method("PUSH",G_SCALAR|G_DISCARD);
6027 if (gimme == G_ARRAY) {
6028 /* EXTEND should not be needed - we just popped them */
6030 for (i=0; i < iters; i++) {
6031 SV **svp = av_fetch(ary, i, FALSE);
6032 PUSHs((svp) ? *svp : &PL_sv_undef);
6039 if (gimme == G_ARRAY)
6042 if (iters || !pm->op_pmreplroot) {
6052 Perl_unlock_condpair(pTHX_ void *svv)
6054 MAGIC *mg = mg_find((SV*)svv, 'm');
6057 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6058 MUTEX_LOCK(MgMUTEXP(mg));
6059 if (MgOWNER(mg) != thr)
6060 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6062 COND_SIGNAL(MgOWNERCONDP(mg));
6063 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6064 PTR2UV(thr), PTR2UV(svv));)
6065 MUTEX_UNLOCK(MgMUTEXP(mg));
6067 #endif /* USE_THREADS */
6076 #endif /* USE_THREADS */
6077 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6078 || SvTYPE(retsv) == SVt_PVCV) {
6079 retsv = refto(retsv);
6090 if (PL_op->op_private & OPpLVAL_INTRO)
6091 PUSHs(*save_threadsv(PL_op->op_targ));
6093 PUSHs(THREADSV(PL_op->op_targ));
6096 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6097 #endif /* USE_THREADS */