3 * Copyright (c) 1991-2000, 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_ARRAY) {
119 I32 maxarg = AvFILL((AV*)TARG) + 1;
121 if (SvMAGICAL(TARG)) {
123 for (i=0; i < maxarg; i++) {
124 SV **svp = av_fetch((AV*)TARG, i, FALSE);
125 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
129 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
134 SV* sv = sv_newmortal();
135 I32 maxarg = AvFILL((AV*)TARG) + 1;
136 sv_setiv(sv, maxarg);
148 if (PL_op->op_private & OPpLVAL_INTRO)
149 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
150 if (PL_op->op_flags & OPf_REF)
153 if (gimme == G_ARRAY) {
156 else if (gimme == G_SCALAR) {
157 SV* sv = sv_newmortal();
158 if (HvFILL((HV*)TARG))
159 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
160 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
170 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
181 tryAMAGICunDEREF(to_gv);
184 if (SvTYPE(sv) == SVt_PVIO) {
185 GV *gv = (GV*) sv_newmortal();
186 gv_init(gv, 0, "", 0, 0);
187 GvIOp(gv) = (IO *)sv;
188 (void)SvREFCNT_inc(sv);
191 else if (SvTYPE(sv) != SVt_PVGV)
192 DIE(aTHX_ "Not a GLOB reference");
195 if (SvTYPE(sv) != SVt_PVGV) {
199 if (SvGMAGICAL(sv)) {
204 if (!SvOK(sv) && sv != &PL_sv_undef) {
205 /* If this is a 'my' scalar and flag is set then vivify
208 if (PL_op->op_private & OPpDEREF) {
211 if (cUNOP->op_targ) {
213 SV *namesv = PL_curpad[cUNOP->op_targ];
214 name = SvPV(namesv, len);
215 gv = (GV*)NEWSV(0,0);
216 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
219 name = CopSTASHPV(PL_curcop);
222 if (SvTYPE(sv) < SVt_RV)
223 sv_upgrade(sv, SVt_RV);
229 if (PL_op->op_flags & OPf_REF ||
230 PL_op->op_private & HINT_STRICT_REFS)
231 DIE(aTHX_ PL_no_usym, "a symbol");
232 if (ckWARN(WARN_UNINITIALIZED))
237 if ((PL_op->op_flags & OPf_SPECIAL) &&
238 !(PL_op->op_flags & OPf_MOD))
240 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
242 && (!is_gv_magical(sym,len,0)
243 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
249 if (PL_op->op_private & HINT_STRICT_REFS)
250 DIE(aTHX_ PL_no_symref, sym, "a symbol");
251 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
255 if (PL_op->op_private & OPpLVAL_INTRO)
256 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
267 tryAMAGICunDEREF(to_sv);
270 switch (SvTYPE(sv)) {
274 DIE(aTHX_ "Not a SCALAR reference");
282 if (SvTYPE(gv) != SVt_PVGV) {
283 if (SvGMAGICAL(sv)) {
289 if (PL_op->op_flags & OPf_REF ||
290 PL_op->op_private & HINT_STRICT_REFS)
291 DIE(aTHX_ PL_no_usym, "a SCALAR");
292 if (ckWARN(WARN_UNINITIALIZED))
297 if ((PL_op->op_flags & OPf_SPECIAL) &&
298 !(PL_op->op_flags & OPf_MOD))
300 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
302 && (!is_gv_magical(sym,len,0)
303 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
309 if (PL_op->op_private & HINT_STRICT_REFS)
310 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
311 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
316 if (PL_op->op_flags & OPf_MOD) {
317 if (PL_op->op_private & OPpLVAL_INTRO)
318 sv = save_scalar((GV*)TOPs);
319 else if (PL_op->op_private & OPpDEREF)
320 vivify_ref(sv, PL_op->op_private & OPpDEREF);
330 SV *sv = AvARYLEN(av);
332 AvARYLEN(av) = sv = NEWSV(0,0);
333 sv_upgrade(sv, SVt_IV);
334 sv_magic(sv, (SV*)av, '#', Nullch, 0);
342 djSP; dTARGET; dPOPss;
344 if (PL_op->op_flags & OPf_MOD) {
345 if (SvTYPE(TARG) < SVt_PVLV) {
346 sv_upgrade(TARG, SVt_PVLV);
347 sv_magic(TARG, Nullsv, '.', Nullch, 0);
351 if (LvTARG(TARG) != sv) {
353 SvREFCNT_dec(LvTARG(TARG));
354 LvTARG(TARG) = SvREFCNT_inc(sv);
356 PUSHs(TARG); /* no SvSETMAGIC */
362 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
363 mg = mg_find(sv, 'g');
364 if (mg && mg->mg_len >= 0) {
368 PUSHi(i + PL_curcop->cop_arybase);
382 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
383 /* (But not in defined().) */
384 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
387 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
388 if ((PL_op->op_private & OPpLVAL_INTRO)) {
389 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
392 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
396 cv = (CV*)&PL_sv_undef;
410 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
411 char *s = SvPVX(TOPs);
412 if (strnEQ(s, "CORE::", 6)) {
415 code = keyword(s + 6, SvCUR(TOPs) - 6);
416 if (code < 0) { /* Overridable. */
417 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
418 int i = 0, n = 0, seen_question = 0;
420 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
422 while (i < MAXO) { /* The slow way. */
423 if (strEQ(s + 6, PL_op_name[i])
424 || strEQ(s + 6, PL_op_desc[i]))
430 goto nonesuch; /* Should not happen... */
432 oa = PL_opargs[i] >> OASHIFT;
434 if (oa & OA_OPTIONAL && !seen_question) {
438 else if (n && str[0] == ';' && seen_question)
439 goto set; /* XXXX system, exec */
440 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
441 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
444 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
445 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
449 ret = sv_2mortal(newSVpvn(str, n - 1));
451 else if (code) /* Non-Overridable */
453 else { /* None such */
455 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
459 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
461 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
470 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
472 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
488 if (GIMME != G_ARRAY) {
492 *MARK = &PL_sv_undef;
493 *MARK = refto(*MARK);
497 EXTEND_MORTAL(SP - MARK);
499 *MARK = refto(*MARK);
504 S_refto(pTHX_ SV *sv)
508 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
511 if (!(sv = LvTARG(sv)))
514 (void)SvREFCNT_inc(sv);
516 else if (SvTYPE(sv) == SVt_PVAV) {
517 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
520 (void)SvREFCNT_inc(sv);
522 else if (SvPADTMP(sv))
526 (void)SvREFCNT_inc(sv);
529 sv_upgrade(rv, SVt_RV);
543 if (sv && SvGMAGICAL(sv))
546 if (!sv || !SvROK(sv))
550 pv = sv_reftype(sv,TRUE);
551 PUSHp(pv, strlen(pv));
561 stash = CopSTASH(PL_curcop);
567 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
568 Perl_croak(aTHX_ "Attempt to bless into a reference");
570 if (ckWARN(WARN_MISC) && len == 0)
571 Perl_warner(aTHX_ WARN_MISC,
572 "Explicit blessing to '' (assuming package main)");
573 stash = gv_stashpvn(ptr, len, TRUE);
576 (void)sv_bless(TOPs, stash);
590 elem = SvPV(sv, n_a);
594 switch (elem ? *elem : '\0')
597 if (strEQ(elem, "ARRAY"))
598 tmpRef = (SV*)GvAV(gv);
601 if (strEQ(elem, "CODE"))
602 tmpRef = (SV*)GvCVu(gv);
605 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
606 tmpRef = (SV*)GvIOp(gv);
608 if (strEQ(elem, "FORMAT"))
609 tmpRef = (SV*)GvFORM(gv);
612 if (strEQ(elem, "GLOB"))
616 if (strEQ(elem, "HASH"))
617 tmpRef = (SV*)GvHV(gv);
620 if (strEQ(elem, "IO"))
621 tmpRef = (SV*)GvIOp(gv);
624 if (strEQ(elem, "NAME"))
625 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
628 if (strEQ(elem, "PACKAGE"))
629 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
632 if (strEQ(elem, "SCALAR"))
646 /* Pattern matching */
651 register unsigned char *s;
654 register I32 *sfirst;
658 if (sv == PL_lastscream) {
664 SvSCREAM_off(PL_lastscream);
665 SvREFCNT_dec(PL_lastscream);
667 PL_lastscream = SvREFCNT_inc(sv);
670 s = (unsigned char*)(SvPV(sv, len));
674 if (pos > PL_maxscream) {
675 if (PL_maxscream < 0) {
676 PL_maxscream = pos + 80;
677 New(301, PL_screamfirst, 256, I32);
678 New(302, PL_screamnext, PL_maxscream, I32);
681 PL_maxscream = pos + pos / 4;
682 Renew(PL_screamnext, PL_maxscream, I32);
686 sfirst = PL_screamfirst;
687 snext = PL_screamnext;
689 if (!sfirst || !snext)
690 DIE(aTHX_ "do_study: out of memory");
692 for (ch = 256; ch; --ch)
699 snext[pos] = sfirst[ch] - pos;
706 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
715 if (PL_op->op_flags & OPf_STACKED)
721 TARG = sv_newmortal();
726 /* Lvalue operators. */
738 djSP; dMARK; dTARGET;
748 SETi(do_chomp(TOPs));
754 djSP; dMARK; dTARGET;
755 register I32 count = 0;
758 count += do_chomp(POPs);
769 if (!sv || !SvANY(sv))
771 switch (SvTYPE(sv)) {
773 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
777 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
781 if (CvROOT(sv) || CvXSUB(sv))
798 if (!PL_op->op_private) {
807 if (SvTHINKFIRST(sv))
810 switch (SvTYPE(sv)) {
820 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
821 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
822 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
826 /* let user-undef'd sub keep its identity */
827 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
834 SvSetMagicSV(sv, &PL_sv_undef);
838 Newz(602, gp, 1, GP);
839 GvGP(sv) = gp_ref(gp);
840 GvSV(sv) = NEWSV(72,0);
841 GvLINE(sv) = CopLINE(PL_curcop);
847 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
850 SvPV_set(sv, Nullch);
863 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
864 DIE(aTHX_ PL_no_modify);
865 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
866 SvIVX(TOPs) != IV_MIN)
869 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
880 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
881 DIE(aTHX_ PL_no_modify);
882 sv_setsv(TARG, TOPs);
883 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
884 SvIVX(TOPs) != IV_MAX)
887 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
901 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
902 DIE(aTHX_ PL_no_modify);
903 sv_setsv(TARG, TOPs);
904 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
905 SvIVX(TOPs) != IV_MIN)
908 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
917 /* Ordinary operators. */
921 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
924 SETn( Perl_pow( left, right) );
931 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
932 #ifdef PERL_PRESERVE_IVUV
935 /* Unless the left argument is integer in range we are going to have to
936 use NV maths. Hence only attempt to coerce the right argument if
937 we know the left is integer. */
938 /* Left operand is defined, so is it IV? */
941 bool auvok = SvUOK(TOPm1s);
942 bool buvok = SvUOK(TOPs);
943 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
944 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
951 alow = SvUVX(TOPm1s);
953 IV aiv = SvIVX(TOPm1s);
956 auvok = TRUE; /* effectively it's a UV now */
958 alow = -aiv; /* abs, auvok == false records sign */
964 IV biv = SvIVX(TOPs);
967 buvok = TRUE; /* effectively it's a UV now */
969 blow = -biv; /* abs, buvok == false records sign */
973 /* If this does sign extension on unsigned it's time for plan B */
974 ahigh = alow >> (4 * sizeof (UV));
976 bhigh = blow >> (4 * sizeof (UV));
978 if (ahigh && bhigh) {
979 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
980 which is overflow. Drop to NVs below. */
981 } else if (!ahigh && !bhigh) {
982 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
983 so the unsigned multiply cannot overflow. */
984 UV product = alow * blow;
985 if (auvok == buvok) {
986 /* -ve * -ve or +ve * +ve gives a +ve result. */
990 } else if (product <= (UV)IV_MIN) {
991 /* 2s complement assumption that (UV)-IV_MIN is correct. */
992 /* -ve result, which could overflow an IV */
996 } /* else drop to NVs below. */
998 /* One operand is large, 1 small */
1001 /* swap the operands */
1003 bhigh = blow; /* bhigh now the temp var for the swap */
1007 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1008 multiplies can't overflow. shift can, add can, -ve can. */
1009 product_middle = ahigh * blow;
1010 if (!(product_middle & topmask)) {
1011 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1013 product_middle <<= (4 * sizeof (UV));
1014 product_low = alow * blow;
1016 /* as for pp_add, UV + something mustn't get smaller.
1017 IIRC ANSI mandates this wrapping *behaviour* for
1018 unsigned whatever the actual representation*/
1019 product_low += product_middle;
1020 if (product_low >= product_middle) {
1021 /* didn't overflow */
1022 if (auvok == buvok) {
1023 /* -ve * -ve or +ve * +ve gives a +ve result. */
1025 SETu( product_low );
1027 } else if (product_low <= (UV)IV_MIN) {
1028 /* 2s complement assumption again */
1029 /* -ve result, which could overflow an IV */
1031 SETi( -product_low );
1033 } /* else drop to NVs below. */
1035 } /* product_middle too large */
1036 } /* ahigh && bhigh */
1037 } /* SvIOK(TOPm1s) */
1042 SETn( left * right );
1049 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1054 DIE(aTHX_ "Illegal division by zero");
1056 /* insure that 20./5. == 4. */
1059 if ((NV)I_V(left) == left &&
1060 (NV)I_V(right) == right &&
1061 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1065 value = left / right;
1069 value = left / right;
1078 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1084 bool use_double = 0;
1088 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1090 right = (right_neg = (i < 0)) ? -i : i;
1095 right_neg = dright < 0;
1100 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1102 left = (left_neg = (i < 0)) ? -i : i;
1110 left_neg = dleft < 0;
1119 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1121 # define CAST_D2UV(d) U_V(d)
1123 # define CAST_D2UV(d) ((UV)(d))
1125 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1126 * or, in other words, precision of UV more than of NV.
1127 * But in fact the approach below turned out to be an
1128 * optimization - floor() may be slow */
1129 if (dright <= UV_MAX && dleft <= UV_MAX) {
1130 right = CAST_D2UV(dright);
1131 left = CAST_D2UV(dleft);
1136 /* Backward-compatibility clause: */
1137 dright = Perl_floor(dright + 0.5);
1138 dleft = Perl_floor(dleft + 0.5);
1141 DIE(aTHX_ "Illegal modulus zero");
1143 dans = Perl_fmod(dleft, dright);
1144 if ((left_neg != right_neg) && dans)
1145 dans = dright - dans;
1148 sv_setnv(TARG, dans);
1155 DIE(aTHX_ "Illegal modulus zero");
1158 if ((left_neg != right_neg) && ans)
1161 /* XXX may warn: unary minus operator applied to unsigned type */
1162 /* could change -foo to be (~foo)+1 instead */
1163 if (ans <= ~((UV)IV_MAX)+1)
1164 sv_setiv(TARG, ~ans+1);
1166 sv_setnv(TARG, -(NV)ans);
1169 sv_setuv(TARG, ans);
1178 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1180 register IV count = POPi;
1181 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1183 I32 items = SP - MARK;
1186 max = items * count;
1195 repeatcpy((char*)(MARK + items), (char*)MARK,
1196 items * sizeof(SV*), count - 1);
1199 else if (count <= 0)
1202 else { /* Note: mark already snarfed by pp_list */
1205 bool isutf = DO_UTF8(tmpstr);
1207 SvSetSV(TARG, tmpstr);
1208 SvPV_force(TARG, len);
1213 SvGROW(TARG, (count * len) + 1);
1214 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1215 SvCUR(TARG) *= count;
1217 *SvEND(TARG) = '\0';
1220 (void)SvPOK_only_UTF8(TARG);
1222 (void)SvPOK_only(TARG);
1231 djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1232 useleft = USE_LEFT(TOPm1s);
1233 #ifdef PERL_PRESERVE_IVUV
1234 /* We must see if we can perform the addition with integers if possible,
1235 as the integer code detects overflow while the NV code doesn't.
1236 If either argument hasn't had a numeric conversion yet attempt to get
1237 the IV. It's important to do this now, rather than just assuming that
1238 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1239 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1240 integer in case the second argument is IV=9223372036854775806
1241 We can (now) rely on sv_2iv to do the right thing, only setting the
1242 public IOK flag if the value in the NV (or PV) slot is truly integer.
1244 A side effect is that this also aggressively prefers integer maths over
1245 fp maths for integer values. */
1248 /* Unless the left argument is integer in range we are going to have to
1249 use NV maths. Hence only attempt to coerce the right argument if
1250 we know the left is integer. */
1252 /* left operand is undef, treat as zero. + 0 is identity. */
1254 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
1255 if (value <= (UV)IV_MIN) {
1256 /* 2s complement assumption. */
1259 } /* else drop through into NVs below */
1266 /* Left operand is defined, so is it IV? */
1267 SvIV_please(TOPm1s);
1268 if (SvIOK(TOPm1s)) {
1269 bool auvok = SvUOK(TOPm1s);
1270 bool buvok = SvUOK(TOPs);
1272 if (!auvok && !buvok) { /* ## IV - IV ## */
1273 IV aiv = SvIVX(TOPm1s);
1274 IV biv = SvIVX(TOPs);
1275 IV result = aiv - biv;
1277 if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
1282 /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
1283 /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
1284 /* -ve - +ve can only overflow too negative. */
1285 /* leaving +ve - -ve, which will go UV */
1286 if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
1287 /* 2s complement assumption for IV_MIN */
1288 UV result = (UV)aiv + (UV)-biv;
1289 /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
1290 overflow UV (2s complement assumption */
1291 assert (result >= (UV) aiv);
1296 /* Overflow, drop through to NVs */
1297 } else if (auvok && buvok) { /* ## UV - UV ## */
1298 UV auv = SvUVX(TOPm1s);
1299 UV buv = SvUVX(TOPs);
1307 /* Blatant 2s complement assumption. */
1308 result = (IV)(auv - buv);
1314 /* Overflow on IV - IV, drop through to NVs */
1315 } else if (auvok) { /* ## Mixed UV - IV ## */
1316 UV auv = SvUVX(TOPm1s);
1317 IV biv = SvIVX(TOPs);
1320 /* 2s complement assumptions for IV_MIN */
1321 UV result = auv + ((UV)-biv);
1322 /* UV + UV can only get bigger... */
1323 if (result >= auv) {
1328 /* and if it gets too big for UV then it's NV time. */
1329 } else if (auv > (UV)IV_MAX) {
1330 /* I think I'm making an implicit 2s complement
1331 assumption that IV_MIN == -IV_MAX - 1 */
1333 UV result = auv - (UV)biv;
1334 assert (result <= auv);
1340 IV result = (IV)auv - biv;
1341 assert (result <= (IV)auv);
1346 } else { /* ## Mixed IV - UV ## */
1347 IV aiv = SvIVX(TOPm1s);
1348 UV buv = SvUVX(TOPs);
1349 IV result = aiv - (IV)buv; /* 2s complement assumption. */
1351 /* result must not get larger. */
1352 if (result <= aiv) {
1356 } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
1365 /* left operand is undef, treat as zero - value */
1369 SETn( TOPn - value );
1376 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1379 if (PL_op->op_private & HINT_INTEGER) {
1393 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1396 if (PL_op->op_private & HINT_INTEGER) {
1410 djSP; tryAMAGICbinSET(lt,0);
1411 #ifdef PERL_PRESERVE_IVUV
1414 SvIV_please(TOPm1s);
1415 if (SvIOK(TOPm1s)) {
1416 bool auvok = SvUOK(TOPm1s);
1417 bool buvok = SvUOK(TOPs);
1419 if (!auvok && !buvok) { /* ## IV < IV ## */
1420 IV aiv = SvIVX(TOPm1s);
1421 IV biv = SvIVX(TOPs);
1424 SETs(boolSV(aiv < biv));
1427 if (auvok && buvok) { /* ## UV < UV ## */
1428 UV auv = SvUVX(TOPm1s);
1429 UV buv = SvUVX(TOPs);
1432 SETs(boolSV(auv < buv));
1435 if (auvok) { /* ## UV < IV ## */
1442 /* As (a) is a UV, it's >=0, so it cannot be < */
1447 if (auv >= (UV) IV_MAX) {
1448 /* As (b) is an IV, it cannot be > IV_MAX */
1452 SETs(boolSV(auv < (UV)biv));
1455 { /* ## IV < UV ## */
1459 aiv = SvIVX(TOPm1s);
1461 /* As (b) is a UV, it's >=0, so it must be < */
1468 if (buv > (UV) IV_MAX) {
1469 /* As (a) is an IV, it cannot be > IV_MAX */
1473 SETs(boolSV((UV)aiv < buv));
1481 SETs(boolSV(TOPn < value));
1488 djSP; tryAMAGICbinSET(gt,0);
1489 #ifdef PERL_PRESERVE_IVUV
1492 SvIV_please(TOPm1s);
1493 if (SvIOK(TOPm1s)) {
1494 bool auvok = SvUOK(TOPm1s);
1495 bool buvok = SvUOK(TOPs);
1497 if (!auvok && !buvok) { /* ## IV > IV ## */
1498 IV aiv = SvIVX(TOPm1s);
1499 IV biv = SvIVX(TOPs);
1502 SETs(boolSV(aiv > biv));
1505 if (auvok && buvok) { /* ## UV > UV ## */
1506 UV auv = SvUVX(TOPm1s);
1507 UV buv = SvUVX(TOPs);
1510 SETs(boolSV(auv > buv));
1513 if (auvok) { /* ## UV > IV ## */
1520 /* As (a) is a UV, it's >=0, so it must be > */
1525 if (auv > (UV) IV_MAX) {
1526 /* As (b) is an IV, it cannot be > IV_MAX */
1530 SETs(boolSV(auv > (UV)biv));
1533 { /* ## IV > UV ## */
1537 aiv = SvIVX(TOPm1s);
1539 /* As (b) is a UV, it's >=0, so it cannot be > */
1546 if (buv >= (UV) IV_MAX) {
1547 /* As (a) is an IV, it cannot be > IV_MAX */
1551 SETs(boolSV((UV)aiv > buv));
1559 SETs(boolSV(TOPn > value));
1566 djSP; tryAMAGICbinSET(le,0);
1567 #ifdef PERL_PRESERVE_IVUV
1570 SvIV_please(TOPm1s);
1571 if (SvIOK(TOPm1s)) {
1572 bool auvok = SvUOK(TOPm1s);
1573 bool buvok = SvUOK(TOPs);
1575 if (!auvok && !buvok) { /* ## IV <= IV ## */
1576 IV aiv = SvIVX(TOPm1s);
1577 IV biv = SvIVX(TOPs);
1580 SETs(boolSV(aiv <= biv));
1583 if (auvok && buvok) { /* ## UV <= UV ## */
1584 UV auv = SvUVX(TOPm1s);
1585 UV buv = SvUVX(TOPs);
1588 SETs(boolSV(auv <= buv));
1591 if (auvok) { /* ## UV <= IV ## */
1598 /* As (a) is a UV, it's >=0, so a cannot be <= */
1603 if (auv > (UV) IV_MAX) {
1604 /* As (b) is an IV, it cannot be > IV_MAX */
1608 SETs(boolSV(auv <= (UV)biv));
1611 { /* ## IV <= UV ## */
1615 aiv = SvIVX(TOPm1s);
1617 /* As (b) is a UV, it's >=0, so a must be <= */
1624 if (buv >= (UV) IV_MAX) {
1625 /* As (a) is an IV, it cannot be > IV_MAX */
1629 SETs(boolSV((UV)aiv <= buv));
1637 SETs(boolSV(TOPn <= value));
1644 djSP; tryAMAGICbinSET(ge,0);
1645 #ifdef PERL_PRESERVE_IVUV
1648 SvIV_please(TOPm1s);
1649 if (SvIOK(TOPm1s)) {
1650 bool auvok = SvUOK(TOPm1s);
1651 bool buvok = SvUOK(TOPs);
1653 if (!auvok && !buvok) { /* ## IV >= IV ## */
1654 IV aiv = SvIVX(TOPm1s);
1655 IV biv = SvIVX(TOPs);
1658 SETs(boolSV(aiv >= biv));
1661 if (auvok && buvok) { /* ## UV >= UV ## */
1662 UV auv = SvUVX(TOPm1s);
1663 UV buv = SvUVX(TOPs);
1666 SETs(boolSV(auv >= buv));
1669 if (auvok) { /* ## UV >= IV ## */
1676 /* As (a) is a UV, it's >=0, so it must be >= */
1681 if (auv >= (UV) IV_MAX) {
1682 /* As (b) is an IV, it cannot be > IV_MAX */
1686 SETs(boolSV(auv >= (UV)biv));
1689 { /* ## IV >= UV ## */
1693 aiv = SvIVX(TOPm1s);
1695 /* As (b) is a UV, it's >=0, so a cannot be >= */
1702 if (buv > (UV) IV_MAX) {
1703 /* As (a) is an IV, it cannot be > IV_MAX */
1707 SETs(boolSV((UV)aiv >= buv));
1715 SETs(boolSV(TOPn >= value));
1722 djSP; tryAMAGICbinSET(ne,0);
1723 #ifdef PERL_PRESERVE_IVUV
1726 SvIV_please(TOPm1s);
1727 if (SvIOK(TOPm1s)) {
1728 bool auvok = SvUOK(TOPm1s);
1729 bool buvok = SvUOK(TOPs);
1731 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1732 IV aiv = SvIVX(TOPm1s);
1733 IV biv = SvIVX(TOPs);
1736 SETs(boolSV(aiv != biv));
1739 if (auvok && buvok) { /* ## UV != UV ## */
1740 UV auv = SvUVX(TOPm1s);
1741 UV buv = SvUVX(TOPs);
1744 SETs(boolSV(auv != buv));
1747 { /* ## Mixed IV,UV ## */
1751 /* != is commutative so swap if needed (save code) */
1753 /* swap. top of stack (b) is the iv */
1757 /* As (a) is a UV, it's >0, so it cannot be == */
1766 /* As (b) is a UV, it's >0, so it cannot be == */
1770 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1772 /* we know iv is >= 0 */
1773 if (uv > (UV) IV_MAX) {
1777 SETs(boolSV((UV)iv != uv));
1785 SETs(boolSV(TOPn != value));
1792 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1793 #ifdef PERL_PRESERVE_IVUV
1794 /* Fortunately it seems NaN isn't IOK */
1797 SvIV_please(TOPm1s);
1798 if (SvIOK(TOPm1s)) {
1799 bool leftuvok = SvUOK(TOPm1s);
1800 bool rightuvok = SvUOK(TOPs);
1802 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1803 IV leftiv = SvIVX(TOPm1s);
1804 IV rightiv = SvIVX(TOPs);
1806 if (leftiv > rightiv)
1808 else if (leftiv < rightiv)
1812 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1813 UV leftuv = SvUVX(TOPm1s);
1814 UV rightuv = SvUVX(TOPs);
1816 if (leftuv > rightuv)
1818 else if (leftuv < rightuv)
1822 } else if (leftuvok) { /* ## UV <=> IV ## */
1826 rightiv = SvIVX(TOPs);
1828 /* As (a) is a UV, it's >=0, so it cannot be < */
1831 leftuv = SvUVX(TOPm1s);
1832 if (leftuv > (UV) IV_MAX) {
1833 /* As (b) is an IV, it cannot be > IV_MAX */
1835 } else if (leftuv > (UV)rightiv) {
1837 } else if (leftuv < (UV)rightiv) {
1843 } else { /* ## IV <=> UV ## */
1847 leftiv = SvIVX(TOPm1s);
1849 /* As (b) is a UV, it's >=0, so it must be < */
1852 rightuv = SvUVX(TOPs);
1853 if (rightuv > (UV) IV_MAX) {
1854 /* As (a) is an IV, it cannot be > IV_MAX */
1856 } else if (leftiv > (UV)rightuv) {
1858 } else if (leftiv < (UV)rightuv) {
1876 if (Perl_isnan(left) || Perl_isnan(right)) {
1880 value = (left > right) - (left < right);
1884 else if (left < right)
1886 else if (left > right)
1900 djSP; tryAMAGICbinSET(slt,0);
1903 int cmp = ((PL_op->op_private & OPpLOCALE)
1904 ? sv_cmp_locale(left, right)
1905 : sv_cmp(left, right));
1906 SETs(boolSV(cmp < 0));
1913 djSP; tryAMAGICbinSET(sgt,0);
1916 int cmp = ((PL_op->op_private & OPpLOCALE)
1917 ? sv_cmp_locale(left, right)
1918 : sv_cmp(left, right));
1919 SETs(boolSV(cmp > 0));
1926 djSP; tryAMAGICbinSET(sle,0);
1929 int cmp = ((PL_op->op_private & OPpLOCALE)
1930 ? sv_cmp_locale(left, right)
1931 : sv_cmp(left, right));
1932 SETs(boolSV(cmp <= 0));
1939 djSP; tryAMAGICbinSET(sge,0);
1942 int cmp = ((PL_op->op_private & OPpLOCALE)
1943 ? sv_cmp_locale(left, right)
1944 : sv_cmp(left, right));
1945 SETs(boolSV(cmp >= 0));
1952 djSP; tryAMAGICbinSET(seq,0);
1955 SETs(boolSV(sv_eq(left, right)));
1962 djSP; tryAMAGICbinSET(sne,0);
1965 SETs(boolSV(!sv_eq(left, right)));
1972 djSP; dTARGET; tryAMAGICbin(scmp,0);
1975 int cmp = ((PL_op->op_private & OPpLOCALE)
1976 ? sv_cmp_locale(left, right)
1977 : sv_cmp(left, right));
1985 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1988 if (SvNIOKp(left) || SvNIOKp(right)) {
1989 if (PL_op->op_private & HINT_INTEGER) {
1990 IV i = SvIV(left) & SvIV(right);
1994 UV u = SvUV(left) & SvUV(right);
1999 do_vop(PL_op->op_type, TARG, left, right);
2008 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2011 if (SvNIOKp(left) || SvNIOKp(right)) {
2012 if (PL_op->op_private & HINT_INTEGER) {
2013 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2017 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2022 do_vop(PL_op->op_type, TARG, left, right);
2031 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2034 if (SvNIOKp(left) || SvNIOKp(right)) {
2035 if (PL_op->op_private & HINT_INTEGER) {
2036 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2040 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2045 do_vop(PL_op->op_type, TARG, left, right);
2054 djSP; dTARGET; tryAMAGICun(neg);
2057 int flags = SvFLAGS(sv);
2060 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2061 /* It's publicly an integer, or privately an integer-not-float */
2064 if (SvIVX(sv) == IV_MIN) {
2065 /* 2s complement assumption. */
2066 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2069 else if (SvUVX(sv) <= IV_MAX) {
2074 else if (SvIVX(sv) != IV_MIN) {
2078 #ifdef PERL_PRESERVE_IVUV
2087 else if (SvPOKp(sv)) {
2089 char *s = SvPV(sv, len);
2090 if (isIDFIRST(*s)) {
2091 sv_setpvn(TARG, "-", 1);
2094 else if (*s == '+' || *s == '-') {
2096 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2098 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
2099 sv_setpvn(TARG, "-", 1);
2105 goto oops_its_an_int;
2106 sv_setnv(TARG, -SvNV(sv));
2118 djSP; tryAMAGICunSET(not);
2119 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2125 djSP; dTARGET; tryAMAGICun(compl);
2129 if (PL_op->op_private & HINT_INTEGER) {
2144 tmps = (U8*)SvPV_force(TARG, len);
2147 /* Calculate exact length, let's not estimate. */
2156 while (tmps < send) {
2157 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2158 tmps += UTF8SKIP(tmps);
2159 targlen += UNISKIP(~c);
2165 /* Now rewind strings and write them. */
2169 Newz(0, result, targlen + 1, U8);
2170 while (tmps < send) {
2171 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2172 tmps += UTF8SKIP(tmps);
2173 result = uv_to_utf8(result, ~c);
2177 sv_setpvn(TARG, (char*)result, targlen);
2181 Newz(0, result, nchar + 1, U8);
2182 while (tmps < send) {
2183 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
2184 tmps += UTF8SKIP(tmps);
2189 sv_setpvn(TARG, (char*)result, nchar);
2197 register long *tmpl;
2198 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2201 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2206 for ( ; anum > 0; anum--, tmps++)
2215 /* integer versions of some of the above */
2219 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2222 SETi( left * right );
2229 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2233 DIE(aTHX_ "Illegal division by zero");
2234 value = POPi / value;
2242 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2246 DIE(aTHX_ "Illegal modulus zero");
2247 SETi( left % right );
2254 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2257 SETi( left + right );
2264 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2267 SETi( left - right );
2274 djSP; tryAMAGICbinSET(lt,0);
2277 SETs(boolSV(left < right));
2284 djSP; tryAMAGICbinSET(gt,0);
2287 SETs(boolSV(left > right));
2294 djSP; tryAMAGICbinSET(le,0);
2297 SETs(boolSV(left <= right));
2304 djSP; tryAMAGICbinSET(ge,0);
2307 SETs(boolSV(left >= right));
2314 djSP; tryAMAGICbinSET(eq,0);
2317 SETs(boolSV(left == right));
2324 djSP; tryAMAGICbinSET(ne,0);
2327 SETs(boolSV(left != right));
2334 djSP; dTARGET; tryAMAGICbin(ncmp,0);
2341 else if (left < right)
2352 djSP; dTARGET; tryAMAGICun(neg);
2357 /* High falutin' math. */
2361 djSP; dTARGET; tryAMAGICbin(atan2,0);
2364 SETn(Perl_atan2(left, right));
2371 djSP; dTARGET; tryAMAGICun(sin);
2375 value = Perl_sin(value);
2383 djSP; dTARGET; tryAMAGICun(cos);
2387 value = Perl_cos(value);
2393 /* Support Configure command-line overrides for rand() functions.
2394 After 5.005, perhaps we should replace this by Configure support
2395 for drand48(), random(), or rand(). For 5.005, though, maintain
2396 compatibility by calling rand() but allow the user to override it.
2397 See INSTALL for details. --Andy Dougherty 15 July 1998
2399 /* Now it's after 5.005, and Configure supports drand48() and random(),
2400 in addition to rand(). So the overrides should not be needed any more.
2401 --Jarkko Hietaniemi 27 September 1998
2404 #ifndef HAS_DRAND48_PROTO
2405 extern double drand48 (void);
2418 if (!PL_srand_called) {
2419 (void)seedDrand01((Rand_seed_t)seed());
2420 PL_srand_called = TRUE;
2435 (void)seedDrand01((Rand_seed_t)anum);
2436 PL_srand_called = TRUE;
2445 * This is really just a quick hack which grabs various garbage
2446 * values. It really should be a real hash algorithm which
2447 * spreads the effect of every input bit onto every output bit,
2448 * if someone who knows about such things would bother to write it.
2449 * Might be a good idea to add that function to CORE as well.
2450 * No numbers below come from careful analysis or anything here,
2451 * except they are primes and SEED_C1 > 1E6 to get a full-width
2452 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2453 * probably be bigger too.
2456 # define SEED_C1 1000003
2457 #define SEED_C4 73819
2459 # define SEED_C1 25747
2460 #define SEED_C4 20639
2464 #define SEED_C5 26107
2466 #ifndef PERL_NO_DEV_RANDOM
2471 # include <starlet.h>
2472 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2473 * in 100-ns units, typically incremented ever 10 ms. */
2474 unsigned int when[2];
2476 # ifdef HAS_GETTIMEOFDAY
2477 struct timeval when;
2483 /* This test is an escape hatch, this symbol isn't set by Configure. */
2484 #ifndef PERL_NO_DEV_RANDOM
2485 #ifndef PERL_RANDOM_DEVICE
2486 /* /dev/random isn't used by default because reads from it will block
2487 * if there isn't enough entropy available. You can compile with
2488 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2489 * is enough real entropy to fill the seed. */
2490 # define PERL_RANDOM_DEVICE "/dev/urandom"
2492 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2494 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2503 _ckvmssts(sys$gettim(when));
2504 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2506 # ifdef HAS_GETTIMEOFDAY
2507 gettimeofday(&when,(struct timezone *) 0);
2508 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2511 u = (U32)SEED_C1 * when;
2514 u += SEED_C3 * (U32)PerlProc_getpid();
2515 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2516 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2517 u += SEED_C5 * (U32)PTR2UV(&when);
2524 djSP; dTARGET; tryAMAGICun(exp);
2528 value = Perl_exp(value);
2536 djSP; dTARGET; tryAMAGICun(log);
2541 SET_NUMERIC_STANDARD();
2542 DIE(aTHX_ "Can't take log of %g", value);
2544 value = Perl_log(value);
2552 djSP; dTARGET; tryAMAGICun(sqrt);
2557 SET_NUMERIC_STANDARD();
2558 DIE(aTHX_ "Can't take sqrt of %g", value);
2560 value = Perl_sqrt(value);
2571 IV iv = TOPi; /* attempt to convert to IV if possible. */
2572 /* XXX it's arguable that compiler casting to IV might be subtly
2573 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2574 else preferring IV has introduced a subtle behaviour change bug. OTOH
2575 relying on floating point to be accurate is a bug. */
2586 if (value < (NV)UV_MAX + 0.5) {
2589 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2590 (void)Perl_modf(value, &value);
2592 double tmp = (double)value;
2593 (void)Perl_modf(tmp, &tmp);
2599 if (value > (NV)IV_MIN - 0.5) {
2602 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2603 (void)Perl_modf(-value, &value);
2606 double tmp = (double)value;
2607 (void)Perl_modf(-tmp, &tmp);
2620 djSP; dTARGET; tryAMAGICun(abs);
2622 /* This will cache the NV value if string isn't actually integer */
2626 /* IVX is precise */
2628 SETu(TOPu); /* force it to be numeric only */
2636 /* 2s complement assumption. Also, not really needed as
2637 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2660 argtype = 1; /* allow underscores */
2661 XPUSHn(scan_hex(tmps, 99, &argtype));
2674 while (*tmps && isSPACE(*tmps))
2678 argtype = 1; /* allow underscores */
2680 value = scan_hex(++tmps, 99, &argtype);
2681 else if (*tmps == 'b')
2682 value = scan_bin(++tmps, 99, &argtype);
2684 value = scan_oct(tmps, 99, &argtype);
2697 SETi(sv_len_utf8(sv));
2713 I32 lvalue = PL_op->op_flags & OPf_MOD;
2715 I32 arybase = PL_curcop->cop_arybase;
2719 SvTAINTED_off(TARG); /* decontaminate */
2720 SvUTF8_off(TARG); /* decontaminate */
2724 repl = SvPV(sv, repl_len);
2731 tmps = SvPV(sv, curlen);
2733 utfcurlen = sv_len_utf8(sv);
2734 if (utfcurlen == curlen)
2742 if (pos >= arybase) {
2760 else if (len >= 0) {
2762 if (rem > (I32)curlen)
2777 Perl_croak(aTHX_ "substr outside of string");
2778 if (ckWARN(WARN_SUBSTR))
2779 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2784 sv_pos_u2b(sv, &pos, &rem);
2786 sv_setpvn(TARG, tmps, rem);
2790 sv_insert(sv, pos, rem, repl, repl_len);
2791 else if (lvalue) { /* it's an lvalue! */
2792 if (!SvGMAGICAL(sv)) {
2796 if (ckWARN(WARN_SUBSTR))
2797 Perl_warner(aTHX_ WARN_SUBSTR,
2798 "Attempt to use reference as lvalue in substr");
2800 if (SvOK(sv)) /* is it defined ? */
2801 (void)SvPOK_only_UTF8(sv);
2803 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2806 if (SvTYPE(TARG) < SVt_PVLV) {
2807 sv_upgrade(TARG, SVt_PVLV);
2808 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2812 if (LvTARG(TARG) != sv) {
2814 SvREFCNT_dec(LvTARG(TARG));
2815 LvTARG(TARG) = SvREFCNT_inc(sv);
2817 LvTARGOFF(TARG) = pos;
2818 LvTARGLEN(TARG) = rem;
2822 PUSHs(TARG); /* avoid SvSETMAGIC here */
2829 register IV size = POPi;
2830 register IV offset = POPi;
2831 register SV *src = POPs;
2832 I32 lvalue = PL_op->op_flags & OPf_MOD;
2834 SvTAINTED_off(TARG); /* decontaminate */
2835 if (lvalue) { /* it's an lvalue! */
2836 if (SvTYPE(TARG) < SVt_PVLV) {
2837 sv_upgrade(TARG, SVt_PVLV);
2838 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2841 if (LvTARG(TARG) != src) {
2843 SvREFCNT_dec(LvTARG(TARG));
2844 LvTARG(TARG) = SvREFCNT_inc(src);
2846 LvTARGOFF(TARG) = offset;
2847 LvTARGLEN(TARG) = size;
2850 sv_setuv(TARG, do_vecget(src, offset, size));
2865 I32 arybase = PL_curcop->cop_arybase;
2870 offset = POPi - arybase;
2873 tmps = SvPV(big, biglen);
2874 if (offset > 0 && DO_UTF8(big))
2875 sv_pos_u2b(big, &offset, 0);
2878 else if (offset > biglen)
2880 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2881 (unsigned char*)tmps + biglen, little, 0)))
2884 retval = tmps2 - tmps;
2885 if (retval > 0 && DO_UTF8(big))
2886 sv_pos_b2u(big, &retval);
2887 PUSHi(retval + arybase);
2902 I32 arybase = PL_curcop->cop_arybase;
2908 tmps2 = SvPV(little, llen);
2909 tmps = SvPV(big, blen);
2913 if (offset > 0 && DO_UTF8(big))
2914 sv_pos_u2b(big, &offset, 0);
2915 offset = offset - arybase + llen;
2919 else if (offset > blen)
2921 if (!(tmps2 = rninstr(tmps, tmps + offset,
2922 tmps2, tmps2 + llen)))
2925 retval = tmps2 - tmps;
2926 if (retval > 0 && DO_UTF8(big))
2927 sv_pos_b2u(big, &retval);
2928 PUSHi(retval + arybase);
2934 djSP; dMARK; dORIGMARK; dTARGET;
2935 do_sprintf(TARG, SP-MARK, MARK+1);
2936 TAINT_IF(SvTAINTED(TARG));
2947 U8 *s = (U8*)SvPVx(argsv, len);
2949 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
2959 (void)SvUPGRADE(TARG,SVt_PV);
2961 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2962 SvGROW(TARG, UTF8_MAXLEN+1);
2964 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2965 SvCUR_set(TARG, tmps - SvPVX(TARG));
2967 (void)SvPOK_only(TARG);
2978 (void)SvPOK_only(TARG);
2985 djSP; dTARGET; dPOPTOPssrl;
2988 char *tmps = SvPV(left, n_a);
2990 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2992 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2996 "The crypt() function is unimplemented due to excessive paranoia.");
3009 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
3011 U8 tmpbuf[UTF8_MAXLEN+1];
3013 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3015 if (PL_op->op_private & OPpLOCALE) {
3018 uv = toTITLE_LC_uni(uv);
3021 uv = toTITLE_utf8(s);
3023 tend = uv_to_utf8(tmpbuf, uv);
3025 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3027 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3028 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3033 s = (U8*)SvPV_force(sv, slen);
3034 Copy(tmpbuf, s, ulen, U8);
3038 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3040 SvUTF8_off(TARG); /* decontaminate */
3045 s = (U8*)SvPV_force(sv, slen);
3047 if (PL_op->op_private & OPpLOCALE) {
3050 *s = toUPPER_LC(*s);
3068 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
3070 U8 tmpbuf[UTF8_MAXLEN+1];
3072 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3074 if (PL_op->op_private & OPpLOCALE) {
3077 uv = toLOWER_LC_uni(uv);
3080 uv = toLOWER_utf8(s);
3082 tend = uv_to_utf8(tmpbuf, uv);
3084 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3086 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3087 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3092 s = (U8*)SvPV_force(sv, slen);
3093 Copy(tmpbuf, s, ulen, U8);
3097 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3099 SvUTF8_off(TARG); /* decontaminate */
3104 s = (U8*)SvPV_force(sv, slen);
3106 if (PL_op->op_private & OPpLOCALE) {
3109 *s = toLOWER_LC(*s);
3133 s = (U8*)SvPV(sv,len);
3135 SvUTF8_off(TARG); /* decontaminate */
3136 sv_setpvn(TARG, "", 0);
3140 (void)SvUPGRADE(TARG, SVt_PV);
3141 SvGROW(TARG, (len * 2) + 1);
3142 (void)SvPOK_only(TARG);
3143 d = (U8*)SvPVX(TARG);
3145 if (PL_op->op_private & OPpLOCALE) {
3149 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3155 d = uv_to_utf8(d, toUPPER_utf8( s ));
3161 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3166 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3168 SvUTF8_off(TARG); /* decontaminate */
3173 s = (U8*)SvPV_force(sv, len);
3175 register U8 *send = s + len;
3177 if (PL_op->op_private & OPpLOCALE) {
3180 for (; s < send; s++)
3181 *s = toUPPER_LC(*s);
3184 for (; s < send; s++)
3207 s = (U8*)SvPV(sv,len);
3209 SvUTF8_off(TARG); /* decontaminate */
3210 sv_setpvn(TARG, "", 0);
3214 (void)SvUPGRADE(TARG, SVt_PV);
3215 SvGROW(TARG, (len * 2) + 1);
3216 (void)SvPOK_only(TARG);
3217 d = (U8*)SvPVX(TARG);
3219 if (PL_op->op_private & OPpLOCALE) {
3223 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3229 d = uv_to_utf8(d, toLOWER_utf8(s));
3235 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3240 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3242 SvUTF8_off(TARG); /* decontaminate */
3248 s = (U8*)SvPV_force(sv, len);
3250 register U8 *send = s + len;
3252 if (PL_op->op_private & OPpLOCALE) {
3255 for (; s < send; s++)
3256 *s = toLOWER_LC(*s);
3259 for (; s < send; s++)
3274 register char *s = SvPV(sv,len);
3277 SvUTF8_off(TARG); /* decontaminate */
3279 (void)SvUPGRADE(TARG, SVt_PV);
3280 SvGROW(TARG, (len * 2) + 1);
3285 STRLEN ulen = UTF8SKIP(s);
3309 SvCUR_set(TARG, d - SvPVX(TARG));
3310 (void)SvPOK_only_UTF8(TARG);
3313 sv_setpvn(TARG, s, len);
3315 if (SvSMAGICAL(TARG))
3324 djSP; dMARK; dORIGMARK;
3326 register AV* av = (AV*)POPs;
3327 register I32 lval = PL_op->op_flags & OPf_MOD;
3328 I32 arybase = PL_curcop->cop_arybase;
3331 if (SvTYPE(av) == SVt_PVAV) {
3332 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3334 for (svp = MARK + 1; svp <= SP; svp++) {
3339 if (max > AvMAX(av))
3342 while (++MARK <= SP) {
3343 elem = SvIVx(*MARK);
3347 svp = av_fetch(av, elem, lval);
3349 if (!svp || *svp == &PL_sv_undef)
3350 DIE(aTHX_ PL_no_aelem, elem);
3351 if (PL_op->op_private & OPpLVAL_INTRO)
3352 save_aelem(av, elem, svp);
3354 *MARK = svp ? *svp : &PL_sv_undef;
3357 if (GIMME != G_ARRAY) {
3365 /* Associative arrays. */
3370 HV *hash = (HV*)POPs;
3372 I32 gimme = GIMME_V;
3373 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3376 /* might clobber stack_sp */
3377 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3382 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3383 if (gimme == G_ARRAY) {
3386 /* might clobber stack_sp */
3388 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3393 else if (gimme == G_SCALAR)
3412 I32 gimme = GIMME_V;
3413 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3417 if (PL_op->op_private & OPpSLICE) {
3421 hvtype = SvTYPE(hv);
3422 if (hvtype == SVt_PVHV) { /* hash element */
3423 while (++MARK <= SP) {
3424 sv = hv_delete_ent(hv, *MARK, discard, 0);
3425 *MARK = sv ? sv : &PL_sv_undef;
3428 else if (hvtype == SVt_PVAV) {
3429 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3430 while (++MARK <= SP) {
3431 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3432 *MARK = sv ? sv : &PL_sv_undef;
3435 else { /* pseudo-hash element */
3436 while (++MARK <= SP) {
3437 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3438 *MARK = sv ? sv : &PL_sv_undef;
3443 DIE(aTHX_ "Not a HASH reference");
3446 else if (gimme == G_SCALAR) {
3455 if (SvTYPE(hv) == SVt_PVHV)
3456 sv = hv_delete_ent(hv, keysv, discard, 0);
3457 else if (SvTYPE(hv) == SVt_PVAV) {
3458 if (PL_op->op_flags & OPf_SPECIAL)
3459 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3461 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3464 DIE(aTHX_ "Not a HASH reference");
3479 if (PL_op->op_private & OPpEXISTS_SUB) {
3483 cv = sv_2cv(sv, &hv, &gv, FALSE);
3486 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3492 if (SvTYPE(hv) == SVt_PVHV) {
3493 if (hv_exists_ent(hv, tmpsv, 0))
3496 else if (SvTYPE(hv) == SVt_PVAV) {
3497 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3498 if (av_exists((AV*)hv, SvIV(tmpsv)))
3501 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3505 DIE(aTHX_ "Not a HASH reference");
3512 djSP; dMARK; dORIGMARK;
3513 register HV *hv = (HV*)POPs;
3514 register I32 lval = PL_op->op_flags & OPf_MOD;
3515 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3517 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3518 DIE(aTHX_ "Can't localize pseudo-hash element");
3520 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3521 while (++MARK <= SP) {
3524 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3526 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3527 svp = he ? &HeVAL(he) : 0;
3530 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3533 if (!svp || *svp == &PL_sv_undef) {
3535 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3537 if (PL_op->op_private & OPpLVAL_INTRO) {
3539 save_helem(hv, keysv, svp);
3542 char *key = SvPV(keysv, keylen);
3543 save_delete(hv, key, keylen);
3547 *MARK = svp ? *svp : &PL_sv_undef;
3550 if (GIMME != G_ARRAY) {
3558 /* List operators. */
3563 if (GIMME != G_ARRAY) {
3565 *MARK = *SP; /* unwanted list, return last item */
3567 *MARK = &PL_sv_undef;
3576 SV **lastrelem = PL_stack_sp;
3577 SV **lastlelem = PL_stack_base + POPMARK;
3578 SV **firstlelem = PL_stack_base + POPMARK + 1;
3579 register SV **firstrelem = lastlelem + 1;
3580 I32 arybase = PL_curcop->cop_arybase;
3581 I32 lval = PL_op->op_flags & OPf_MOD;
3582 I32 is_something_there = lval;
3584 register I32 max = lastrelem - lastlelem;
3585 register SV **lelem;
3588 if (GIMME != G_ARRAY) {
3589 ix = SvIVx(*lastlelem);
3594 if (ix < 0 || ix >= max)
3595 *firstlelem = &PL_sv_undef;
3597 *firstlelem = firstrelem[ix];
3603 SP = firstlelem - 1;
3607 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3613 if (ix < 0 || ix >= max)
3614 *lelem = &PL_sv_undef;
3616 is_something_there = TRUE;
3617 if (!(*lelem = firstrelem[ix]))
3618 *lelem = &PL_sv_undef;
3621 if (is_something_there)
3624 SP = firstlelem - 1;
3630 djSP; dMARK; dORIGMARK;
3631 I32 items = SP - MARK;
3632 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3633 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3640 djSP; dMARK; dORIGMARK;
3641 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3645 SV *val = NEWSV(46, 0);
3647 sv_setsv(val, *++MARK);
3648 else if (ckWARN(WARN_MISC))
3649 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3650 (void)hv_store_ent(hv,key,val,0);
3659 djSP; dMARK; dORIGMARK;
3660 register AV *ary = (AV*)*++MARK;
3664 register I32 offset;
3665 register I32 length;
3672 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3673 *MARK-- = SvTIED_obj((SV*)ary, mg);
3677 call_method("SPLICE",GIMME_V);
3686 offset = i = SvIVx(*MARK);
3688 offset += AvFILLp(ary) + 1;
3690 offset -= PL_curcop->cop_arybase;
3692 DIE(aTHX_ PL_no_aelem, i);
3694 length = SvIVx(*MARK++);
3696 length += AvFILLp(ary) - offset + 1;
3702 length = AvMAX(ary) + 1; /* close enough to infinity */
3706 length = AvMAX(ary) + 1;
3708 if (offset > AvFILLp(ary) + 1)
3709 offset = AvFILLp(ary) + 1;
3710 after = AvFILLp(ary) + 1 - (offset + length);
3711 if (after < 0) { /* not that much array */
3712 length += after; /* offset+length now in array */
3718 /* At this point, MARK .. SP-1 is our new LIST */
3721 diff = newlen - length;
3722 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3725 if (diff < 0) { /* shrinking the area */
3727 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3728 Copy(MARK, tmparyval, newlen, SV*);
3731 MARK = ORIGMARK + 1;
3732 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3733 MEXTEND(MARK, length);
3734 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3736 EXTEND_MORTAL(length);
3737 for (i = length, dst = MARK; i; i--) {
3738 sv_2mortal(*dst); /* free them eventualy */
3745 *MARK = AvARRAY(ary)[offset+length-1];
3748 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3749 SvREFCNT_dec(*dst++); /* free them now */
3752 AvFILLp(ary) += diff;
3754 /* pull up or down? */
3756 if (offset < after) { /* easier to pull up */
3757 if (offset) { /* esp. if nothing to pull */
3758 src = &AvARRAY(ary)[offset-1];
3759 dst = src - diff; /* diff is negative */
3760 for (i = offset; i > 0; i--) /* can't trust Copy */
3764 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3768 if (after) { /* anything to pull down? */
3769 src = AvARRAY(ary) + offset + length;
3770 dst = src + diff; /* diff is negative */
3771 Move(src, dst, after, SV*);
3773 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3774 /* avoid later double free */
3778 dst[--i] = &PL_sv_undef;
3781 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3783 *dst = NEWSV(46, 0);
3784 sv_setsv(*dst++, *src++);
3786 Safefree(tmparyval);
3789 else { /* no, expanding (or same) */
3791 New(452, tmparyval, length, SV*); /* so remember deletion */
3792 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3795 if (diff > 0) { /* expanding */
3797 /* push up or down? */
3799 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3803 Move(src, dst, offset, SV*);
3805 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3807 AvFILLp(ary) += diff;
3810 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3811 av_extend(ary, AvFILLp(ary) + diff);
3812 AvFILLp(ary) += diff;
3815 dst = AvARRAY(ary) + AvFILLp(ary);
3817 for (i = after; i; i--) {
3824 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3825 *dst = NEWSV(46, 0);
3826 sv_setsv(*dst++, *src++);
3828 MARK = ORIGMARK + 1;
3829 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3831 Copy(tmparyval, MARK, length, SV*);
3833 EXTEND_MORTAL(length);
3834 for (i = length, dst = MARK; i; i--) {
3835 sv_2mortal(*dst); /* free them eventualy */
3839 Safefree(tmparyval);
3843 else if (length--) {
3844 *MARK = tmparyval[length];
3847 while (length-- > 0)
3848 SvREFCNT_dec(tmparyval[length]);
3850 Safefree(tmparyval);
3853 *MARK = &PL_sv_undef;
3861 djSP; dMARK; dORIGMARK; dTARGET;
3862 register AV *ary = (AV*)*++MARK;
3863 register SV *sv = &PL_sv_undef;
3866 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3867 *MARK-- = SvTIED_obj((SV*)ary, mg);
3871 call_method("PUSH",G_SCALAR|G_DISCARD);
3876 /* Why no pre-extend of ary here ? */
3877 for (++MARK; MARK <= SP; MARK++) {
3880 sv_setsv(sv, *MARK);
3885 PUSHi( AvFILL(ary) + 1 );
3893 SV *sv = av_pop(av);
3895 (void)sv_2mortal(sv);
3904 SV *sv = av_shift(av);
3909 (void)sv_2mortal(sv);
3916 djSP; dMARK; dORIGMARK; dTARGET;
3917 register AV *ary = (AV*)*++MARK;
3922 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3923 *MARK-- = SvTIED_obj((SV*)ary, mg);
3927 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3932 av_unshift(ary, SP - MARK);
3935 sv_setsv(sv, *++MARK);
3936 (void)av_store(ary, i++, sv);
3940 PUSHi( AvFILL(ary) + 1 );
3950 if (GIMME == G_ARRAY) {
3957 /* safe as long as stack cannot get extended in the above */
3962 register char *down;
3967 SvUTF8_off(TARG); /* decontaminate */
3969 do_join(TARG, &PL_sv_no, MARK, SP);
3971 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3972 up = SvPV_force(TARG, len);
3974 if (DO_UTF8(TARG)) { /* first reverse each character */
3975 U8* s = (U8*)SvPVX(TARG);
3976 U8* send = (U8*)(s + len);
3985 down = (char*)(s - 1);
3986 if (s > send || !((*down & 0xc0) == 0x80)) {
3987 if (ckWARN_d(WARN_UTF8))
3988 Perl_warner(aTHX_ WARN_UTF8,
3989 "Malformed UTF-8 character");
4001 down = SvPVX(TARG) + len - 1;
4007 (void)SvPOK_only_UTF8(TARG);
4016 S_mul128(pTHX_ SV *sv, U8 m)
4019 char *s = SvPV(sv, len);
4023 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4024 SV *tmpNew = newSVpvn("0000000000", 10);
4026 sv_catsv(tmpNew, sv);
4027 SvREFCNT_dec(sv); /* free old sv */
4032 while (!*t) /* trailing '\0'? */
4035 i = ((*t - '0') << 7) + m;
4036 *(t--) = '0' + (i % 10);
4042 /* Explosives and implosives. */
4044 #if 'I' == 73 && 'J' == 74
4045 /* On an ASCII/ISO kind of system */
4046 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4049 Some other sort of character set - use memchr() so we don't match
4052 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4059 I32 start_sp_offset = SP - PL_stack_base;
4060 I32 gimme = GIMME_V;
4064 register char *pat = SvPV(left, llen);
4065 register char *s = SvPV(right, rlen);
4066 char *strend = s + rlen;
4068 register char *patend = pat + llen;
4074 /* These must not be in registers: */
4091 register U32 culong;
4095 #ifdef PERL_NATINT_PACK
4096 int natint; /* native integer */
4097 int unatint; /* unsigned native integer */
4100 if (gimme != G_ARRAY) { /* arrange to do first one only */
4102 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4103 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4105 while (isDIGIT(*patend) || *patend == '*')
4111 while (pat < patend) {
4113 datumtype = *pat++ & 0xFF;
4114 #ifdef PERL_NATINT_PACK
4117 if (isSPACE(datumtype))
4119 if (datumtype == '#') {
4120 while (pat < patend && *pat != '\n')
4125 char *natstr = "sSiIlL";
4127 if (strchr(natstr, datumtype)) {
4128 #ifdef PERL_NATINT_PACK
4134 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4139 else if (*pat == '*') {
4140 len = strend - strbeg; /* long enough */
4144 else if (isDIGIT(*pat)) {
4146 while (isDIGIT(*pat)) {
4147 len = (len * 10) + (*pat++ - '0');
4149 DIE(aTHX_ "Repeat count in unpack overflows");
4153 len = (datumtype != '@');
4157 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4158 case ',': /* grandfather in commas but with a warning */
4159 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4160 Perl_warner(aTHX_ WARN_UNPACK,
4161 "Invalid type in unpack: '%c'", (int)datumtype);
4164 if (len == 1 && pat[-1] != '1')
4173 if (len > strend - strbeg)
4174 DIE(aTHX_ "@ outside of string");
4178 if (len > s - strbeg)
4179 DIE(aTHX_ "X outside of string");
4183 if (len > strend - s)
4184 DIE(aTHX_ "x outside of string");
4188 if (start_sp_offset >= SP - PL_stack_base)
4189 DIE(aTHX_ "/ must follow a numeric type");
4192 pat++; /* ignore '*' for compatibility with pack */
4194 DIE(aTHX_ "/ cannot take a count" );
4201 if (len > strend - s)
4204 goto uchar_checksum;
4205 sv = NEWSV(35, len);
4206 sv_setpvn(sv, s, len);
4208 if (datumtype == 'A' || datumtype == 'Z') {
4209 aptr = s; /* borrow register */
4210 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4215 else { /* 'A' strips both nulls and spaces */
4216 s = SvPVX(sv) + len - 1;
4217 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4221 SvCUR_set(sv, s - SvPVX(sv));
4222 s = aptr; /* unborrow register */
4224 XPUSHs(sv_2mortal(sv));
4228 if (star || len > (strend - s) * 8)
4229 len = (strend - s) * 8;
4232 Newz(601, PL_bitcount, 256, char);
4233 for (bits = 1; bits < 256; bits++) {
4234 if (bits & 1) PL_bitcount[bits]++;
4235 if (bits & 2) PL_bitcount[bits]++;
4236 if (bits & 4) PL_bitcount[bits]++;
4237 if (bits & 8) PL_bitcount[bits]++;
4238 if (bits & 16) PL_bitcount[bits]++;
4239 if (bits & 32) PL_bitcount[bits]++;
4240 if (bits & 64) PL_bitcount[bits]++;
4241 if (bits & 128) PL_bitcount[bits]++;
4245 culong += PL_bitcount[*(unsigned char*)s++];
4250 if (datumtype == 'b') {
4252 if (bits & 1) culong++;
4258 if (bits & 128) culong++;
4265 sv = NEWSV(35, len + 1);
4269 if (datumtype == 'b') {
4271 for (len = 0; len < aint; len++) {
4272 if (len & 7) /*SUPPRESS 595*/
4276 *str++ = '0' + (bits & 1);
4281 for (len = 0; len < aint; len++) {
4286 *str++ = '0' + ((bits & 128) != 0);
4290 XPUSHs(sv_2mortal(sv));
4294 if (star || len > (strend - s) * 2)
4295 len = (strend - s) * 2;
4296 sv = NEWSV(35, len + 1);
4300 if (datumtype == 'h') {
4302 for (len = 0; len < aint; len++) {
4307 *str++ = PL_hexdigit[bits & 15];
4312 for (len = 0; len < aint; len++) {
4317 *str++ = PL_hexdigit[(bits >> 4) & 15];
4321 XPUSHs(sv_2mortal(sv));
4324 if (len > strend - s)
4329 if (aint >= 128) /* fake up signed chars */
4339 if (aint >= 128) /* fake up signed chars */
4342 sv_setiv(sv, (IV)aint);
4343 PUSHs(sv_2mortal(sv));
4348 if (len > strend - s)
4363 sv_setiv(sv, (IV)auint);
4364 PUSHs(sv_2mortal(sv));
4369 if (len > strend - s)
4372 while (len-- > 0 && s < strend) {
4374 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4378 cdouble += (NV)auint;
4386 while (len-- > 0 && s < strend) {
4388 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4392 sv_setuv(sv, (UV)auint);
4393 PUSHs(sv_2mortal(sv));
4398 #if SHORTSIZE == SIZE16
4399 along = (strend - s) / SIZE16;
4401 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4406 #if SHORTSIZE != SIZE16
4410 COPYNN(s, &ashort, sizeof(short));
4421 #if SHORTSIZE > SIZE16
4433 #if SHORTSIZE != SIZE16
4437 COPYNN(s, &ashort, sizeof(short));
4440 sv_setiv(sv, (IV)ashort);
4441 PUSHs(sv_2mortal(sv));
4449 #if SHORTSIZE > SIZE16
4455 sv_setiv(sv, (IV)ashort);
4456 PUSHs(sv_2mortal(sv));
4464 #if SHORTSIZE == SIZE16
4465 along = (strend - s) / SIZE16;
4467 unatint = natint && datumtype == 'S';
4468 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4473 #if SHORTSIZE != SIZE16
4475 unsigned short aushort;
4477 COPYNN(s, &aushort, sizeof(unsigned short));
4478 s += sizeof(unsigned short);
4486 COPY16(s, &aushort);
4489 if (datumtype == 'n')
4490 aushort = PerlSock_ntohs(aushort);
4493 if (datumtype == 'v')
4494 aushort = vtohs(aushort);
4503 #if SHORTSIZE != SIZE16
4505 unsigned short aushort;
4507 COPYNN(s, &aushort, sizeof(unsigned short));
4508 s += sizeof(unsigned short);
4510 sv_setiv(sv, (UV)aushort);
4511 PUSHs(sv_2mortal(sv));
4518 COPY16(s, &aushort);
4522 if (datumtype == 'n')
4523 aushort = PerlSock_ntohs(aushort);
4526 if (datumtype == 'v')
4527 aushort = vtohs(aushort);
4529 sv_setiv(sv, (UV)aushort);
4530 PUSHs(sv_2mortal(sv));
4536 along = (strend - s) / sizeof(int);
4541 Copy(s, &aint, 1, int);
4544 cdouble += (NV)aint;
4553 Copy(s, &aint, 1, int);
4557 /* Without the dummy below unpack("i", pack("i",-1))
4558 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4559 * cc with optimization turned on.
4561 * The bug was detected in
4562 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4563 * with optimization (-O4) turned on.
4564 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4565 * does not have this problem even with -O4.
4567 * This bug was reported as DECC_BUGS 1431
4568 * and tracked internally as GEM_BUGS 7775.
4570 * The bug is fixed in
4571 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4572 * UNIX V4.0F support: DEC C V5.9-006 or later
4573 * UNIX V4.0E support: DEC C V5.8-011 or later
4576 * See also few lines later for the same bug.
4579 sv_setiv(sv, (IV)aint) :
4581 sv_setiv(sv, (IV)aint);
4582 PUSHs(sv_2mortal(sv));
4587 along = (strend - s) / sizeof(unsigned int);
4592 Copy(s, &auint, 1, unsigned int);
4593 s += sizeof(unsigned int);
4595 cdouble += (NV)auint;
4604 Copy(s, &auint, 1, unsigned int);
4605 s += sizeof(unsigned int);
4608 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4609 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4610 * See details few lines earlier. */
4612 sv_setuv(sv, (UV)auint) :
4614 sv_setuv(sv, (UV)auint);
4615 PUSHs(sv_2mortal(sv));
4620 #if LONGSIZE == SIZE32
4621 along = (strend - s) / SIZE32;
4623 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4628 #if LONGSIZE != SIZE32
4631 COPYNN(s, &along, sizeof(long));
4634 cdouble += (NV)along;
4643 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4647 #if LONGSIZE > SIZE32
4648 if (along > 2147483647)
4649 along -= 4294967296;
4653 cdouble += (NV)along;
4662 #if LONGSIZE != SIZE32
4665 COPYNN(s, &along, sizeof(long));
4668 sv_setiv(sv, (IV)along);
4669 PUSHs(sv_2mortal(sv));
4676 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4680 #if LONGSIZE > SIZE32
4681 if (along > 2147483647)
4682 along -= 4294967296;
4686 sv_setiv(sv, (IV)along);
4687 PUSHs(sv_2mortal(sv));
4695 #if LONGSIZE == SIZE32
4696 along = (strend - s) / SIZE32;
4698 unatint = natint && datumtype == 'L';
4699 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4704 #if LONGSIZE != SIZE32
4706 unsigned long aulong;
4708 COPYNN(s, &aulong, sizeof(unsigned long));
4709 s += sizeof(unsigned long);
4711 cdouble += (NV)aulong;
4723 if (datumtype == 'N')
4724 aulong = PerlSock_ntohl(aulong);
4727 if (datumtype == 'V')
4728 aulong = vtohl(aulong);
4731 cdouble += (NV)aulong;
4740 #if LONGSIZE != SIZE32
4742 unsigned long aulong;
4744 COPYNN(s, &aulong, sizeof(unsigned long));
4745 s += sizeof(unsigned long);
4747 sv_setuv(sv, (UV)aulong);
4748 PUSHs(sv_2mortal(sv));
4758 if (datumtype == 'N')
4759 aulong = PerlSock_ntohl(aulong);
4762 if (datumtype == 'V')
4763 aulong = vtohl(aulong);
4766 sv_setuv(sv, (UV)aulong);
4767 PUSHs(sv_2mortal(sv));
4773 along = (strend - s) / sizeof(char*);
4779 if (sizeof(char*) > strend - s)
4782 Copy(s, &aptr, 1, char*);
4788 PUSHs(sv_2mortal(sv));
4798 while ((len > 0) && (s < strend)) {
4799 auv = (auv << 7) | (*s & 0x7f);
4800 if (!(*s++ & 0x80)) {
4804 PUSHs(sv_2mortal(sv));
4808 else if (++bytes >= sizeof(UV)) { /* promote to string */
4812 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4813 while (s < strend) {
4814 sv = mul128(sv, *s & 0x7f);
4815 if (!(*s++ & 0x80)) {
4824 PUSHs(sv_2mortal(sv));
4829 if ((s >= strend) && bytes)
4830 DIE(aTHX_ "Unterminated compressed integer");
4835 if (sizeof(char*) > strend - s)
4838 Copy(s, &aptr, 1, char*);
4843 sv_setpvn(sv, aptr, len);
4844 PUSHs(sv_2mortal(sv));
4848 along = (strend - s) / sizeof(Quad_t);
4854 if (s + sizeof(Quad_t) > strend)
4857 Copy(s, &aquad, 1, Quad_t);
4858 s += sizeof(Quad_t);
4861 if (aquad >= IV_MIN && aquad <= IV_MAX)
4862 sv_setiv(sv, (IV)aquad);
4864 sv_setnv(sv, (NV)aquad);
4865 PUSHs(sv_2mortal(sv));
4869 along = (strend - s) / sizeof(Quad_t);
4875 if (s + sizeof(Uquad_t) > strend)
4878 Copy(s, &auquad, 1, Uquad_t);
4879 s += sizeof(Uquad_t);
4882 if (auquad <= UV_MAX)
4883 sv_setuv(sv, (UV)auquad);
4885 sv_setnv(sv, (NV)auquad);
4886 PUSHs(sv_2mortal(sv));
4890 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4893 along = (strend - s) / sizeof(float);
4898 Copy(s, &afloat, 1, float);
4907 Copy(s, &afloat, 1, float);
4910 sv_setnv(sv, (NV)afloat);
4911 PUSHs(sv_2mortal(sv));
4917 along = (strend - s) / sizeof(double);
4922 Copy(s, &adouble, 1, double);
4923 s += sizeof(double);
4931 Copy(s, &adouble, 1, double);
4932 s += sizeof(double);
4934 sv_setnv(sv, (NV)adouble);
4935 PUSHs(sv_2mortal(sv));
4941 * Initialise the decode mapping. By using a table driven
4942 * algorithm, the code will be character-set independent
4943 * (and just as fast as doing character arithmetic)
4945 if (PL_uudmap['M'] == 0) {
4948 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4949 PL_uudmap[(U8)PL_uuemap[i]] = i;
4951 * Because ' ' and '`' map to the same value,
4952 * we need to decode them both the same.
4957 along = (strend - s) * 3 / 4;
4958 sv = NEWSV(42, along);
4961 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4966 len = PL_uudmap[*(U8*)s++] & 077;
4968 if (s < strend && ISUUCHAR(*s))
4969 a = PL_uudmap[*(U8*)s++] & 077;
4972 if (s < strend && ISUUCHAR(*s))
4973 b = PL_uudmap[*(U8*)s++] & 077;
4976 if (s < strend && ISUUCHAR(*s))
4977 c = PL_uudmap[*(U8*)s++] & 077;
4980 if (s < strend && ISUUCHAR(*s))
4981 d = PL_uudmap[*(U8*)s++] & 077;
4984 hunk[0] = (a << 2) | (b >> 4);
4985 hunk[1] = (b << 4) | (c >> 2);
4986 hunk[2] = (c << 6) | d;
4987 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4992 else if (s[1] == '\n') /* possible checksum byte */
4995 XPUSHs(sv_2mortal(sv));
5000 if (strchr("fFdD", datumtype) ||
5001 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5005 while (checksum >= 16) {
5009 while (checksum >= 4) {
5015 along = (1 << checksum) - 1;
5016 while (cdouble < 0.0)
5018 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5019 sv_setnv(sv, cdouble);
5022 if (checksum < 32) {
5023 aulong = (1 << checksum) - 1;
5026 sv_setuv(sv, (UV)culong);
5028 XPUSHs(sv_2mortal(sv));
5032 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5033 PUSHs(&PL_sv_undef);
5038 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5042 *hunk = PL_uuemap[len];
5043 sv_catpvn(sv, hunk, 1);
5046 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5047 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5048 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5049 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5050 sv_catpvn(sv, hunk, 4);
5055 char r = (len > 1 ? s[1] : '\0');
5056 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5057 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5058 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5059 hunk[3] = PL_uuemap[0];
5060 sv_catpvn(sv, hunk, 4);
5062 sv_catpvn(sv, "\n", 1);
5066 S_is_an_int(pTHX_ char *s, STRLEN l)
5069 SV *result = newSVpvn(s, l);
5070 char *result_c = SvPV(result, n_a); /* convenience */
5071 char *out = result_c;
5081 SvREFCNT_dec(result);
5104 SvREFCNT_dec(result);
5110 SvCUR_set(result, out - result_c);
5114 /* pnum must be '\0' terminated */
5116 S_div128(pTHX_ SV *pnum, bool *done)
5119 char *s = SvPV(pnum, len);
5128 i = m * 10 + (*t - '0');
5130 r = (i >> 7); /* r < 10 */
5137 SvCUR_set(pnum, (STRLEN) (t - s));
5144 djSP; dMARK; dORIGMARK; dTARGET;
5145 register SV *cat = TARG;
5148 register char *pat = SvPVx(*++MARK, fromlen);
5150 register char *patend = pat + fromlen;
5155 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5156 static char *space10 = " ";
5158 /* These must not be in registers: */
5173 #ifdef PERL_NATINT_PACK
5174 int natint; /* native integer */
5179 sv_setpvn(cat, "", 0);
5181 while (pat < patend) {
5182 SV *lengthcode = Nullsv;
5183 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5184 datumtype = *pat++ & 0xFF;
5185 #ifdef PERL_NATINT_PACK
5188 if (isSPACE(datumtype)) {
5192 if (datumtype == 'U' && pat == patcopy+1)
5194 if (datumtype == '#') {
5195 while (pat < patend && *pat != '\n')
5200 char *natstr = "sSiIlL";
5202 if (strchr(natstr, datumtype)) {
5203 #ifdef PERL_NATINT_PACK
5209 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5212 len = strchr("@Xxu", datumtype) ? 0 : items;
5215 else if (isDIGIT(*pat)) {
5217 while (isDIGIT(*pat)) {
5218 len = (len * 10) + (*pat++ - '0');
5220 DIE(aTHX_ "Repeat count in pack overflows");
5227 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5228 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5229 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5230 ? *MARK : &PL_sv_no)
5231 + (*pat == 'Z' ? 1 : 0)));
5235 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5236 case ',': /* grandfather in commas but with a warning */
5237 if (commas++ == 0 && ckWARN(WARN_PACK))
5238 Perl_warner(aTHX_ WARN_PACK,
5239 "Invalid type in pack: '%c'", (int)datumtype);
5242 DIE(aTHX_ "%% may only be used in unpack");
5253 if (SvCUR(cat) < len)
5254 DIE(aTHX_ "X outside of string");
5261 sv_catpvn(cat, null10, 10);
5264 sv_catpvn(cat, null10, len);
5270 aptr = SvPV(fromstr, fromlen);
5271 if (pat[-1] == '*') {
5273 if (datumtype == 'Z')
5276 if (fromlen >= len) {
5277 sv_catpvn(cat, aptr, len);
5278 if (datumtype == 'Z')
5279 *(SvEND(cat)-1) = '\0';
5282 sv_catpvn(cat, aptr, fromlen);
5284 if (datumtype == 'A') {
5286 sv_catpvn(cat, space10, 10);
5289 sv_catpvn(cat, space10, len);
5293 sv_catpvn(cat, null10, 10);
5296 sv_catpvn(cat, null10, len);
5308 str = SvPV(fromstr, fromlen);
5312 SvCUR(cat) += (len+7)/8;
5313 SvGROW(cat, SvCUR(cat) + 1);
5314 aptr = SvPVX(cat) + aint;
5319 if (datumtype == 'B') {
5320 for (len = 0; len++ < aint;) {
5321 items |= *str++ & 1;
5325 *aptr++ = items & 0xff;
5331 for (len = 0; len++ < aint;) {
5337 *aptr++ = items & 0xff;
5343 if (datumtype == 'B')
5344 items <<= 7 - (aint & 7);
5346 items >>= 7 - (aint & 7);
5347 *aptr++ = items & 0xff;
5349 str = SvPVX(cat) + SvCUR(cat);
5364 str = SvPV(fromstr, fromlen);
5368 SvCUR(cat) += (len+1)/2;
5369 SvGROW(cat, SvCUR(cat) + 1);
5370 aptr = SvPVX(cat) + aint;
5375 if (datumtype == 'H') {
5376 for (len = 0; len++ < aint;) {
5378 items |= ((*str++ & 15) + 9) & 15;
5380 items |= *str++ & 15;
5384 *aptr++ = items & 0xff;
5390 for (len = 0; len++ < aint;) {
5392 items |= (((*str++ & 15) + 9) & 15) << 4;
5394 items |= (*str++ & 15) << 4;
5398 *aptr++ = items & 0xff;
5404 *aptr++ = items & 0xff;
5405 str = SvPVX(cat) + SvCUR(cat);
5416 aint = SvIV(fromstr);
5418 sv_catpvn(cat, &achar, sizeof(char));
5424 auint = SvUV(fromstr);
5425 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5426 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
5431 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5436 afloat = (float)SvNV(fromstr);
5437 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5444 adouble = (double)SvNV(fromstr);
5445 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5451 ashort = (I16)SvIV(fromstr);
5453 ashort = PerlSock_htons(ashort);
5455 CAT16(cat, &ashort);
5461 ashort = (I16)SvIV(fromstr);
5463 ashort = htovs(ashort);
5465 CAT16(cat, &ashort);
5469 #if SHORTSIZE != SIZE16
5471 unsigned short aushort;
5475 aushort = SvUV(fromstr);
5476 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5486 aushort = (U16)SvUV(fromstr);
5487 CAT16(cat, &aushort);
5493 #if SHORTSIZE != SIZE16
5499 ashort = SvIV(fromstr);
5500 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5508 ashort = (I16)SvIV(fromstr);
5509 CAT16(cat, &ashort);
5516 auint = SvUV(fromstr);
5517 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5523 adouble = Perl_floor(SvNV(fromstr));
5526 DIE(aTHX_ "Cannot compress negative numbers");
5529 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5530 adouble <= 0xffffffff
5532 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5533 adouble <= UV_MAX_cxux
5540 char buf[1 + sizeof(UV)];
5541 char *in = buf + sizeof(buf);
5542 UV auv = U_V(adouble);
5545 *--in = (auv & 0x7f) | 0x80;
5548 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5549 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5551 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5552 char *from, *result, *in;
5557 /* Copy string and check for compliance */
5558 from = SvPV(fromstr, len);
5559 if ((norm = is_an_int(from, len)) == NULL)
5560 DIE(aTHX_ "can compress only unsigned integer");
5562 New('w', result, len, char);
5566 *--in = div128(norm, &done) | 0x80;
5567 result[len - 1] &= 0x7F; /* clear continue bit */
5568 sv_catpvn(cat, in, (result + len) - in);
5570 SvREFCNT_dec(norm); /* free norm */
5572 else if (SvNOKp(fromstr)) {
5573 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5574 char *in = buf + sizeof(buf);
5577 double next = floor(adouble / 128);
5578 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5579 if (in <= buf) /* this cannot happen ;-) */
5580 DIE(aTHX_ "Cannot compress integer");
5583 } while (adouble > 0);
5584 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5585 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5588 DIE(aTHX_ "Cannot compress non integer");
5594 aint = SvIV(fromstr);
5595 sv_catpvn(cat, (char*)&aint, sizeof(int));
5601 aulong = SvUV(fromstr);
5603 aulong = PerlSock_htonl(aulong);
5605 CAT32(cat, &aulong);
5611 aulong = SvUV(fromstr);
5613 aulong = htovl(aulong);
5615 CAT32(cat, &aulong);
5619 #if LONGSIZE != SIZE32
5621 unsigned long aulong;
5625 aulong = SvUV(fromstr);
5626 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5634 aulong = SvUV(fromstr);
5635 CAT32(cat, &aulong);
5640 #if LONGSIZE != SIZE32
5646 along = SvIV(fromstr);
5647 sv_catpvn(cat, (char *)&along, sizeof(long));
5655 along = SvIV(fromstr);
5664 auquad = (Uquad_t)SvUV(fromstr);
5665 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5671 aquad = (Quad_t)SvIV(fromstr);
5672 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5677 len = 1; /* assume SV is correct length */
5682 if (fromstr == &PL_sv_undef)
5686 /* XXX better yet, could spirit away the string to
5687 * a safe spot and hang on to it until the result
5688 * of pack() (and all copies of the result) are
5691 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5692 || (SvPADTMP(fromstr)
5693 && !SvREADONLY(fromstr))))
5695 Perl_warner(aTHX_ WARN_PACK,
5696 "Attempt to pack pointer to temporary value");
5698 if (SvPOK(fromstr) || SvNIOK(fromstr))
5699 aptr = SvPV(fromstr,n_a);
5701 aptr = SvPV_force(fromstr,n_a);
5703 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5708 aptr = SvPV(fromstr, fromlen);
5709 SvGROW(cat, fromlen * 4 / 3);
5714 while (fromlen > 0) {
5721 doencodes(cat, aptr, todo);
5740 register IV limit = POPi; /* note, negative is forever */
5743 register char *s = SvPV(sv, len);
5744 bool do_utf8 = DO_UTF8(sv);
5745 char *strend = s + len;
5747 register REGEXP *rx;
5751 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5752 I32 maxiters = slen + 10;
5755 I32 origlimit = limit;
5758 AV *oldstack = PL_curstack;
5759 I32 gimme = GIMME_V;
5760 I32 oldsave = PL_savestack_ix;
5761 I32 make_mortal = 1;
5762 MAGIC *mg = (MAGIC *) NULL;
5765 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5770 DIE(aTHX_ "panic: pp_split");
5771 rx = pm->op_pmregexp;
5773 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5774 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5776 if (pm->op_pmreplroot) {
5778 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5780 ary = GvAVn((GV*)pm->op_pmreplroot);
5783 else if (gimme != G_ARRAY)
5785 ary = (AV*)PL_curpad[0];
5787 ary = GvAVn(PL_defgv);
5788 #endif /* USE_THREADS */
5791 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5797 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5799 XPUSHs(SvTIED_obj((SV*)ary, mg));
5805 for (i = AvFILLp(ary); i >= 0; i--)
5806 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5808 /* temporarily switch stacks */
5809 SWITCHSTACK(PL_curstack, ary);
5813 base = SP - PL_stack_base;
5815 if (pm->op_pmflags & PMf_SKIPWHITE) {
5816 if (pm->op_pmflags & PMf_LOCALE) {
5817 while (isSPACE_LC(*s))
5825 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5826 SAVEINT(PL_multiline);
5827 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5831 limit = maxiters + 2;
5832 if (pm->op_pmflags & PMf_WHITE) {
5835 while (m < strend &&
5836 !((pm->op_pmflags & PMf_LOCALE)
5837 ? isSPACE_LC(*m) : isSPACE(*m)))
5842 dstr = NEWSV(30, m-s);
5843 sv_setpvn(dstr, s, m-s);
5847 (void)SvUTF8_on(dstr);
5851 while (s < strend &&
5852 ((pm->op_pmflags & PMf_LOCALE)
5853 ? isSPACE_LC(*s) : isSPACE(*s)))
5857 else if (strEQ("^", rx->precomp)) {
5860 for (m = s; m < strend && *m != '\n'; m++) ;
5864 dstr = NEWSV(30, m-s);
5865 sv_setpvn(dstr, s, m-s);
5869 (void)SvUTF8_on(dstr);
5874 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5875 && (rx->reganch & ROPT_CHECK_ALL)
5876 && !(rx->reganch & ROPT_ANCH)) {
5877 int tail = (rx->reganch & RE_INTUIT_TAIL);
5878 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5881 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5883 char c = *SvPV(csv, n_a);
5886 for (m = s; m < strend && *m != c; m++) ;
5889 dstr = NEWSV(30, m-s);
5890 sv_setpvn(dstr, s, m-s);
5894 (void)SvUTF8_on(dstr);
5896 /* The rx->minlen is in characters but we want to step
5897 * s ahead by bytes. */
5899 s = (char*)utf8_hop((U8*)m, len);
5901 s = m + len; /* Fake \n at the end */
5906 while (s < strend && --limit &&
5907 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5908 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5911 dstr = NEWSV(31, m-s);
5912 sv_setpvn(dstr, s, m-s);
5916 (void)SvUTF8_on(dstr);
5918 /* The rx->minlen is in characters but we want to step
5919 * s ahead by bytes. */
5921 s = (char*)utf8_hop((U8*)m, len);
5923 s = m + len; /* Fake \n at the end */
5928 maxiters += slen * rx->nparens;
5929 while (s < strend && --limit
5930 /* && (!rx->check_substr
5931 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5933 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5934 1 /* minend */, sv, NULL, 0))
5936 TAINT_IF(RX_MATCH_TAINTED(rx));
5937 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5942 strend = s + (strend - m);
5944 m = rx->startp[0] + orig;
5945 dstr = NEWSV(32, m-s);
5946 sv_setpvn(dstr, s, m-s);
5950 (void)SvUTF8_on(dstr);
5953 for (i = 1; i <= rx->nparens; i++) {
5954 s = rx->startp[i] + orig;
5955 m = rx->endp[i] + orig;
5957 dstr = NEWSV(33, m-s);
5958 sv_setpvn(dstr, s, m-s);
5961 dstr = NEWSV(33, 0);
5965 (void)SvUTF8_on(dstr);
5969 s = rx->endp[0] + orig;
5973 LEAVE_SCOPE(oldsave);
5974 iters = (SP - PL_stack_base) - base;
5975 if (iters > maxiters)
5976 DIE(aTHX_ "Split loop");
5978 /* keep field after final delim? */
5979 if (s < strend || (iters && origlimit)) {
5980 STRLEN l = strend - s;
5981 dstr = NEWSV(34, l);
5982 sv_setpvn(dstr, s, l);
5986 (void)SvUTF8_on(dstr);
5990 else if (!origlimit) {
5991 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5997 SWITCHSTACK(ary, oldstack);
5998 if (SvSMAGICAL(ary)) {
6003 if (gimme == G_ARRAY) {
6005 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6013 call_method("PUSH",G_SCALAR|G_DISCARD);
6016 if (gimme == G_ARRAY) {
6017 /* EXTEND should not be needed - we just popped them */
6019 for (i=0; i < iters; i++) {
6020 SV **svp = av_fetch(ary, i, FALSE);
6021 PUSHs((svp) ? *svp : &PL_sv_undef);
6028 if (gimme == G_ARRAY)
6031 if (iters || !pm->op_pmreplroot) {
6041 Perl_unlock_condpair(pTHX_ void *svv)
6043 MAGIC *mg = mg_find((SV*)svv, 'm');
6046 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6047 MUTEX_LOCK(MgMUTEXP(mg));
6048 if (MgOWNER(mg) != thr)
6049 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6051 COND_SIGNAL(MgOWNERCONDP(mg));
6052 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6053 PTR2UV(thr), PTR2UV(svv));)
6054 MUTEX_UNLOCK(MgMUTEXP(mg));
6056 #endif /* USE_THREADS */
6065 #endif /* USE_THREADS */
6066 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6067 || SvTYPE(retsv) == SVt_PVCV) {
6068 retsv = refto(retsv);
6079 if (PL_op->op_private & OPpLVAL_INTRO)
6080 PUSHs(*save_threadsv(PL_op->op_targ));
6082 PUSHs(THREADSV(PL_op->op_targ));
6085 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6086 #endif /* USE_THREADS */