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_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) && UTF8_IS_START(*s) && 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) ||
2962 (UTF8_IS_CONTINUED(value) && (PL_hints & HINT_UTF8)) ) {
2963 SvGROW(TARG, UTF8_MAXLEN+1);
2965 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2966 SvCUR_set(TARG, tmps - SvPVX(TARG));
2968 (void)SvPOK_only(TARG);
2982 (void)SvPOK_only(TARG);
2989 djSP; dTARGET; dPOPTOPssrl;
2992 char *tmps = SvPV(left, n_a);
2994 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2996 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3000 "The crypt() function is unimplemented due to excessive paranoia.");
3013 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3015 U8 tmpbuf[UTF8_MAXLEN+1];
3017 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3019 if (PL_op->op_private & OPpLOCALE) {
3022 uv = toTITLE_LC_uni(uv);
3025 uv = toTITLE_utf8(s);
3027 tend = uv_to_utf8(tmpbuf, uv);
3029 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3031 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3032 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3037 s = (U8*)SvPV_force(sv, slen);
3038 Copy(tmpbuf, s, ulen, U8);
3042 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3044 SvUTF8_off(TARG); /* decontaminate */
3049 s = (U8*)SvPV_force(sv, slen);
3051 if (PL_op->op_private & OPpLOCALE) {
3054 *s = toUPPER_LC(*s);
3072 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3074 U8 tmpbuf[UTF8_MAXLEN+1];
3076 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3078 if (PL_op->op_private & OPpLOCALE) {
3081 uv = toLOWER_LC_uni(uv);
3084 uv = toLOWER_utf8(s);
3086 tend = uv_to_utf8(tmpbuf, uv);
3088 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3090 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3091 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3096 s = (U8*)SvPV_force(sv, slen);
3097 Copy(tmpbuf, s, ulen, U8);
3101 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3103 SvUTF8_off(TARG); /* decontaminate */
3108 s = (U8*)SvPV_force(sv, slen);
3110 if (PL_op->op_private & OPpLOCALE) {
3113 *s = toLOWER_LC(*s);
3137 s = (U8*)SvPV(sv,len);
3139 SvUTF8_off(TARG); /* decontaminate */
3140 sv_setpvn(TARG, "", 0);
3144 (void)SvUPGRADE(TARG, SVt_PV);
3145 SvGROW(TARG, (len * 2) + 1);
3146 (void)SvPOK_only(TARG);
3147 d = (U8*)SvPVX(TARG);
3149 if (PL_op->op_private & OPpLOCALE) {
3153 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3159 d = uv_to_utf8(d, toUPPER_utf8( s ));
3165 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3170 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3172 SvUTF8_off(TARG); /* decontaminate */
3177 s = (U8*)SvPV_force(sv, len);
3179 register U8 *send = s + len;
3181 if (PL_op->op_private & OPpLOCALE) {
3184 for (; s < send; s++)
3185 *s = toUPPER_LC(*s);
3188 for (; s < send; s++)
3211 s = (U8*)SvPV(sv,len);
3213 SvUTF8_off(TARG); /* decontaminate */
3214 sv_setpvn(TARG, "", 0);
3218 (void)SvUPGRADE(TARG, SVt_PV);
3219 SvGROW(TARG, (len * 2) + 1);
3220 (void)SvPOK_only(TARG);
3221 d = (U8*)SvPVX(TARG);
3223 if (PL_op->op_private & OPpLOCALE) {
3227 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3233 d = uv_to_utf8(d, toLOWER_utf8(s));
3239 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3244 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3246 SvUTF8_off(TARG); /* decontaminate */
3252 s = (U8*)SvPV_force(sv, len);
3254 register U8 *send = s + len;
3256 if (PL_op->op_private & OPpLOCALE) {
3259 for (; s < send; s++)
3260 *s = toLOWER_LC(*s);
3263 for (; s < send; s++)
3278 register char *s = SvPV(sv,len);
3281 SvUTF8_off(TARG); /* decontaminate */
3283 (void)SvUPGRADE(TARG, SVt_PV);
3284 SvGROW(TARG, (len * 2) + 1);
3288 if (UTF8_IS_CONTINUED(*s)) {
3289 STRLEN ulen = UTF8SKIP(s);
3313 SvCUR_set(TARG, d - SvPVX(TARG));
3314 (void)SvPOK_only_UTF8(TARG);
3317 sv_setpvn(TARG, s, len);
3319 if (SvSMAGICAL(TARG))
3328 djSP; dMARK; dORIGMARK;
3330 register AV* av = (AV*)POPs;
3331 register I32 lval = PL_op->op_flags & OPf_MOD;
3332 I32 arybase = PL_curcop->cop_arybase;
3335 if (SvTYPE(av) == SVt_PVAV) {
3336 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3338 for (svp = MARK + 1; svp <= SP; svp++) {
3343 if (max > AvMAX(av))
3346 while (++MARK <= SP) {
3347 elem = SvIVx(*MARK);
3351 svp = av_fetch(av, elem, lval);
3353 if (!svp || *svp == &PL_sv_undef)
3354 DIE(aTHX_ PL_no_aelem, elem);
3355 if (PL_op->op_private & OPpLVAL_INTRO)
3356 save_aelem(av, elem, svp);
3358 *MARK = svp ? *svp : &PL_sv_undef;
3361 if (GIMME != G_ARRAY) {
3369 /* Associative arrays. */
3374 HV *hash = (HV*)POPs;
3376 I32 gimme = GIMME_V;
3377 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3380 /* might clobber stack_sp */
3381 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3386 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3387 if (gimme == G_ARRAY) {
3390 /* might clobber stack_sp */
3392 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3397 else if (gimme == G_SCALAR)
3416 I32 gimme = GIMME_V;
3417 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3421 if (PL_op->op_private & OPpSLICE) {
3425 hvtype = SvTYPE(hv);
3426 if (hvtype == SVt_PVHV) { /* hash element */
3427 while (++MARK <= SP) {
3428 sv = hv_delete_ent(hv, *MARK, discard, 0);
3429 *MARK = sv ? sv : &PL_sv_undef;
3432 else if (hvtype == SVt_PVAV) {
3433 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3434 while (++MARK <= SP) {
3435 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3436 *MARK = sv ? sv : &PL_sv_undef;
3439 else { /* pseudo-hash element */
3440 while (++MARK <= SP) {
3441 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3442 *MARK = sv ? sv : &PL_sv_undef;
3447 DIE(aTHX_ "Not a HASH reference");
3450 else if (gimme == G_SCALAR) {
3459 if (SvTYPE(hv) == SVt_PVHV)
3460 sv = hv_delete_ent(hv, keysv, discard, 0);
3461 else if (SvTYPE(hv) == SVt_PVAV) {
3462 if (PL_op->op_flags & OPf_SPECIAL)
3463 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3465 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3468 DIE(aTHX_ "Not a HASH reference");
3483 if (PL_op->op_private & OPpEXISTS_SUB) {
3487 cv = sv_2cv(sv, &hv, &gv, FALSE);
3490 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3496 if (SvTYPE(hv) == SVt_PVHV) {
3497 if (hv_exists_ent(hv, tmpsv, 0))
3500 else if (SvTYPE(hv) == SVt_PVAV) {
3501 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3502 if (av_exists((AV*)hv, SvIV(tmpsv)))
3505 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3509 DIE(aTHX_ "Not a HASH reference");
3516 djSP; dMARK; dORIGMARK;
3517 register HV *hv = (HV*)POPs;
3518 register I32 lval = PL_op->op_flags & OPf_MOD;
3519 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3521 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3522 DIE(aTHX_ "Can't localize pseudo-hash element");
3524 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3525 while (++MARK <= SP) {
3528 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3530 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3531 svp = he ? &HeVAL(he) : 0;
3534 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3537 if (!svp || *svp == &PL_sv_undef) {
3539 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3541 if (PL_op->op_private & OPpLVAL_INTRO) {
3543 save_helem(hv, keysv, svp);
3546 char *key = SvPV(keysv, keylen);
3547 save_delete(hv, key, keylen);
3551 *MARK = svp ? *svp : &PL_sv_undef;
3554 if (GIMME != G_ARRAY) {
3562 /* List operators. */
3567 if (GIMME != G_ARRAY) {
3569 *MARK = *SP; /* unwanted list, return last item */
3571 *MARK = &PL_sv_undef;
3580 SV **lastrelem = PL_stack_sp;
3581 SV **lastlelem = PL_stack_base + POPMARK;
3582 SV **firstlelem = PL_stack_base + POPMARK + 1;
3583 register SV **firstrelem = lastlelem + 1;
3584 I32 arybase = PL_curcop->cop_arybase;
3585 I32 lval = PL_op->op_flags & OPf_MOD;
3586 I32 is_something_there = lval;
3588 register I32 max = lastrelem - lastlelem;
3589 register SV **lelem;
3592 if (GIMME != G_ARRAY) {
3593 ix = SvIVx(*lastlelem);
3598 if (ix < 0 || ix >= max)
3599 *firstlelem = &PL_sv_undef;
3601 *firstlelem = firstrelem[ix];
3607 SP = firstlelem - 1;
3611 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3617 if (ix < 0 || ix >= max)
3618 *lelem = &PL_sv_undef;
3620 is_something_there = TRUE;
3621 if (!(*lelem = firstrelem[ix]))
3622 *lelem = &PL_sv_undef;
3625 if (is_something_there)
3628 SP = firstlelem - 1;
3634 djSP; dMARK; dORIGMARK;
3635 I32 items = SP - MARK;
3636 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3637 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3644 djSP; dMARK; dORIGMARK;
3645 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3649 SV *val = NEWSV(46, 0);
3651 sv_setsv(val, *++MARK);
3652 else if (ckWARN(WARN_MISC))
3653 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3654 (void)hv_store_ent(hv,key,val,0);
3663 djSP; dMARK; dORIGMARK;
3664 register AV *ary = (AV*)*++MARK;
3668 register I32 offset;
3669 register I32 length;
3676 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3677 *MARK-- = SvTIED_obj((SV*)ary, mg);
3681 call_method("SPLICE",GIMME_V);
3690 offset = i = SvIVx(*MARK);
3692 offset += AvFILLp(ary) + 1;
3694 offset -= PL_curcop->cop_arybase;
3696 DIE(aTHX_ PL_no_aelem, i);
3698 length = SvIVx(*MARK++);
3700 length += AvFILLp(ary) - offset + 1;
3706 length = AvMAX(ary) + 1; /* close enough to infinity */
3710 length = AvMAX(ary) + 1;
3712 if (offset > AvFILLp(ary) + 1)
3713 offset = AvFILLp(ary) + 1;
3714 after = AvFILLp(ary) + 1 - (offset + length);
3715 if (after < 0) { /* not that much array */
3716 length += after; /* offset+length now in array */
3722 /* At this point, MARK .. SP-1 is our new LIST */
3725 diff = newlen - length;
3726 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3729 if (diff < 0) { /* shrinking the area */
3731 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3732 Copy(MARK, tmparyval, newlen, SV*);
3735 MARK = ORIGMARK + 1;
3736 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3737 MEXTEND(MARK, length);
3738 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3740 EXTEND_MORTAL(length);
3741 for (i = length, dst = MARK; i; i--) {
3742 sv_2mortal(*dst); /* free them eventualy */
3749 *MARK = AvARRAY(ary)[offset+length-1];
3752 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3753 SvREFCNT_dec(*dst++); /* free them now */
3756 AvFILLp(ary) += diff;
3758 /* pull up or down? */
3760 if (offset < after) { /* easier to pull up */
3761 if (offset) { /* esp. if nothing to pull */
3762 src = &AvARRAY(ary)[offset-1];
3763 dst = src - diff; /* diff is negative */
3764 for (i = offset; i > 0; i--) /* can't trust Copy */
3768 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3772 if (after) { /* anything to pull down? */
3773 src = AvARRAY(ary) + offset + length;
3774 dst = src + diff; /* diff is negative */
3775 Move(src, dst, after, SV*);
3777 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3778 /* avoid later double free */
3782 dst[--i] = &PL_sv_undef;
3785 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3787 *dst = NEWSV(46, 0);
3788 sv_setsv(*dst++, *src++);
3790 Safefree(tmparyval);
3793 else { /* no, expanding (or same) */
3795 New(452, tmparyval, length, SV*); /* so remember deletion */
3796 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3799 if (diff > 0) { /* expanding */
3801 /* push up or down? */
3803 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3807 Move(src, dst, offset, SV*);
3809 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3811 AvFILLp(ary) += diff;
3814 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3815 av_extend(ary, AvFILLp(ary) + diff);
3816 AvFILLp(ary) += diff;
3819 dst = AvARRAY(ary) + AvFILLp(ary);
3821 for (i = after; i; i--) {
3828 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3829 *dst = NEWSV(46, 0);
3830 sv_setsv(*dst++, *src++);
3832 MARK = ORIGMARK + 1;
3833 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3835 Copy(tmparyval, MARK, length, SV*);
3837 EXTEND_MORTAL(length);
3838 for (i = length, dst = MARK; i; i--) {
3839 sv_2mortal(*dst); /* free them eventualy */
3843 Safefree(tmparyval);
3847 else if (length--) {
3848 *MARK = tmparyval[length];
3851 while (length-- > 0)
3852 SvREFCNT_dec(tmparyval[length]);
3854 Safefree(tmparyval);
3857 *MARK = &PL_sv_undef;
3865 djSP; dMARK; dORIGMARK; dTARGET;
3866 register AV *ary = (AV*)*++MARK;
3867 register SV *sv = &PL_sv_undef;
3870 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3871 *MARK-- = SvTIED_obj((SV*)ary, mg);
3875 call_method("PUSH",G_SCALAR|G_DISCARD);
3880 /* Why no pre-extend of ary here ? */
3881 for (++MARK; MARK <= SP; MARK++) {
3884 sv_setsv(sv, *MARK);
3889 PUSHi( AvFILL(ary) + 1 );
3897 SV *sv = av_pop(av);
3899 (void)sv_2mortal(sv);
3908 SV *sv = av_shift(av);
3913 (void)sv_2mortal(sv);
3920 djSP; dMARK; dORIGMARK; dTARGET;
3921 register AV *ary = (AV*)*++MARK;
3926 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3927 *MARK-- = SvTIED_obj((SV*)ary, mg);
3931 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3936 av_unshift(ary, SP - MARK);
3939 sv_setsv(sv, *++MARK);
3940 (void)av_store(ary, i++, sv);
3944 PUSHi( AvFILL(ary) + 1 );
3954 if (GIMME == G_ARRAY) {
3961 /* safe as long as stack cannot get extended in the above */
3966 register char *down;
3971 SvUTF8_off(TARG); /* decontaminate */
3973 do_join(TARG, &PL_sv_no, MARK, SP);
3975 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3976 up = SvPV_force(TARG, len);
3978 if (DO_UTF8(TARG)) { /* first reverse each character */
3979 U8* s = (U8*)SvPVX(TARG);
3980 U8* send = (U8*)(s + len);
3982 if (UTF8_IS_ASCII(*s)) {
3987 if (!utf8_to_uv_simple(s, 0))
3991 down = (char*)(s - 1);
3992 /* reverse this character */
4002 down = SvPVX(TARG) + len - 1;
4008 (void)SvPOK_only_UTF8(TARG);
4017 S_mul128(pTHX_ SV *sv, U8 m)
4020 char *s = SvPV(sv, len);
4024 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4025 SV *tmpNew = newSVpvn("0000000000", 10);
4027 sv_catsv(tmpNew, sv);
4028 SvREFCNT_dec(sv); /* free old sv */
4033 while (!*t) /* trailing '\0'? */
4036 i = ((*t - '0') << 7) + m;
4037 *(t--) = '0' + (i % 10);
4043 /* Explosives and implosives. */
4045 #if 'I' == 73 && 'J' == 74
4046 /* On an ASCII/ISO kind of system */
4047 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4050 Some other sort of character set - use memchr() so we don't match
4053 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4060 I32 start_sp_offset = SP - PL_stack_base;
4061 I32 gimme = GIMME_V;
4065 register char *pat = SvPV(left, llen);
4066 register char *s = SvPV(right, rlen);
4067 char *strend = s + rlen;
4069 register char *patend = pat + llen;
4075 /* These must not be in registers: */
4092 register U32 culong;
4096 #ifdef PERL_NATINT_PACK
4097 int natint; /* native integer */
4098 int unatint; /* unsigned native integer */
4101 if (gimme != G_ARRAY) { /* arrange to do first one only */
4103 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4104 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4106 while (isDIGIT(*patend) || *patend == '*')
4112 while (pat < patend) {
4114 datumtype = *pat++ & 0xFF;
4115 #ifdef PERL_NATINT_PACK
4118 if (isSPACE(datumtype))
4120 if (datumtype == '#') {
4121 while (pat < patend && *pat != '\n')
4126 char *natstr = "sSiIlL";
4128 if (strchr(natstr, datumtype)) {
4129 #ifdef PERL_NATINT_PACK
4135 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4140 else if (*pat == '*') {
4141 len = strend - strbeg; /* long enough */
4145 else if (isDIGIT(*pat)) {
4147 while (isDIGIT(*pat)) {
4148 len = (len * 10) + (*pat++ - '0');
4150 DIE(aTHX_ "Repeat count in unpack overflows");
4154 len = (datumtype != '@');
4158 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4159 case ',': /* grandfather in commas but with a warning */
4160 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4161 Perl_warner(aTHX_ WARN_UNPACK,
4162 "Invalid type in unpack: '%c'", (int)datumtype);
4165 if (len == 1 && pat[-1] != '1')
4174 if (len > strend - strbeg)
4175 DIE(aTHX_ "@ outside of string");
4179 if (len > s - strbeg)
4180 DIE(aTHX_ "X outside of string");
4184 if (len > strend - s)
4185 DIE(aTHX_ "x outside of string");
4189 if (start_sp_offset >= SP - PL_stack_base)
4190 DIE(aTHX_ "/ must follow a numeric type");
4193 pat++; /* ignore '*' for compatibility with pack */
4195 DIE(aTHX_ "/ cannot take a count" );
4202 if (len > strend - s)
4205 goto uchar_checksum;
4206 sv = NEWSV(35, len);
4207 sv_setpvn(sv, s, len);
4209 if (datumtype == 'A' || datumtype == 'Z') {
4210 aptr = s; /* borrow register */
4211 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4216 else { /* 'A' strips both nulls and spaces */
4217 s = SvPVX(sv) + len - 1;
4218 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4222 SvCUR_set(sv, s - SvPVX(sv));
4223 s = aptr; /* unborrow register */
4225 XPUSHs(sv_2mortal(sv));
4229 if (star || len > (strend - s) * 8)
4230 len = (strend - s) * 8;
4233 Newz(601, PL_bitcount, 256, char);
4234 for (bits = 1; bits < 256; bits++) {
4235 if (bits & 1) PL_bitcount[bits]++;
4236 if (bits & 2) PL_bitcount[bits]++;
4237 if (bits & 4) PL_bitcount[bits]++;
4238 if (bits & 8) PL_bitcount[bits]++;
4239 if (bits & 16) PL_bitcount[bits]++;
4240 if (bits & 32) PL_bitcount[bits]++;
4241 if (bits & 64) PL_bitcount[bits]++;
4242 if (bits & 128) PL_bitcount[bits]++;
4246 culong += PL_bitcount[*(unsigned char*)s++];
4251 if (datumtype == 'b') {
4253 if (bits & 1) culong++;
4259 if (bits & 128) culong++;
4266 sv = NEWSV(35, len + 1);
4270 if (datumtype == 'b') {
4272 for (len = 0; len < aint; len++) {
4273 if (len & 7) /*SUPPRESS 595*/
4277 *str++ = '0' + (bits & 1);
4282 for (len = 0; len < aint; len++) {
4287 *str++ = '0' + ((bits & 128) != 0);
4291 XPUSHs(sv_2mortal(sv));
4295 if (star || len > (strend - s) * 2)
4296 len = (strend - s) * 2;
4297 sv = NEWSV(35, len + 1);
4301 if (datumtype == 'h') {
4303 for (len = 0; len < aint; len++) {
4308 *str++ = PL_hexdigit[bits & 15];
4313 for (len = 0; len < aint; len++) {
4318 *str++ = PL_hexdigit[(bits >> 4) & 15];
4322 XPUSHs(sv_2mortal(sv));
4325 if (len > strend - s)
4330 if (aint >= 128) /* fake up signed chars */
4340 if (aint >= 128) /* fake up signed chars */
4343 sv_setiv(sv, (IV)aint);
4344 PUSHs(sv_2mortal(sv));
4349 if (len > strend - s)
4364 sv_setiv(sv, (IV)auint);
4365 PUSHs(sv_2mortal(sv));
4370 if (len > strend - s)
4373 while (len-- > 0 && s < strend) {
4375 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4379 cdouble += (NV)auint;
4387 while (len-- > 0 && s < strend) {
4389 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4393 sv_setuv(sv, (UV)auint);
4394 PUSHs(sv_2mortal(sv));
4399 #if SHORTSIZE == SIZE16
4400 along = (strend - s) / SIZE16;
4402 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4407 #if SHORTSIZE != SIZE16
4411 COPYNN(s, &ashort, sizeof(short));
4422 #if SHORTSIZE > SIZE16
4434 #if SHORTSIZE != SIZE16
4438 COPYNN(s, &ashort, sizeof(short));
4441 sv_setiv(sv, (IV)ashort);
4442 PUSHs(sv_2mortal(sv));
4450 #if SHORTSIZE > SIZE16
4456 sv_setiv(sv, (IV)ashort);
4457 PUSHs(sv_2mortal(sv));
4465 #if SHORTSIZE == SIZE16
4466 along = (strend - s) / SIZE16;
4468 unatint = natint && datumtype == 'S';
4469 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4474 #if SHORTSIZE != SIZE16
4476 unsigned short aushort;
4478 COPYNN(s, &aushort, sizeof(unsigned short));
4479 s += sizeof(unsigned short);
4487 COPY16(s, &aushort);
4490 if (datumtype == 'n')
4491 aushort = PerlSock_ntohs(aushort);
4494 if (datumtype == 'v')
4495 aushort = vtohs(aushort);
4504 #if SHORTSIZE != SIZE16
4506 unsigned short aushort;
4508 COPYNN(s, &aushort, sizeof(unsigned short));
4509 s += sizeof(unsigned short);
4511 sv_setiv(sv, (UV)aushort);
4512 PUSHs(sv_2mortal(sv));
4519 COPY16(s, &aushort);
4523 if (datumtype == 'n')
4524 aushort = PerlSock_ntohs(aushort);
4527 if (datumtype == 'v')
4528 aushort = vtohs(aushort);
4530 sv_setiv(sv, (UV)aushort);
4531 PUSHs(sv_2mortal(sv));
4537 along = (strend - s) / sizeof(int);
4542 Copy(s, &aint, 1, int);
4545 cdouble += (NV)aint;
4554 Copy(s, &aint, 1, int);
4558 /* Without the dummy below unpack("i", pack("i",-1))
4559 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4560 * cc with optimization turned on.
4562 * The bug was detected in
4563 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4564 * with optimization (-O4) turned on.
4565 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4566 * does not have this problem even with -O4.
4568 * This bug was reported as DECC_BUGS 1431
4569 * and tracked internally as GEM_BUGS 7775.
4571 * The bug is fixed in
4572 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4573 * UNIX V4.0F support: DEC C V5.9-006 or later
4574 * UNIX V4.0E support: DEC C V5.8-011 or later
4577 * See also few lines later for the same bug.
4580 sv_setiv(sv, (IV)aint) :
4582 sv_setiv(sv, (IV)aint);
4583 PUSHs(sv_2mortal(sv));
4588 along = (strend - s) / sizeof(unsigned int);
4593 Copy(s, &auint, 1, unsigned int);
4594 s += sizeof(unsigned int);
4596 cdouble += (NV)auint;
4605 Copy(s, &auint, 1, unsigned int);
4606 s += sizeof(unsigned int);
4609 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4610 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4611 * See details few lines earlier. */
4613 sv_setuv(sv, (UV)auint) :
4615 sv_setuv(sv, (UV)auint);
4616 PUSHs(sv_2mortal(sv));
4621 #if LONGSIZE == SIZE32
4622 along = (strend - s) / SIZE32;
4624 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4629 #if LONGSIZE != SIZE32
4632 COPYNN(s, &along, sizeof(long));
4635 cdouble += (NV)along;
4644 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4648 #if LONGSIZE > SIZE32
4649 if (along > 2147483647)
4650 along -= 4294967296;
4654 cdouble += (NV)along;
4663 #if LONGSIZE != SIZE32
4666 COPYNN(s, &along, sizeof(long));
4669 sv_setiv(sv, (IV)along);
4670 PUSHs(sv_2mortal(sv));
4677 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4681 #if LONGSIZE > SIZE32
4682 if (along > 2147483647)
4683 along -= 4294967296;
4687 sv_setiv(sv, (IV)along);
4688 PUSHs(sv_2mortal(sv));
4696 #if LONGSIZE == SIZE32
4697 along = (strend - s) / SIZE32;
4699 unatint = natint && datumtype == 'L';
4700 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4705 #if LONGSIZE != SIZE32
4707 unsigned long aulong;
4709 COPYNN(s, &aulong, sizeof(unsigned long));
4710 s += sizeof(unsigned long);
4712 cdouble += (NV)aulong;
4724 if (datumtype == 'N')
4725 aulong = PerlSock_ntohl(aulong);
4728 if (datumtype == 'V')
4729 aulong = vtohl(aulong);
4732 cdouble += (NV)aulong;
4741 #if LONGSIZE != SIZE32
4743 unsigned long aulong;
4745 COPYNN(s, &aulong, sizeof(unsigned long));
4746 s += sizeof(unsigned long);
4748 sv_setuv(sv, (UV)aulong);
4749 PUSHs(sv_2mortal(sv));
4759 if (datumtype == 'N')
4760 aulong = PerlSock_ntohl(aulong);
4763 if (datumtype == 'V')
4764 aulong = vtohl(aulong);
4767 sv_setuv(sv, (UV)aulong);
4768 PUSHs(sv_2mortal(sv));
4774 along = (strend - s) / sizeof(char*);
4780 if (sizeof(char*) > strend - s)
4783 Copy(s, &aptr, 1, char*);
4789 PUSHs(sv_2mortal(sv));
4799 while ((len > 0) && (s < strend)) {
4800 auv = (auv << 7) | (*s & 0x7f);
4801 if (UTF8_IS_ASCII(*s++)) {
4805 PUSHs(sv_2mortal(sv));
4809 else if (++bytes >= sizeof(UV)) { /* promote to string */
4813 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4814 while (s < strend) {
4815 sv = mul128(sv, *s & 0x7f);
4816 if (!(*s++ & 0x80)) {
4825 PUSHs(sv_2mortal(sv));
4830 if ((s >= strend) && bytes)
4831 DIE(aTHX_ "Unterminated compressed integer");
4836 if (sizeof(char*) > strend - s)
4839 Copy(s, &aptr, 1, char*);
4844 sv_setpvn(sv, aptr, len);
4845 PUSHs(sv_2mortal(sv));
4849 along = (strend - s) / sizeof(Quad_t);
4855 if (s + sizeof(Quad_t) > strend)
4858 Copy(s, &aquad, 1, Quad_t);
4859 s += sizeof(Quad_t);
4862 if (aquad >= IV_MIN && aquad <= IV_MAX)
4863 sv_setiv(sv, (IV)aquad);
4865 sv_setnv(sv, (NV)aquad);
4866 PUSHs(sv_2mortal(sv));
4870 along = (strend - s) / sizeof(Quad_t);
4876 if (s + sizeof(Uquad_t) > strend)
4879 Copy(s, &auquad, 1, Uquad_t);
4880 s += sizeof(Uquad_t);
4883 if (auquad <= UV_MAX)
4884 sv_setuv(sv, (UV)auquad);
4886 sv_setnv(sv, (NV)auquad);
4887 PUSHs(sv_2mortal(sv));
4891 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4894 along = (strend - s) / sizeof(float);
4899 Copy(s, &afloat, 1, float);
4908 Copy(s, &afloat, 1, float);
4911 sv_setnv(sv, (NV)afloat);
4912 PUSHs(sv_2mortal(sv));
4918 along = (strend - s) / sizeof(double);
4923 Copy(s, &adouble, 1, double);
4924 s += sizeof(double);
4932 Copy(s, &adouble, 1, double);
4933 s += sizeof(double);
4935 sv_setnv(sv, (NV)adouble);
4936 PUSHs(sv_2mortal(sv));
4942 * Initialise the decode mapping. By using a table driven
4943 * algorithm, the code will be character-set independent
4944 * (and just as fast as doing character arithmetic)
4946 if (PL_uudmap['M'] == 0) {
4949 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4950 PL_uudmap[(U8)PL_uuemap[i]] = i;
4952 * Because ' ' and '`' map to the same value,
4953 * we need to decode them both the same.
4958 along = (strend - s) * 3 / 4;
4959 sv = NEWSV(42, along);
4962 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4967 len = PL_uudmap[*(U8*)s++] & 077;
4969 if (s < strend && ISUUCHAR(*s))
4970 a = PL_uudmap[*(U8*)s++] & 077;
4973 if (s < strend && ISUUCHAR(*s))
4974 b = PL_uudmap[*(U8*)s++] & 077;
4977 if (s < strend && ISUUCHAR(*s))
4978 c = PL_uudmap[*(U8*)s++] & 077;
4981 if (s < strend && ISUUCHAR(*s))
4982 d = PL_uudmap[*(U8*)s++] & 077;
4985 hunk[0] = (a << 2) | (b >> 4);
4986 hunk[1] = (b << 4) | (c >> 2);
4987 hunk[2] = (c << 6) | d;
4988 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4993 else if (s[1] == '\n') /* possible checksum byte */
4996 XPUSHs(sv_2mortal(sv));
5001 if (strchr("fFdD", datumtype) ||
5002 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5006 while (checksum >= 16) {
5010 while (checksum >= 4) {
5016 along = (1 << checksum) - 1;
5017 while (cdouble < 0.0)
5019 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5020 sv_setnv(sv, cdouble);
5023 if (checksum < 32) {
5024 aulong = (1 << checksum) - 1;
5027 sv_setuv(sv, (UV)culong);
5029 XPUSHs(sv_2mortal(sv));
5033 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5034 PUSHs(&PL_sv_undef);
5039 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5043 *hunk = PL_uuemap[len];
5044 sv_catpvn(sv, hunk, 1);
5047 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5048 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5049 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5050 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5051 sv_catpvn(sv, hunk, 4);
5056 char r = (len > 1 ? s[1] : '\0');
5057 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5058 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5059 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5060 hunk[3] = PL_uuemap[0];
5061 sv_catpvn(sv, hunk, 4);
5063 sv_catpvn(sv, "\n", 1);
5067 S_is_an_int(pTHX_ char *s, STRLEN l)
5070 SV *result = newSVpvn(s, l);
5071 char *result_c = SvPV(result, n_a); /* convenience */
5072 char *out = result_c;
5082 SvREFCNT_dec(result);
5105 SvREFCNT_dec(result);
5111 SvCUR_set(result, out - result_c);
5115 /* pnum must be '\0' terminated */
5117 S_div128(pTHX_ SV *pnum, bool *done)
5120 char *s = SvPV(pnum, len);
5129 i = m * 10 + (*t - '0');
5131 r = (i >> 7); /* r < 10 */
5138 SvCUR_set(pnum, (STRLEN) (t - s));
5145 djSP; dMARK; dORIGMARK; dTARGET;
5146 register SV *cat = TARG;
5149 register char *pat = SvPVx(*++MARK, fromlen);
5151 register char *patend = pat + fromlen;
5156 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5157 static char *space10 = " ";
5159 /* These must not be in registers: */
5174 #ifdef PERL_NATINT_PACK
5175 int natint; /* native integer */
5180 sv_setpvn(cat, "", 0);
5182 while (pat < patend) {
5183 SV *lengthcode = Nullsv;
5184 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5185 datumtype = *pat++ & 0xFF;
5186 #ifdef PERL_NATINT_PACK
5189 if (isSPACE(datumtype)) {
5193 if (datumtype == 'U' && pat == patcopy+1)
5195 if (datumtype == '#') {
5196 while (pat < patend && *pat != '\n')
5201 char *natstr = "sSiIlL";
5203 if (strchr(natstr, datumtype)) {
5204 #ifdef PERL_NATINT_PACK
5210 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5213 len = strchr("@Xxu", datumtype) ? 0 : items;
5216 else if (isDIGIT(*pat)) {
5218 while (isDIGIT(*pat)) {
5219 len = (len * 10) + (*pat++ - '0');
5221 DIE(aTHX_ "Repeat count in pack overflows");
5228 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5229 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5230 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5231 ? *MARK : &PL_sv_no)
5232 + (*pat == 'Z' ? 1 : 0)));
5236 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5237 case ',': /* grandfather in commas but with a warning */
5238 if (commas++ == 0 && ckWARN(WARN_PACK))
5239 Perl_warner(aTHX_ WARN_PACK,
5240 "Invalid type in pack: '%c'", (int)datumtype);
5243 DIE(aTHX_ "%% may only be used in unpack");
5254 if (SvCUR(cat) < len)
5255 DIE(aTHX_ "X outside of string");
5262 sv_catpvn(cat, null10, 10);
5265 sv_catpvn(cat, null10, len);
5271 aptr = SvPV(fromstr, fromlen);
5272 if (pat[-1] == '*') {
5274 if (datumtype == 'Z')
5277 if (fromlen >= len) {
5278 sv_catpvn(cat, aptr, len);
5279 if (datumtype == 'Z')
5280 *(SvEND(cat)-1) = '\0';
5283 sv_catpvn(cat, aptr, fromlen);
5285 if (datumtype == 'A') {
5287 sv_catpvn(cat, space10, 10);
5290 sv_catpvn(cat, space10, len);
5294 sv_catpvn(cat, null10, 10);
5297 sv_catpvn(cat, null10, len);
5309 str = SvPV(fromstr, fromlen);
5313 SvCUR(cat) += (len+7)/8;
5314 SvGROW(cat, SvCUR(cat) + 1);
5315 aptr = SvPVX(cat) + aint;
5320 if (datumtype == 'B') {
5321 for (len = 0; len++ < aint;) {
5322 items |= *str++ & 1;
5326 *aptr++ = items & 0xff;
5332 for (len = 0; len++ < aint;) {
5338 *aptr++ = items & 0xff;
5344 if (datumtype == 'B')
5345 items <<= 7 - (aint & 7);
5347 items >>= 7 - (aint & 7);
5348 *aptr++ = items & 0xff;
5350 str = SvPVX(cat) + SvCUR(cat);
5365 str = SvPV(fromstr, fromlen);
5369 SvCUR(cat) += (len+1)/2;
5370 SvGROW(cat, SvCUR(cat) + 1);
5371 aptr = SvPVX(cat) + aint;
5376 if (datumtype == 'H') {
5377 for (len = 0; len++ < aint;) {
5379 items |= ((*str++ & 15) + 9) & 15;
5381 items |= *str++ & 15;
5385 *aptr++ = items & 0xff;
5391 for (len = 0; len++ < aint;) {
5393 items |= (((*str++ & 15) + 9) & 15) << 4;
5395 items |= (*str++ & 15) << 4;
5399 *aptr++ = items & 0xff;
5405 *aptr++ = items & 0xff;
5406 str = SvPVX(cat) + SvCUR(cat);
5417 aint = SvIV(fromstr);
5419 sv_catpvn(cat, &achar, sizeof(char));
5425 auint = SvUV(fromstr);
5426 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5427 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
5432 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5437 afloat = (float)SvNV(fromstr);
5438 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5445 adouble = (double)SvNV(fromstr);
5446 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5452 ashort = (I16)SvIV(fromstr);
5454 ashort = PerlSock_htons(ashort);
5456 CAT16(cat, &ashort);
5462 ashort = (I16)SvIV(fromstr);
5464 ashort = htovs(ashort);
5466 CAT16(cat, &ashort);
5470 #if SHORTSIZE != SIZE16
5472 unsigned short aushort;
5476 aushort = SvUV(fromstr);
5477 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5487 aushort = (U16)SvUV(fromstr);
5488 CAT16(cat, &aushort);
5494 #if SHORTSIZE != SIZE16
5500 ashort = SvIV(fromstr);
5501 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5509 ashort = (I16)SvIV(fromstr);
5510 CAT16(cat, &ashort);
5517 auint = SvUV(fromstr);
5518 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5524 adouble = Perl_floor(SvNV(fromstr));
5527 DIE(aTHX_ "Cannot compress negative numbers");
5530 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5531 adouble <= 0xffffffff
5533 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5534 adouble <= UV_MAX_cxux
5541 char buf[1 + sizeof(UV)];
5542 char *in = buf + sizeof(buf);
5543 UV auv = U_V(adouble);
5546 *--in = (auv & 0x7f) | 0x80;
5549 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5550 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5552 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5553 char *from, *result, *in;
5558 /* Copy string and check for compliance */
5559 from = SvPV(fromstr, len);
5560 if ((norm = is_an_int(from, len)) == NULL)
5561 DIE(aTHX_ "can compress only unsigned integer");
5563 New('w', result, len, char);
5567 *--in = div128(norm, &done) | 0x80;
5568 result[len - 1] &= 0x7F; /* clear continue bit */
5569 sv_catpvn(cat, in, (result + len) - in);
5571 SvREFCNT_dec(norm); /* free norm */
5573 else if (SvNOKp(fromstr)) {
5574 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5575 char *in = buf + sizeof(buf);
5578 double next = floor(adouble / 128);
5579 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5580 if (in <= buf) /* this cannot happen ;-) */
5581 DIE(aTHX_ "Cannot compress integer");
5584 } while (adouble > 0);
5585 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5586 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5589 DIE(aTHX_ "Cannot compress non integer");
5595 aint = SvIV(fromstr);
5596 sv_catpvn(cat, (char*)&aint, sizeof(int));
5602 aulong = SvUV(fromstr);
5604 aulong = PerlSock_htonl(aulong);
5606 CAT32(cat, &aulong);
5612 aulong = SvUV(fromstr);
5614 aulong = htovl(aulong);
5616 CAT32(cat, &aulong);
5620 #if LONGSIZE != SIZE32
5622 unsigned long aulong;
5626 aulong = SvUV(fromstr);
5627 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5635 aulong = SvUV(fromstr);
5636 CAT32(cat, &aulong);
5641 #if LONGSIZE != SIZE32
5647 along = SvIV(fromstr);
5648 sv_catpvn(cat, (char *)&along, sizeof(long));
5656 along = SvIV(fromstr);
5665 auquad = (Uquad_t)SvUV(fromstr);
5666 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5672 aquad = (Quad_t)SvIV(fromstr);
5673 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5678 len = 1; /* assume SV is correct length */
5683 if (fromstr == &PL_sv_undef)
5687 /* XXX better yet, could spirit away the string to
5688 * a safe spot and hang on to it until the result
5689 * of pack() (and all copies of the result) are
5692 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5693 || (SvPADTMP(fromstr)
5694 && !SvREADONLY(fromstr))))
5696 Perl_warner(aTHX_ WARN_PACK,
5697 "Attempt to pack pointer to temporary value");
5699 if (SvPOK(fromstr) || SvNIOK(fromstr))
5700 aptr = SvPV(fromstr,n_a);
5702 aptr = SvPV_force(fromstr,n_a);
5704 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5709 aptr = SvPV(fromstr, fromlen);
5710 SvGROW(cat, fromlen * 4 / 3);
5715 while (fromlen > 0) {
5722 doencodes(cat, aptr, todo);
5741 register IV limit = POPi; /* note, negative is forever */
5744 register char *s = SvPV(sv, len);
5745 bool do_utf8 = DO_UTF8(sv);
5746 char *strend = s + len;
5748 register REGEXP *rx;
5752 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5753 I32 maxiters = slen + 10;
5756 I32 origlimit = limit;
5759 AV *oldstack = PL_curstack;
5760 I32 gimme = GIMME_V;
5761 I32 oldsave = PL_savestack_ix;
5762 I32 make_mortal = 1;
5763 MAGIC *mg = (MAGIC *) NULL;
5766 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5771 DIE(aTHX_ "panic: pp_split");
5772 rx = pm->op_pmregexp;
5774 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5775 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5777 if (pm->op_pmreplroot) {
5779 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5781 ary = GvAVn((GV*)pm->op_pmreplroot);
5784 else if (gimme != G_ARRAY)
5786 ary = (AV*)PL_curpad[0];
5788 ary = GvAVn(PL_defgv);
5789 #endif /* USE_THREADS */
5792 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5798 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5800 XPUSHs(SvTIED_obj((SV*)ary, mg));
5806 for (i = AvFILLp(ary); i >= 0; i--)
5807 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5809 /* temporarily switch stacks */
5810 SWITCHSTACK(PL_curstack, ary);
5814 base = SP - PL_stack_base;
5816 if (pm->op_pmflags & PMf_SKIPWHITE) {
5817 if (pm->op_pmflags & PMf_LOCALE) {
5818 while (isSPACE_LC(*s))
5826 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5827 SAVEINT(PL_multiline);
5828 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5832 limit = maxiters + 2;
5833 if (pm->op_pmflags & PMf_WHITE) {
5836 while (m < strend &&
5837 !((pm->op_pmflags & PMf_LOCALE)
5838 ? isSPACE_LC(*m) : isSPACE(*m)))
5843 dstr = NEWSV(30, m-s);
5844 sv_setpvn(dstr, s, m-s);
5848 (void)SvUTF8_on(dstr);
5852 while (s < strend &&
5853 ((pm->op_pmflags & PMf_LOCALE)
5854 ? isSPACE_LC(*s) : isSPACE(*s)))
5858 else if (strEQ("^", rx->precomp)) {
5861 for (m = s; m < strend && *m != '\n'; m++) ;
5865 dstr = NEWSV(30, m-s);
5866 sv_setpvn(dstr, s, m-s);
5870 (void)SvUTF8_on(dstr);
5875 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5876 && (rx->reganch & ROPT_CHECK_ALL)
5877 && !(rx->reganch & ROPT_ANCH)) {
5878 int tail = (rx->reganch & RE_INTUIT_TAIL);
5879 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5882 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5884 char c = *SvPV(csv, n_a);
5887 for (m = s; m < strend && *m != c; m++) ;
5890 dstr = NEWSV(30, m-s);
5891 sv_setpvn(dstr, s, m-s);
5895 (void)SvUTF8_on(dstr);
5897 /* The rx->minlen is in characters but we want to step
5898 * s ahead by bytes. */
5900 s = (char*)utf8_hop((U8*)m, len);
5902 s = m + len; /* Fake \n at the end */
5907 while (s < strend && --limit &&
5908 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5909 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5912 dstr = NEWSV(31, m-s);
5913 sv_setpvn(dstr, s, m-s);
5917 (void)SvUTF8_on(dstr);
5919 /* The rx->minlen is in characters but we want to step
5920 * s ahead by bytes. */
5922 s = (char*)utf8_hop((U8*)m, len);
5924 s = m + len; /* Fake \n at the end */
5929 maxiters += slen * rx->nparens;
5930 while (s < strend && --limit
5931 /* && (!rx->check_substr
5932 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5934 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5935 1 /* minend */, sv, NULL, 0))
5937 TAINT_IF(RX_MATCH_TAINTED(rx));
5938 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5943 strend = s + (strend - m);
5945 m = rx->startp[0] + orig;
5946 dstr = NEWSV(32, m-s);
5947 sv_setpvn(dstr, s, m-s);
5951 (void)SvUTF8_on(dstr);
5954 for (i = 1; i <= rx->nparens; i++) {
5955 s = rx->startp[i] + orig;
5956 m = rx->endp[i] + orig;
5958 dstr = NEWSV(33, m-s);
5959 sv_setpvn(dstr, s, m-s);
5962 dstr = NEWSV(33, 0);
5966 (void)SvUTF8_on(dstr);
5970 s = rx->endp[0] + orig;
5974 LEAVE_SCOPE(oldsave);
5975 iters = (SP - PL_stack_base) - base;
5976 if (iters > maxiters)
5977 DIE(aTHX_ "Split loop");
5979 /* keep field after final delim? */
5980 if (s < strend || (iters && origlimit)) {
5981 STRLEN l = strend - s;
5982 dstr = NEWSV(34, l);
5983 sv_setpvn(dstr, s, l);
5987 (void)SvUTF8_on(dstr);
5991 else if (!origlimit) {
5992 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5998 SWITCHSTACK(ary, oldstack);
5999 if (SvSMAGICAL(ary)) {
6004 if (gimme == G_ARRAY) {
6006 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6014 call_method("PUSH",G_SCALAR|G_DISCARD);
6017 if (gimme == G_ARRAY) {
6018 /* EXTEND should not be needed - we just popped them */
6020 for (i=0; i < iters; i++) {
6021 SV **svp = av_fetch(ary, i, FALSE);
6022 PUSHs((svp) ? *svp : &PL_sv_undef);
6029 if (gimme == G_ARRAY)
6032 if (iters || !pm->op_pmreplroot) {
6042 Perl_unlock_condpair(pTHX_ void *svv)
6044 MAGIC *mg = mg_find((SV*)svv, 'm');
6047 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6048 MUTEX_LOCK(MgMUTEXP(mg));
6049 if (MgOWNER(mg) != thr)
6050 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6052 COND_SIGNAL(MgOWNERCONDP(mg));
6053 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6054 PTR2UV(thr), PTR2UV(svv));)
6055 MUTEX_UNLOCK(MgMUTEXP(mg));
6057 #endif /* USE_THREADS */
6066 #endif /* USE_THREADS */
6067 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6068 || SvTYPE(retsv) == SVt_PVCV) {
6069 retsv = refto(retsv);
6080 if (PL_op->op_private & OPpLVAL_INTRO)
6081 PUSHs(*save_threadsv(PL_op->op_targ));
6083 PUSHs(THREADSV(PL_op->op_targ));
6086 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6087 #endif /* USE_THREADS */