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 */
1207 SvSetSV(TARG, tmpstr);
1208 SvPV_force(TARG, len);
1209 isutf = DO_UTF8(TARG);
1214 SvGROW(TARG, (count * len) + 1);
1215 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1216 SvCUR(TARG) *= count;
1218 *SvEND(TARG) = '\0';
1221 (void)SvPOK_only_UTF8(TARG);
1223 (void)SvPOK_only(TARG);
1232 djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1233 useleft = USE_LEFT(TOPm1s);
1234 #ifdef PERL_PRESERVE_IVUV
1235 /* We must see if we can perform the addition with integers if possible,
1236 as the integer code detects overflow while the NV code doesn't.
1237 If either argument hasn't had a numeric conversion yet attempt to get
1238 the IV. It's important to do this now, rather than just assuming that
1239 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1240 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1241 integer in case the second argument is IV=9223372036854775806
1242 We can (now) rely on sv_2iv to do the right thing, only setting the
1243 public IOK flag if the value in the NV (or PV) slot is truly integer.
1245 A side effect is that this also aggressively prefers integer maths over
1246 fp maths for integer values. */
1249 /* Unless the left argument is integer in range we are going to have to
1250 use NV maths. Hence only attempt to coerce the right argument if
1251 we know the left is integer. */
1253 /* left operand is undef, treat as zero. + 0 is identity. */
1255 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
1256 if (value <= (UV)IV_MIN) {
1257 /* 2s complement assumption. */
1260 } /* else drop through into NVs below */
1267 /* Left operand is defined, so is it IV? */
1268 SvIV_please(TOPm1s);
1269 if (SvIOK(TOPm1s)) {
1270 bool auvok = SvUOK(TOPm1s);
1271 bool buvok = SvUOK(TOPs);
1273 if (!auvok && !buvok) { /* ## IV - IV ## */
1274 IV aiv = SvIVX(TOPm1s);
1275 IV biv = SvIVX(TOPs);
1276 IV result = aiv - biv;
1278 if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
1283 /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
1284 /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
1285 /* -ve - +ve can only overflow too negative. */
1286 /* leaving +ve - -ve, which will go UV */
1287 if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
1288 /* 2s complement assumption for IV_MIN */
1289 UV result = (UV)aiv + (UV)-biv;
1290 /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
1291 overflow UV (2s complement assumption */
1292 assert (result >= (UV) aiv);
1297 /* Overflow, drop through to NVs */
1298 } else if (auvok && buvok) { /* ## UV - UV ## */
1299 UV auv = SvUVX(TOPm1s);
1300 UV buv = SvUVX(TOPs);
1308 /* Blatant 2s complement assumption. */
1309 result = (IV)(auv - buv);
1315 /* Overflow on IV - IV, drop through to NVs */
1316 } else if (auvok) { /* ## Mixed UV - IV ## */
1317 UV auv = SvUVX(TOPm1s);
1318 IV biv = SvIVX(TOPs);
1321 /* 2s complement assumptions for IV_MIN */
1322 UV result = auv + ((UV)-biv);
1323 /* UV + UV can only get bigger... */
1324 if (result >= auv) {
1329 /* and if it gets too big for UV then it's NV time. */
1330 } else if (auv > (UV)IV_MAX) {
1331 /* I think I'm making an implicit 2s complement
1332 assumption that IV_MIN == -IV_MAX - 1 */
1334 UV result = auv - (UV)biv;
1335 assert (result <= auv);
1341 IV result = (IV)auv - biv;
1342 assert (result <= (IV)auv);
1347 } else { /* ## Mixed IV - UV ## */
1348 IV aiv = SvIVX(TOPm1s);
1349 UV buv = SvUVX(TOPs);
1350 IV result = aiv - (IV)buv; /* 2s complement assumption. */
1352 /* result must not get larger. */
1353 if (result <= aiv) {
1357 } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
1366 /* left operand is undef, treat as zero - value */
1370 SETn( TOPn - value );
1377 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1380 if (PL_op->op_private & HINT_INTEGER) {
1394 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1397 if (PL_op->op_private & HINT_INTEGER) {
1411 djSP; tryAMAGICbinSET(lt,0);
1412 #ifdef PERL_PRESERVE_IVUV
1415 SvIV_please(TOPm1s);
1416 if (SvIOK(TOPm1s)) {
1417 bool auvok = SvUOK(TOPm1s);
1418 bool buvok = SvUOK(TOPs);
1420 if (!auvok && !buvok) { /* ## IV < IV ## */
1421 IV aiv = SvIVX(TOPm1s);
1422 IV biv = SvIVX(TOPs);
1425 SETs(boolSV(aiv < biv));
1428 if (auvok && buvok) { /* ## UV < UV ## */
1429 UV auv = SvUVX(TOPm1s);
1430 UV buv = SvUVX(TOPs);
1433 SETs(boolSV(auv < buv));
1436 if (auvok) { /* ## UV < IV ## */
1443 /* As (a) is a UV, it's >=0, so it cannot be < */
1448 if (auv >= (UV) IV_MAX) {
1449 /* As (b) is an IV, it cannot be > IV_MAX */
1453 SETs(boolSV(auv < (UV)biv));
1456 { /* ## IV < UV ## */
1460 aiv = SvIVX(TOPm1s);
1462 /* As (b) is a UV, it's >=0, so it must be < */
1469 if (buv > (UV) IV_MAX) {
1470 /* As (a) is an IV, it cannot be > IV_MAX */
1474 SETs(boolSV((UV)aiv < buv));
1482 SETs(boolSV(TOPn < value));
1489 djSP; tryAMAGICbinSET(gt,0);
1490 #ifdef PERL_PRESERVE_IVUV
1493 SvIV_please(TOPm1s);
1494 if (SvIOK(TOPm1s)) {
1495 bool auvok = SvUOK(TOPm1s);
1496 bool buvok = SvUOK(TOPs);
1498 if (!auvok && !buvok) { /* ## IV > IV ## */
1499 IV aiv = SvIVX(TOPm1s);
1500 IV biv = SvIVX(TOPs);
1503 SETs(boolSV(aiv > biv));
1506 if (auvok && buvok) { /* ## UV > UV ## */
1507 UV auv = SvUVX(TOPm1s);
1508 UV buv = SvUVX(TOPs);
1511 SETs(boolSV(auv > buv));
1514 if (auvok) { /* ## UV > IV ## */
1521 /* As (a) is a UV, it's >=0, so it must be > */
1526 if (auv > (UV) IV_MAX) {
1527 /* As (b) is an IV, it cannot be > IV_MAX */
1531 SETs(boolSV(auv > (UV)biv));
1534 { /* ## IV > UV ## */
1538 aiv = SvIVX(TOPm1s);
1540 /* As (b) is a UV, it's >=0, so it cannot be > */
1547 if (buv >= (UV) IV_MAX) {
1548 /* As (a) is an IV, it cannot be > IV_MAX */
1552 SETs(boolSV((UV)aiv > buv));
1560 SETs(boolSV(TOPn > value));
1567 djSP; tryAMAGICbinSET(le,0);
1568 #ifdef PERL_PRESERVE_IVUV
1571 SvIV_please(TOPm1s);
1572 if (SvIOK(TOPm1s)) {
1573 bool auvok = SvUOK(TOPm1s);
1574 bool buvok = SvUOK(TOPs);
1576 if (!auvok && !buvok) { /* ## IV <= IV ## */
1577 IV aiv = SvIVX(TOPm1s);
1578 IV biv = SvIVX(TOPs);
1581 SETs(boolSV(aiv <= biv));
1584 if (auvok && buvok) { /* ## UV <= UV ## */
1585 UV auv = SvUVX(TOPm1s);
1586 UV buv = SvUVX(TOPs);
1589 SETs(boolSV(auv <= buv));
1592 if (auvok) { /* ## UV <= IV ## */
1599 /* As (a) is a UV, it's >=0, so a cannot be <= */
1604 if (auv > (UV) IV_MAX) {
1605 /* As (b) is an IV, it cannot be > IV_MAX */
1609 SETs(boolSV(auv <= (UV)biv));
1612 { /* ## IV <= UV ## */
1616 aiv = SvIVX(TOPm1s);
1618 /* As (b) is a UV, it's >=0, so a must be <= */
1625 if (buv >= (UV) IV_MAX) {
1626 /* As (a) is an IV, it cannot be > IV_MAX */
1630 SETs(boolSV((UV)aiv <= buv));
1638 SETs(boolSV(TOPn <= value));
1645 djSP; tryAMAGICbinSET(ge,0);
1646 #ifdef PERL_PRESERVE_IVUV
1649 SvIV_please(TOPm1s);
1650 if (SvIOK(TOPm1s)) {
1651 bool auvok = SvUOK(TOPm1s);
1652 bool buvok = SvUOK(TOPs);
1654 if (!auvok && !buvok) { /* ## IV >= IV ## */
1655 IV aiv = SvIVX(TOPm1s);
1656 IV biv = SvIVX(TOPs);
1659 SETs(boolSV(aiv >= biv));
1662 if (auvok && buvok) { /* ## UV >= UV ## */
1663 UV auv = SvUVX(TOPm1s);
1664 UV buv = SvUVX(TOPs);
1667 SETs(boolSV(auv >= buv));
1670 if (auvok) { /* ## UV >= IV ## */
1677 /* As (a) is a UV, it's >=0, so it must be >= */
1682 if (auv >= (UV) IV_MAX) {
1683 /* As (b) is an IV, it cannot be > IV_MAX */
1687 SETs(boolSV(auv >= (UV)biv));
1690 { /* ## IV >= UV ## */
1694 aiv = SvIVX(TOPm1s);
1696 /* As (b) is a UV, it's >=0, so a cannot be >= */
1703 if (buv > (UV) IV_MAX) {
1704 /* As (a) is an IV, it cannot be > IV_MAX */
1708 SETs(boolSV((UV)aiv >= buv));
1716 SETs(boolSV(TOPn >= value));
1723 djSP; tryAMAGICbinSET(ne,0);
1724 #ifdef PERL_PRESERVE_IVUV
1727 SvIV_please(TOPm1s);
1728 if (SvIOK(TOPm1s)) {
1729 bool auvok = SvUOK(TOPm1s);
1730 bool buvok = SvUOK(TOPs);
1732 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1733 IV aiv = SvIVX(TOPm1s);
1734 IV biv = SvIVX(TOPs);
1737 SETs(boolSV(aiv != biv));
1740 if (auvok && buvok) { /* ## UV != UV ## */
1741 UV auv = SvUVX(TOPm1s);
1742 UV buv = SvUVX(TOPs);
1745 SETs(boolSV(auv != buv));
1748 { /* ## Mixed IV,UV ## */
1752 /* != is commutative so swap if needed (save code) */
1754 /* swap. top of stack (b) is the iv */
1758 /* As (a) is a UV, it's >0, so it cannot be == */
1767 /* As (b) is a UV, it's >0, so it cannot be == */
1771 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1773 /* we know iv is >= 0 */
1774 if (uv > (UV) IV_MAX) {
1778 SETs(boolSV((UV)iv != uv));
1786 SETs(boolSV(TOPn != value));
1793 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1794 #ifdef PERL_PRESERVE_IVUV
1795 /* Fortunately it seems NaN isn't IOK */
1798 SvIV_please(TOPm1s);
1799 if (SvIOK(TOPm1s)) {
1800 bool leftuvok = SvUOK(TOPm1s);
1801 bool rightuvok = SvUOK(TOPs);
1803 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1804 IV leftiv = SvIVX(TOPm1s);
1805 IV rightiv = SvIVX(TOPs);
1807 if (leftiv > rightiv)
1809 else if (leftiv < rightiv)
1813 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1814 UV leftuv = SvUVX(TOPm1s);
1815 UV rightuv = SvUVX(TOPs);
1817 if (leftuv > rightuv)
1819 else if (leftuv < rightuv)
1823 } else if (leftuvok) { /* ## UV <=> IV ## */
1827 rightiv = SvIVX(TOPs);
1829 /* As (a) is a UV, it's >=0, so it cannot be < */
1832 leftuv = SvUVX(TOPm1s);
1833 if (leftuv > (UV) IV_MAX) {
1834 /* As (b) is an IV, it cannot be > IV_MAX */
1836 } else if (leftuv > (UV)rightiv) {
1838 } else if (leftuv < (UV)rightiv) {
1844 } else { /* ## IV <=> UV ## */
1848 leftiv = SvIVX(TOPm1s);
1850 /* As (b) is a UV, it's >=0, so it must be < */
1853 rightuv = SvUVX(TOPs);
1854 if (rightuv > (UV) IV_MAX) {
1855 /* As (a) is an IV, it cannot be > IV_MAX */
1857 } else if (leftiv > (UV)rightuv) {
1859 } else if (leftiv < (UV)rightuv) {
1877 if (Perl_isnan(left) || Perl_isnan(right)) {
1881 value = (left > right) - (left < right);
1885 else if (left < right)
1887 else if (left > right)
1901 djSP; tryAMAGICbinSET(slt,0);
1904 int cmp = ((PL_op->op_private & OPpLOCALE)
1905 ? sv_cmp_locale(left, right)
1906 : sv_cmp(left, right));
1907 SETs(boolSV(cmp < 0));
1914 djSP; tryAMAGICbinSET(sgt,0);
1917 int cmp = ((PL_op->op_private & OPpLOCALE)
1918 ? sv_cmp_locale(left, right)
1919 : sv_cmp(left, right));
1920 SETs(boolSV(cmp > 0));
1927 djSP; tryAMAGICbinSET(sle,0);
1930 int cmp = ((PL_op->op_private & OPpLOCALE)
1931 ? sv_cmp_locale(left, right)
1932 : sv_cmp(left, right));
1933 SETs(boolSV(cmp <= 0));
1940 djSP; tryAMAGICbinSET(sge,0);
1943 int cmp = ((PL_op->op_private & OPpLOCALE)
1944 ? sv_cmp_locale(left, right)
1945 : sv_cmp(left, right));
1946 SETs(boolSV(cmp >= 0));
1953 djSP; tryAMAGICbinSET(seq,0);
1956 SETs(boolSV(sv_eq(left, right)));
1963 djSP; tryAMAGICbinSET(sne,0);
1966 SETs(boolSV(!sv_eq(left, right)));
1973 djSP; dTARGET; tryAMAGICbin(scmp,0);
1976 int cmp = ((PL_op->op_private & OPpLOCALE)
1977 ? sv_cmp_locale(left, right)
1978 : sv_cmp(left, right));
1986 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1989 if (SvNIOKp(left) || SvNIOKp(right)) {
1990 if (PL_op->op_private & HINT_INTEGER) {
1991 IV i = SvIV(left) & SvIV(right);
1995 UV u = SvUV(left) & SvUV(right);
2000 do_vop(PL_op->op_type, TARG, left, right);
2009 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2012 if (SvNIOKp(left) || SvNIOKp(right)) {
2013 if (PL_op->op_private & HINT_INTEGER) {
2014 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2018 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2023 do_vop(PL_op->op_type, TARG, left, right);
2032 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2035 if (SvNIOKp(left) || SvNIOKp(right)) {
2036 if (PL_op->op_private & HINT_INTEGER) {
2037 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2041 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2046 do_vop(PL_op->op_type, TARG, left, right);
2055 djSP; dTARGET; tryAMAGICun(neg);
2058 int flags = SvFLAGS(sv);
2061 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2062 /* It's publicly an integer, or privately an integer-not-float */
2065 if (SvIVX(sv) == IV_MIN) {
2066 /* 2s complement assumption. */
2067 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2070 else if (SvUVX(sv) <= IV_MAX) {
2075 else if (SvIVX(sv) != IV_MIN) {
2079 #ifdef PERL_PRESERVE_IVUV
2088 else if (SvPOKp(sv)) {
2090 char *s = SvPV(sv, len);
2091 if (isIDFIRST(*s)) {
2092 sv_setpvn(TARG, "-", 1);
2095 else if (*s == '+' || *s == '-') {
2097 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2099 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2100 sv_setpvn(TARG, "-", 1);
2106 goto oops_its_an_int;
2107 sv_setnv(TARG, -SvNV(sv));
2119 djSP; tryAMAGICunSET(not);
2120 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2126 djSP; dTARGET; tryAMAGICun(compl);
2130 if (PL_op->op_private & HINT_INTEGER) {
2145 tmps = (U8*)SvPV_force(TARG, len);
2148 /* Calculate exact length, let's not estimate. */
2157 while (tmps < send) {
2158 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2159 tmps += UTF8SKIP(tmps);
2160 targlen += UNISKIP(~c);
2166 /* Now rewind strings and write them. */
2170 Newz(0, result, targlen + 1, U8);
2171 while (tmps < send) {
2172 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2173 tmps += UTF8SKIP(tmps);
2174 result = uv_to_utf8(result, ~c);
2178 sv_setpvn(TARG, (char*)result, targlen);
2182 Newz(0, result, nchar + 1, U8);
2183 while (tmps < send) {
2184 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
2185 tmps += UTF8SKIP(tmps);
2190 sv_setpvn(TARG, (char*)result, nchar);
2198 register long *tmpl;
2199 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2202 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2207 for ( ; anum > 0; anum--, tmps++)
2216 /* integer versions of some of the above */
2220 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2223 SETi( left * right );
2230 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2234 DIE(aTHX_ "Illegal division by zero");
2235 value = POPi / value;
2243 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2247 DIE(aTHX_ "Illegal modulus zero");
2248 SETi( left % right );
2255 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2258 SETi( left + right );
2265 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2268 SETi( left - right );
2275 djSP; tryAMAGICbinSET(lt,0);
2278 SETs(boolSV(left < right));
2285 djSP; tryAMAGICbinSET(gt,0);
2288 SETs(boolSV(left > right));
2295 djSP; tryAMAGICbinSET(le,0);
2298 SETs(boolSV(left <= right));
2305 djSP; tryAMAGICbinSET(ge,0);
2308 SETs(boolSV(left >= right));
2315 djSP; tryAMAGICbinSET(eq,0);
2318 SETs(boolSV(left == right));
2325 djSP; tryAMAGICbinSET(ne,0);
2328 SETs(boolSV(left != right));
2335 djSP; dTARGET; tryAMAGICbin(ncmp,0);
2342 else if (left < right)
2353 djSP; dTARGET; tryAMAGICun(neg);
2358 /* High falutin' math. */
2362 djSP; dTARGET; tryAMAGICbin(atan2,0);
2365 SETn(Perl_atan2(left, right));
2372 djSP; dTARGET; tryAMAGICun(sin);
2376 value = Perl_sin(value);
2384 djSP; dTARGET; tryAMAGICun(cos);
2388 value = Perl_cos(value);
2394 /* Support Configure command-line overrides for rand() functions.
2395 After 5.005, perhaps we should replace this by Configure support
2396 for drand48(), random(), or rand(). For 5.005, though, maintain
2397 compatibility by calling rand() but allow the user to override it.
2398 See INSTALL for details. --Andy Dougherty 15 July 1998
2400 /* Now it's after 5.005, and Configure supports drand48() and random(),
2401 in addition to rand(). So the overrides should not be needed any more.
2402 --Jarkko Hietaniemi 27 September 1998
2405 #ifndef HAS_DRAND48_PROTO
2406 extern double drand48 (void);
2419 if (!PL_srand_called) {
2420 (void)seedDrand01((Rand_seed_t)seed());
2421 PL_srand_called = TRUE;
2436 (void)seedDrand01((Rand_seed_t)anum);
2437 PL_srand_called = TRUE;
2446 * This is really just a quick hack which grabs various garbage
2447 * values. It really should be a real hash algorithm which
2448 * spreads the effect of every input bit onto every output bit,
2449 * if someone who knows about such things would bother to write it.
2450 * Might be a good idea to add that function to CORE as well.
2451 * No numbers below come from careful analysis or anything here,
2452 * except they are primes and SEED_C1 > 1E6 to get a full-width
2453 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2454 * probably be bigger too.
2457 # define SEED_C1 1000003
2458 #define SEED_C4 73819
2460 # define SEED_C1 25747
2461 #define SEED_C4 20639
2465 #define SEED_C5 26107
2467 #ifndef PERL_NO_DEV_RANDOM
2472 # include <starlet.h>
2473 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2474 * in 100-ns units, typically incremented ever 10 ms. */
2475 unsigned int when[2];
2477 # ifdef HAS_GETTIMEOFDAY
2478 struct timeval when;
2484 /* This test is an escape hatch, this symbol isn't set by Configure. */
2485 #ifndef PERL_NO_DEV_RANDOM
2486 #ifndef PERL_RANDOM_DEVICE
2487 /* /dev/random isn't used by default because reads from it will block
2488 * if there isn't enough entropy available. You can compile with
2489 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2490 * is enough real entropy to fill the seed. */
2491 # define PERL_RANDOM_DEVICE "/dev/urandom"
2493 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2495 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2504 _ckvmssts(sys$gettim(when));
2505 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2507 # ifdef HAS_GETTIMEOFDAY
2508 gettimeofday(&when,(struct timezone *) 0);
2509 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2512 u = (U32)SEED_C1 * when;
2515 u += SEED_C3 * (U32)PerlProc_getpid();
2516 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2517 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2518 u += SEED_C5 * (U32)PTR2UV(&when);
2525 djSP; dTARGET; tryAMAGICun(exp);
2529 value = Perl_exp(value);
2537 djSP; dTARGET; tryAMAGICun(log);
2542 SET_NUMERIC_STANDARD();
2543 DIE(aTHX_ "Can't take log of %g", value);
2545 value = Perl_log(value);
2553 djSP; dTARGET; tryAMAGICun(sqrt);
2558 SET_NUMERIC_STANDARD();
2559 DIE(aTHX_ "Can't take sqrt of %g", value);
2561 value = Perl_sqrt(value);
2572 IV iv = TOPi; /* attempt to convert to IV if possible. */
2573 /* XXX it's arguable that compiler casting to IV might be subtly
2574 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2575 else preferring IV has introduced a subtle behaviour change bug. OTOH
2576 relying on floating point to be accurate is a bug. */
2587 if (value < (NV)UV_MAX + 0.5) {
2590 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2591 (void)Perl_modf(value, &value);
2593 double tmp = (double)value;
2594 (void)Perl_modf(tmp, &tmp);
2600 if (value > (NV)IV_MIN - 0.5) {
2603 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2604 (void)Perl_modf(-value, &value);
2607 double tmp = (double)value;
2608 (void)Perl_modf(-tmp, &tmp);
2621 djSP; dTARGET; tryAMAGICun(abs);
2623 /* This will cache the NV value if string isn't actually integer */
2627 /* IVX is precise */
2629 SETu(TOPu); /* force it to be numeric only */
2637 /* 2s complement assumption. Also, not really needed as
2638 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2661 argtype = 1; /* allow underscores */
2662 XPUSHn(scan_hex(tmps, 99, &argtype));
2675 while (*tmps && isSPACE(*tmps))
2679 argtype = 1; /* allow underscores */
2681 value = scan_hex(++tmps, 99, &argtype);
2682 else if (*tmps == 'b')
2683 value = scan_bin(++tmps, 99, &argtype);
2685 value = scan_oct(tmps, 99, &argtype);
2698 SETi(sv_len_utf8(sv));
2714 I32 lvalue = PL_op->op_flags & OPf_MOD;
2716 I32 arybase = PL_curcop->cop_arybase;
2720 SvTAINTED_off(TARG); /* decontaminate */
2721 SvUTF8_off(TARG); /* decontaminate */
2725 repl = SvPV(sv, repl_len);
2732 tmps = SvPV(sv, curlen);
2734 utfcurlen = sv_len_utf8(sv);
2735 if (utfcurlen == curlen)
2743 if (pos >= arybase) {
2761 else if (len >= 0) {
2763 if (rem > (I32)curlen)
2778 Perl_croak(aTHX_ "substr outside of string");
2779 if (ckWARN(WARN_SUBSTR))
2780 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2785 sv_pos_u2b(sv, &pos, &rem);
2787 sv_setpvn(TARG, tmps, rem);
2791 sv_insert(sv, pos, rem, repl, repl_len);
2792 else if (lvalue) { /* it's an lvalue! */
2793 if (!SvGMAGICAL(sv)) {
2797 if (ckWARN(WARN_SUBSTR))
2798 Perl_warner(aTHX_ WARN_SUBSTR,
2799 "Attempt to use reference as lvalue in substr");
2801 if (SvOK(sv)) /* is it defined ? */
2802 (void)SvPOK_only_UTF8(sv);
2804 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2807 if (SvTYPE(TARG) < SVt_PVLV) {
2808 sv_upgrade(TARG, SVt_PVLV);
2809 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2813 if (LvTARG(TARG) != sv) {
2815 SvREFCNT_dec(LvTARG(TARG));
2816 LvTARG(TARG) = SvREFCNT_inc(sv);
2818 LvTARGOFF(TARG) = pos;
2819 LvTARGLEN(TARG) = rem;
2823 PUSHs(TARG); /* avoid SvSETMAGIC here */
2830 register IV size = POPi;
2831 register IV offset = POPi;
2832 register SV *src = POPs;
2833 I32 lvalue = PL_op->op_flags & OPf_MOD;
2835 SvTAINTED_off(TARG); /* decontaminate */
2836 if (lvalue) { /* it's an lvalue! */
2837 if (SvTYPE(TARG) < SVt_PVLV) {
2838 sv_upgrade(TARG, SVt_PVLV);
2839 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2842 if (LvTARG(TARG) != src) {
2844 SvREFCNT_dec(LvTARG(TARG));
2845 LvTARG(TARG) = SvREFCNT_inc(src);
2847 LvTARGOFF(TARG) = offset;
2848 LvTARGLEN(TARG) = size;
2851 sv_setuv(TARG, do_vecget(src, offset, size));
2866 I32 arybase = PL_curcop->cop_arybase;
2871 offset = POPi - arybase;
2874 tmps = SvPV(big, biglen);
2875 if (offset > 0 && DO_UTF8(big))
2876 sv_pos_u2b(big, &offset, 0);
2879 else if (offset > biglen)
2881 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2882 (unsigned char*)tmps + biglen, little, 0)))
2885 retval = tmps2 - tmps;
2886 if (retval > 0 && DO_UTF8(big))
2887 sv_pos_b2u(big, &retval);
2888 PUSHi(retval + arybase);
2903 I32 arybase = PL_curcop->cop_arybase;
2909 tmps2 = SvPV(little, llen);
2910 tmps = SvPV(big, blen);
2914 if (offset > 0 && DO_UTF8(big))
2915 sv_pos_u2b(big, &offset, 0);
2916 offset = offset - arybase + llen;
2920 else if (offset > blen)
2922 if (!(tmps2 = rninstr(tmps, tmps + offset,
2923 tmps2, tmps2 + llen)))
2926 retval = tmps2 - tmps;
2927 if (retval > 0 && DO_UTF8(big))
2928 sv_pos_b2u(big, &retval);
2929 PUSHi(retval + arybase);
2935 djSP; dMARK; dORIGMARK; dTARGET;
2936 do_sprintf(TARG, SP-MARK, MARK+1);
2937 TAINT_IF(SvTAINTED(TARG));
2948 U8 *s = (U8*)SvPVx(argsv, len);
2950 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
2960 (void)SvUPGRADE(TARG,SVt_PV);
2962 if ((value > 255 && !IN_BYTE) ||
2963 (UTF8_IS_CONTINUED(value) && (PL_hints & HINT_UTF8)) ) {
2964 SvGROW(TARG, UTF8_MAXLEN+1);
2966 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2967 SvCUR_set(TARG, tmps - SvPVX(TARG));
2969 (void)SvPOK_only(TARG);
2983 (void)SvPOK_only(TARG);
2990 djSP; dTARGET; dPOPTOPssrl;
2993 char *tmps = SvPV(left, n_a);
2995 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2997 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3001 "The crypt() function is unimplemented due to excessive paranoia.");
3014 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3016 U8 tmpbuf[UTF8_MAXLEN+1];
3018 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3020 if (PL_op->op_private & OPpLOCALE) {
3023 uv = toTITLE_LC_uni(uv);
3026 uv = toTITLE_utf8(s);
3028 tend = uv_to_utf8(tmpbuf, uv);
3030 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3032 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3033 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3038 s = (U8*)SvPV_force(sv, slen);
3039 Copy(tmpbuf, s, ulen, U8);
3043 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3045 SvUTF8_off(TARG); /* decontaminate */
3050 s = (U8*)SvPV_force(sv, slen);
3052 if (PL_op->op_private & OPpLOCALE) {
3055 *s = toUPPER_LC(*s);
3073 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3075 U8 tmpbuf[UTF8_MAXLEN+1];
3077 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3079 if (PL_op->op_private & OPpLOCALE) {
3082 uv = toLOWER_LC_uni(uv);
3085 uv = toLOWER_utf8(s);
3087 tend = uv_to_utf8(tmpbuf, uv);
3089 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3091 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3092 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3097 s = (U8*)SvPV_force(sv, slen);
3098 Copy(tmpbuf, s, ulen, U8);
3102 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3104 SvUTF8_off(TARG); /* decontaminate */
3109 s = (U8*)SvPV_force(sv, slen);
3111 if (PL_op->op_private & OPpLOCALE) {
3114 *s = toLOWER_LC(*s);
3138 s = (U8*)SvPV(sv,len);
3140 SvUTF8_off(TARG); /* decontaminate */
3141 sv_setpvn(TARG, "", 0);
3145 (void)SvUPGRADE(TARG, SVt_PV);
3146 SvGROW(TARG, (len * 2) + 1);
3147 (void)SvPOK_only(TARG);
3148 d = (U8*)SvPVX(TARG);
3150 if (PL_op->op_private & OPpLOCALE) {
3154 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3160 d = uv_to_utf8(d, toUPPER_utf8( s ));
3166 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3171 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3173 SvUTF8_off(TARG); /* decontaminate */
3178 s = (U8*)SvPV_force(sv, len);
3180 register U8 *send = s + len;
3182 if (PL_op->op_private & OPpLOCALE) {
3185 for (; s < send; s++)
3186 *s = toUPPER_LC(*s);
3189 for (; s < send; s++)
3212 s = (U8*)SvPV(sv,len);
3214 SvUTF8_off(TARG); /* decontaminate */
3215 sv_setpvn(TARG, "", 0);
3219 (void)SvUPGRADE(TARG, SVt_PV);
3220 SvGROW(TARG, (len * 2) + 1);
3221 (void)SvPOK_only(TARG);
3222 d = (U8*)SvPVX(TARG);
3224 if (PL_op->op_private & OPpLOCALE) {
3228 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3234 d = uv_to_utf8(d, toLOWER_utf8(s));
3240 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3245 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3247 SvUTF8_off(TARG); /* decontaminate */
3253 s = (U8*)SvPV_force(sv, len);
3255 register U8 *send = s + len;
3257 if (PL_op->op_private & OPpLOCALE) {
3260 for (; s < send; s++)
3261 *s = toLOWER_LC(*s);
3264 for (; s < send; s++)
3279 register char *s = SvPV(sv,len);
3282 SvUTF8_off(TARG); /* decontaminate */
3284 (void)SvUPGRADE(TARG, SVt_PV);
3285 SvGROW(TARG, (len * 2) + 1);
3289 if (UTF8_IS_CONTINUED(*s)) {
3290 STRLEN ulen = UTF8SKIP(s);
3314 SvCUR_set(TARG, d - SvPVX(TARG));
3315 (void)SvPOK_only_UTF8(TARG);
3318 sv_setpvn(TARG, s, len);
3320 if (SvSMAGICAL(TARG))
3329 djSP; dMARK; dORIGMARK;
3331 register AV* av = (AV*)POPs;
3332 register I32 lval = PL_op->op_flags & OPf_MOD;
3333 I32 arybase = PL_curcop->cop_arybase;
3336 if (SvTYPE(av) == SVt_PVAV) {
3337 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3339 for (svp = MARK + 1; svp <= SP; svp++) {
3344 if (max > AvMAX(av))
3347 while (++MARK <= SP) {
3348 elem = SvIVx(*MARK);
3352 svp = av_fetch(av, elem, lval);
3354 if (!svp || *svp == &PL_sv_undef)
3355 DIE(aTHX_ PL_no_aelem, elem);
3356 if (PL_op->op_private & OPpLVAL_INTRO)
3357 save_aelem(av, elem, svp);
3359 *MARK = svp ? *svp : &PL_sv_undef;
3362 if (GIMME != G_ARRAY) {
3370 /* Associative arrays. */
3375 HV *hash = (HV*)POPs;
3377 I32 gimme = GIMME_V;
3378 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3381 /* might clobber stack_sp */
3382 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3387 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3388 if (gimme == G_ARRAY) {
3391 /* might clobber stack_sp */
3393 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3398 else if (gimme == G_SCALAR)
3417 I32 gimme = GIMME_V;
3418 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3422 if (PL_op->op_private & OPpSLICE) {
3426 hvtype = SvTYPE(hv);
3427 if (hvtype == SVt_PVHV) { /* hash element */
3428 while (++MARK <= SP) {
3429 sv = hv_delete_ent(hv, *MARK, discard, 0);
3430 *MARK = sv ? sv : &PL_sv_undef;
3433 else if (hvtype == SVt_PVAV) {
3434 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3435 while (++MARK <= SP) {
3436 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3437 *MARK = sv ? sv : &PL_sv_undef;
3440 else { /* pseudo-hash element */
3441 while (++MARK <= SP) {
3442 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3443 *MARK = sv ? sv : &PL_sv_undef;
3448 DIE(aTHX_ "Not a HASH reference");
3451 else if (gimme == G_SCALAR) {
3460 if (SvTYPE(hv) == SVt_PVHV)
3461 sv = hv_delete_ent(hv, keysv, discard, 0);
3462 else if (SvTYPE(hv) == SVt_PVAV) {
3463 if (PL_op->op_flags & OPf_SPECIAL)
3464 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3466 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3469 DIE(aTHX_ "Not a HASH reference");
3484 if (PL_op->op_private & OPpEXISTS_SUB) {
3488 cv = sv_2cv(sv, &hv, &gv, FALSE);
3491 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3497 if (SvTYPE(hv) == SVt_PVHV) {
3498 if (hv_exists_ent(hv, tmpsv, 0))
3501 else if (SvTYPE(hv) == SVt_PVAV) {
3502 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3503 if (av_exists((AV*)hv, SvIV(tmpsv)))
3506 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3510 DIE(aTHX_ "Not a HASH reference");
3517 djSP; dMARK; dORIGMARK;
3518 register HV *hv = (HV*)POPs;
3519 register I32 lval = PL_op->op_flags & OPf_MOD;
3520 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3522 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3523 DIE(aTHX_ "Can't localize pseudo-hash element");
3525 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3526 while (++MARK <= SP) {
3529 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3531 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3532 svp = he ? &HeVAL(he) : 0;
3535 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3538 if (!svp || *svp == &PL_sv_undef) {
3540 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3542 if (PL_op->op_private & OPpLVAL_INTRO) {
3544 save_helem(hv, keysv, svp);
3547 char *key = SvPV(keysv, keylen);
3548 save_delete(hv, key, keylen);
3552 *MARK = svp ? *svp : &PL_sv_undef;
3555 if (GIMME != G_ARRAY) {
3563 /* List operators. */
3568 if (GIMME != G_ARRAY) {
3570 *MARK = *SP; /* unwanted list, return last item */
3572 *MARK = &PL_sv_undef;
3581 SV **lastrelem = PL_stack_sp;
3582 SV **lastlelem = PL_stack_base + POPMARK;
3583 SV **firstlelem = PL_stack_base + POPMARK + 1;
3584 register SV **firstrelem = lastlelem + 1;
3585 I32 arybase = PL_curcop->cop_arybase;
3586 I32 lval = PL_op->op_flags & OPf_MOD;
3587 I32 is_something_there = lval;
3589 register I32 max = lastrelem - lastlelem;
3590 register SV **lelem;
3593 if (GIMME != G_ARRAY) {
3594 ix = SvIVx(*lastlelem);
3599 if (ix < 0 || ix >= max)
3600 *firstlelem = &PL_sv_undef;
3602 *firstlelem = firstrelem[ix];
3608 SP = firstlelem - 1;
3612 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3618 if (ix < 0 || ix >= max)
3619 *lelem = &PL_sv_undef;
3621 is_something_there = TRUE;
3622 if (!(*lelem = firstrelem[ix]))
3623 *lelem = &PL_sv_undef;
3626 if (is_something_there)
3629 SP = firstlelem - 1;
3635 djSP; dMARK; dORIGMARK;
3636 I32 items = SP - MARK;
3637 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3638 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3645 djSP; dMARK; dORIGMARK;
3646 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3650 SV *val = NEWSV(46, 0);
3652 sv_setsv(val, *++MARK);
3653 else if (ckWARN(WARN_MISC))
3654 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3655 (void)hv_store_ent(hv,key,val,0);
3664 djSP; dMARK; dORIGMARK;
3665 register AV *ary = (AV*)*++MARK;
3669 register I32 offset;
3670 register I32 length;
3677 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3678 *MARK-- = SvTIED_obj((SV*)ary, mg);
3682 call_method("SPLICE",GIMME_V);
3691 offset = i = SvIVx(*MARK);
3693 offset += AvFILLp(ary) + 1;
3695 offset -= PL_curcop->cop_arybase;
3697 DIE(aTHX_ PL_no_aelem, i);
3699 length = SvIVx(*MARK++);
3701 length += AvFILLp(ary) - offset + 1;
3707 length = AvMAX(ary) + 1; /* close enough to infinity */
3711 length = AvMAX(ary) + 1;
3713 if (offset > AvFILLp(ary) + 1)
3714 offset = AvFILLp(ary) + 1;
3715 after = AvFILLp(ary) + 1 - (offset + length);
3716 if (after < 0) { /* not that much array */
3717 length += after; /* offset+length now in array */
3723 /* At this point, MARK .. SP-1 is our new LIST */
3726 diff = newlen - length;
3727 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3730 if (diff < 0) { /* shrinking the area */
3732 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3733 Copy(MARK, tmparyval, newlen, SV*);
3736 MARK = ORIGMARK + 1;
3737 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3738 MEXTEND(MARK, length);
3739 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3741 EXTEND_MORTAL(length);
3742 for (i = length, dst = MARK; i; i--) {
3743 sv_2mortal(*dst); /* free them eventualy */
3750 *MARK = AvARRAY(ary)[offset+length-1];
3753 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3754 SvREFCNT_dec(*dst++); /* free them now */
3757 AvFILLp(ary) += diff;
3759 /* pull up or down? */
3761 if (offset < after) { /* easier to pull up */
3762 if (offset) { /* esp. if nothing to pull */
3763 src = &AvARRAY(ary)[offset-1];
3764 dst = src - diff; /* diff is negative */
3765 for (i = offset; i > 0; i--) /* can't trust Copy */
3769 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3773 if (after) { /* anything to pull down? */
3774 src = AvARRAY(ary) + offset + length;
3775 dst = src + diff; /* diff is negative */
3776 Move(src, dst, after, SV*);
3778 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3779 /* avoid later double free */
3783 dst[--i] = &PL_sv_undef;
3786 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3788 *dst = NEWSV(46, 0);
3789 sv_setsv(*dst++, *src++);
3791 Safefree(tmparyval);
3794 else { /* no, expanding (or same) */
3796 New(452, tmparyval, length, SV*); /* so remember deletion */
3797 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3800 if (diff > 0) { /* expanding */
3802 /* push up or down? */
3804 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3808 Move(src, dst, offset, SV*);
3810 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3812 AvFILLp(ary) += diff;
3815 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3816 av_extend(ary, AvFILLp(ary) + diff);
3817 AvFILLp(ary) += diff;
3820 dst = AvARRAY(ary) + AvFILLp(ary);
3822 for (i = after; i; i--) {
3829 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3830 *dst = NEWSV(46, 0);
3831 sv_setsv(*dst++, *src++);
3833 MARK = ORIGMARK + 1;
3834 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3836 Copy(tmparyval, MARK, length, SV*);
3838 EXTEND_MORTAL(length);
3839 for (i = length, dst = MARK; i; i--) {
3840 sv_2mortal(*dst); /* free them eventualy */
3844 Safefree(tmparyval);
3848 else if (length--) {
3849 *MARK = tmparyval[length];
3852 while (length-- > 0)
3853 SvREFCNT_dec(tmparyval[length]);
3855 Safefree(tmparyval);
3858 *MARK = &PL_sv_undef;
3866 djSP; dMARK; dORIGMARK; dTARGET;
3867 register AV *ary = (AV*)*++MARK;
3868 register SV *sv = &PL_sv_undef;
3871 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3872 *MARK-- = SvTIED_obj((SV*)ary, mg);
3876 call_method("PUSH",G_SCALAR|G_DISCARD);
3881 /* Why no pre-extend of ary here ? */
3882 for (++MARK; MARK <= SP; MARK++) {
3885 sv_setsv(sv, *MARK);
3890 PUSHi( AvFILL(ary) + 1 );
3898 SV *sv = av_pop(av);
3900 (void)sv_2mortal(sv);
3909 SV *sv = av_shift(av);
3914 (void)sv_2mortal(sv);
3921 djSP; dMARK; dORIGMARK; dTARGET;
3922 register AV *ary = (AV*)*++MARK;
3927 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3928 *MARK-- = SvTIED_obj((SV*)ary, mg);
3932 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3937 av_unshift(ary, SP - MARK);
3940 sv_setsv(sv, *++MARK);
3941 (void)av_store(ary, i++, sv);
3945 PUSHi( AvFILL(ary) + 1 );
3955 if (GIMME == G_ARRAY) {
3962 /* safe as long as stack cannot get extended in the above */
3967 register char *down;
3972 SvUTF8_off(TARG); /* decontaminate */
3974 do_join(TARG, &PL_sv_no, MARK, SP);
3976 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3977 up = SvPV_force(TARG, len);
3979 if (DO_UTF8(TARG)) { /* first reverse each character */
3980 U8* s = (U8*)SvPVX(TARG);
3981 U8* send = (U8*)(s + len);
3983 if (UTF8_IS_ASCII(*s)) {
3988 if (!utf8_to_uv_simple(s, 0))
3992 down = (char*)(s - 1);
3993 /* reverse this character */
4003 down = SvPVX(TARG) + len - 1;
4009 (void)SvPOK_only_UTF8(TARG);
4018 S_mul128(pTHX_ SV *sv, U8 m)
4021 char *s = SvPV(sv, len);
4025 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4026 SV *tmpNew = newSVpvn("0000000000", 10);
4028 sv_catsv(tmpNew, sv);
4029 SvREFCNT_dec(sv); /* free old sv */
4034 while (!*t) /* trailing '\0'? */
4037 i = ((*t - '0') << 7) + m;
4038 *(t--) = '0' + (i % 10);
4044 /* Explosives and implosives. */
4046 #if 'I' == 73 && 'J' == 74
4047 /* On an ASCII/ISO kind of system */
4048 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4051 Some other sort of character set - use memchr() so we don't match
4054 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4061 I32 start_sp_offset = SP - PL_stack_base;
4062 I32 gimme = GIMME_V;
4066 register char *pat = SvPV(left, llen);
4067 register char *s = SvPV(right, rlen);
4068 char *strend = s + rlen;
4070 register char *patend = pat + llen;
4076 /* These must not be in registers: */
4093 register U32 culong;
4097 #ifdef PERL_NATINT_PACK
4098 int natint; /* native integer */
4099 int unatint; /* unsigned native integer */
4102 if (gimme != G_ARRAY) { /* arrange to do first one only */
4104 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4105 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4107 while (isDIGIT(*patend) || *patend == '*')
4113 while (pat < patend) {
4115 datumtype = *pat++ & 0xFF;
4116 #ifdef PERL_NATINT_PACK
4119 if (isSPACE(datumtype))
4121 if (datumtype == '#') {
4122 while (pat < patend && *pat != '\n')
4127 char *natstr = "sSiIlL";
4129 if (strchr(natstr, datumtype)) {
4130 #ifdef PERL_NATINT_PACK
4136 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4141 else if (*pat == '*') {
4142 len = strend - strbeg; /* long enough */
4146 else if (isDIGIT(*pat)) {
4148 while (isDIGIT(*pat)) {
4149 len = (len * 10) + (*pat++ - '0');
4151 DIE(aTHX_ "Repeat count in unpack overflows");
4155 len = (datumtype != '@');
4159 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4160 case ',': /* grandfather in commas but with a warning */
4161 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4162 Perl_warner(aTHX_ WARN_UNPACK,
4163 "Invalid type in unpack: '%c'", (int)datumtype);
4166 if (len == 1 && pat[-1] != '1')
4175 if (len > strend - strbeg)
4176 DIE(aTHX_ "@ outside of string");
4180 if (len > s - strbeg)
4181 DIE(aTHX_ "X outside of string");
4185 if (len > strend - s)
4186 DIE(aTHX_ "x outside of string");
4190 if (start_sp_offset >= SP - PL_stack_base)
4191 DIE(aTHX_ "/ must follow a numeric type");
4194 pat++; /* ignore '*' for compatibility with pack */
4196 DIE(aTHX_ "/ cannot take a count" );
4203 if (len > strend - s)
4206 goto uchar_checksum;
4207 sv = NEWSV(35, len);
4208 sv_setpvn(sv, s, len);
4210 if (datumtype == 'A' || datumtype == 'Z') {
4211 aptr = s; /* borrow register */
4212 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4217 else { /* 'A' strips both nulls and spaces */
4218 s = SvPVX(sv) + len - 1;
4219 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4223 SvCUR_set(sv, s - SvPVX(sv));
4224 s = aptr; /* unborrow register */
4226 XPUSHs(sv_2mortal(sv));
4230 if (star || len > (strend - s) * 8)
4231 len = (strend - s) * 8;
4234 Newz(601, PL_bitcount, 256, char);
4235 for (bits = 1; bits < 256; bits++) {
4236 if (bits & 1) PL_bitcount[bits]++;
4237 if (bits & 2) PL_bitcount[bits]++;
4238 if (bits & 4) PL_bitcount[bits]++;
4239 if (bits & 8) PL_bitcount[bits]++;
4240 if (bits & 16) PL_bitcount[bits]++;
4241 if (bits & 32) PL_bitcount[bits]++;
4242 if (bits & 64) PL_bitcount[bits]++;
4243 if (bits & 128) PL_bitcount[bits]++;
4247 culong += PL_bitcount[*(unsigned char*)s++];
4252 if (datumtype == 'b') {
4254 if (bits & 1) culong++;
4260 if (bits & 128) culong++;
4267 sv = NEWSV(35, len + 1);
4271 if (datumtype == 'b') {
4273 for (len = 0; len < aint; len++) {
4274 if (len & 7) /*SUPPRESS 595*/
4278 *str++ = '0' + (bits & 1);
4283 for (len = 0; len < aint; len++) {
4288 *str++ = '0' + ((bits & 128) != 0);
4292 XPUSHs(sv_2mortal(sv));
4296 if (star || len > (strend - s) * 2)
4297 len = (strend - s) * 2;
4298 sv = NEWSV(35, len + 1);
4302 if (datumtype == 'h') {
4304 for (len = 0; len < aint; len++) {
4309 *str++ = PL_hexdigit[bits & 15];
4314 for (len = 0; len < aint; len++) {
4319 *str++ = PL_hexdigit[(bits >> 4) & 15];
4323 XPUSHs(sv_2mortal(sv));
4326 if (len > strend - s)
4331 if (aint >= 128) /* fake up signed chars */
4341 if (aint >= 128) /* fake up signed chars */
4344 sv_setiv(sv, (IV)aint);
4345 PUSHs(sv_2mortal(sv));
4350 if (len > strend - s)
4365 sv_setiv(sv, (IV)auint);
4366 PUSHs(sv_2mortal(sv));
4371 if (len > strend - s)
4374 while (len-- > 0 && s < strend) {
4376 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4380 cdouble += (NV)auint;
4388 while (len-- > 0 && s < strend) {
4390 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4394 sv_setuv(sv, (UV)auint);
4395 PUSHs(sv_2mortal(sv));
4400 #if SHORTSIZE == SIZE16
4401 along = (strend - s) / SIZE16;
4403 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4408 #if SHORTSIZE != SIZE16
4412 COPYNN(s, &ashort, sizeof(short));
4423 #if SHORTSIZE > SIZE16
4435 #if SHORTSIZE != SIZE16
4439 COPYNN(s, &ashort, sizeof(short));
4442 sv_setiv(sv, (IV)ashort);
4443 PUSHs(sv_2mortal(sv));
4451 #if SHORTSIZE > SIZE16
4457 sv_setiv(sv, (IV)ashort);
4458 PUSHs(sv_2mortal(sv));
4466 #if SHORTSIZE == SIZE16
4467 along = (strend - s) / SIZE16;
4469 unatint = natint && datumtype == 'S';
4470 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4475 #if SHORTSIZE != SIZE16
4477 unsigned short aushort;
4479 COPYNN(s, &aushort, sizeof(unsigned short));
4480 s += sizeof(unsigned short);
4488 COPY16(s, &aushort);
4491 if (datumtype == 'n')
4492 aushort = PerlSock_ntohs(aushort);
4495 if (datumtype == 'v')
4496 aushort = vtohs(aushort);
4505 #if SHORTSIZE != SIZE16
4507 unsigned short aushort;
4509 COPYNN(s, &aushort, sizeof(unsigned short));
4510 s += sizeof(unsigned short);
4512 sv_setiv(sv, (UV)aushort);
4513 PUSHs(sv_2mortal(sv));
4520 COPY16(s, &aushort);
4524 if (datumtype == 'n')
4525 aushort = PerlSock_ntohs(aushort);
4528 if (datumtype == 'v')
4529 aushort = vtohs(aushort);
4531 sv_setiv(sv, (UV)aushort);
4532 PUSHs(sv_2mortal(sv));
4538 along = (strend - s) / sizeof(int);
4543 Copy(s, &aint, 1, int);
4546 cdouble += (NV)aint;
4555 Copy(s, &aint, 1, int);
4559 /* Without the dummy below unpack("i", pack("i",-1))
4560 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4561 * cc with optimization turned on.
4563 * The bug was detected in
4564 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4565 * with optimization (-O4) turned on.
4566 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4567 * does not have this problem even with -O4.
4569 * This bug was reported as DECC_BUGS 1431
4570 * and tracked internally as GEM_BUGS 7775.
4572 * The bug is fixed in
4573 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4574 * UNIX V4.0F support: DEC C V5.9-006 or later
4575 * UNIX V4.0E support: DEC C V5.8-011 or later
4578 * See also few lines later for the same bug.
4581 sv_setiv(sv, (IV)aint) :
4583 sv_setiv(sv, (IV)aint);
4584 PUSHs(sv_2mortal(sv));
4589 along = (strend - s) / sizeof(unsigned int);
4594 Copy(s, &auint, 1, unsigned int);
4595 s += sizeof(unsigned int);
4597 cdouble += (NV)auint;
4606 Copy(s, &auint, 1, unsigned int);
4607 s += sizeof(unsigned int);
4610 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4611 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4612 * See details few lines earlier. */
4614 sv_setuv(sv, (UV)auint) :
4616 sv_setuv(sv, (UV)auint);
4617 PUSHs(sv_2mortal(sv));
4622 #if LONGSIZE == SIZE32
4623 along = (strend - s) / SIZE32;
4625 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4630 #if LONGSIZE != SIZE32
4633 COPYNN(s, &along, sizeof(long));
4636 cdouble += (NV)along;
4645 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4649 #if LONGSIZE > SIZE32
4650 if (along > 2147483647)
4651 along -= 4294967296;
4655 cdouble += (NV)along;
4664 #if LONGSIZE != SIZE32
4667 COPYNN(s, &along, sizeof(long));
4670 sv_setiv(sv, (IV)along);
4671 PUSHs(sv_2mortal(sv));
4678 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4682 #if LONGSIZE > SIZE32
4683 if (along > 2147483647)
4684 along -= 4294967296;
4688 sv_setiv(sv, (IV)along);
4689 PUSHs(sv_2mortal(sv));
4697 #if LONGSIZE == SIZE32
4698 along = (strend - s) / SIZE32;
4700 unatint = natint && datumtype == 'L';
4701 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4706 #if LONGSIZE != SIZE32
4708 unsigned long aulong;
4710 COPYNN(s, &aulong, sizeof(unsigned long));
4711 s += sizeof(unsigned long);
4713 cdouble += (NV)aulong;
4725 if (datumtype == 'N')
4726 aulong = PerlSock_ntohl(aulong);
4729 if (datumtype == 'V')
4730 aulong = vtohl(aulong);
4733 cdouble += (NV)aulong;
4742 #if LONGSIZE != SIZE32
4744 unsigned long aulong;
4746 COPYNN(s, &aulong, sizeof(unsigned long));
4747 s += sizeof(unsigned long);
4749 sv_setuv(sv, (UV)aulong);
4750 PUSHs(sv_2mortal(sv));
4760 if (datumtype == 'N')
4761 aulong = PerlSock_ntohl(aulong);
4764 if (datumtype == 'V')
4765 aulong = vtohl(aulong);
4768 sv_setuv(sv, (UV)aulong);
4769 PUSHs(sv_2mortal(sv));
4775 along = (strend - s) / sizeof(char*);
4781 if (sizeof(char*) > strend - s)
4784 Copy(s, &aptr, 1, char*);
4790 PUSHs(sv_2mortal(sv));
4800 while ((len > 0) && (s < strend)) {
4801 auv = (auv << 7) | (*s & 0x7f);
4802 if (UTF8_IS_ASCII(*s++)) {
4806 PUSHs(sv_2mortal(sv));
4810 else if (++bytes >= sizeof(UV)) { /* promote to string */
4814 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4815 while (s < strend) {
4816 sv = mul128(sv, *s & 0x7f);
4817 if (!(*s++ & 0x80)) {
4826 PUSHs(sv_2mortal(sv));
4831 if ((s >= strend) && bytes)
4832 DIE(aTHX_ "Unterminated compressed integer");
4837 if (sizeof(char*) > strend - s)
4840 Copy(s, &aptr, 1, char*);
4845 sv_setpvn(sv, aptr, len);
4846 PUSHs(sv_2mortal(sv));
4850 along = (strend - s) / sizeof(Quad_t);
4856 if (s + sizeof(Quad_t) > strend)
4859 Copy(s, &aquad, 1, Quad_t);
4860 s += sizeof(Quad_t);
4863 if (aquad >= IV_MIN && aquad <= IV_MAX)
4864 sv_setiv(sv, (IV)aquad);
4866 sv_setnv(sv, (NV)aquad);
4867 PUSHs(sv_2mortal(sv));
4871 along = (strend - s) / sizeof(Quad_t);
4877 if (s + sizeof(Uquad_t) > strend)
4880 Copy(s, &auquad, 1, Uquad_t);
4881 s += sizeof(Uquad_t);
4884 if (auquad <= UV_MAX)
4885 sv_setuv(sv, (UV)auquad);
4887 sv_setnv(sv, (NV)auquad);
4888 PUSHs(sv_2mortal(sv));
4892 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4895 along = (strend - s) / sizeof(float);
4900 Copy(s, &afloat, 1, float);
4909 Copy(s, &afloat, 1, float);
4912 sv_setnv(sv, (NV)afloat);
4913 PUSHs(sv_2mortal(sv));
4919 along = (strend - s) / sizeof(double);
4924 Copy(s, &adouble, 1, double);
4925 s += sizeof(double);
4933 Copy(s, &adouble, 1, double);
4934 s += sizeof(double);
4936 sv_setnv(sv, (NV)adouble);
4937 PUSHs(sv_2mortal(sv));
4943 * Initialise the decode mapping. By using a table driven
4944 * algorithm, the code will be character-set independent
4945 * (and just as fast as doing character arithmetic)
4947 if (PL_uudmap['M'] == 0) {
4950 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4951 PL_uudmap[(U8)PL_uuemap[i]] = i;
4953 * Because ' ' and '`' map to the same value,
4954 * we need to decode them both the same.
4959 along = (strend - s) * 3 / 4;
4960 sv = NEWSV(42, along);
4963 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4968 len = PL_uudmap[*(U8*)s++] & 077;
4970 if (s < strend && ISUUCHAR(*s))
4971 a = PL_uudmap[*(U8*)s++] & 077;
4974 if (s < strend && ISUUCHAR(*s))
4975 b = PL_uudmap[*(U8*)s++] & 077;
4978 if (s < strend && ISUUCHAR(*s))
4979 c = PL_uudmap[*(U8*)s++] & 077;
4982 if (s < strend && ISUUCHAR(*s))
4983 d = PL_uudmap[*(U8*)s++] & 077;
4986 hunk[0] = (a << 2) | (b >> 4);
4987 hunk[1] = (b << 4) | (c >> 2);
4988 hunk[2] = (c << 6) | d;
4989 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4994 else if (s[1] == '\n') /* possible checksum byte */
4997 XPUSHs(sv_2mortal(sv));
5002 if (strchr("fFdD", datumtype) ||
5003 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5007 while (checksum >= 16) {
5011 while (checksum >= 4) {
5017 along = (1 << checksum) - 1;
5018 while (cdouble < 0.0)
5020 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5021 sv_setnv(sv, cdouble);
5024 if (checksum < 32) {
5025 aulong = (1 << checksum) - 1;
5028 sv_setuv(sv, (UV)culong);
5030 XPUSHs(sv_2mortal(sv));
5034 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5035 PUSHs(&PL_sv_undef);
5040 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5044 *hunk = PL_uuemap[len];
5045 sv_catpvn(sv, hunk, 1);
5048 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5049 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5050 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5051 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5052 sv_catpvn(sv, hunk, 4);
5057 char r = (len > 1 ? s[1] : '\0');
5058 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5059 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5060 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5061 hunk[3] = PL_uuemap[0];
5062 sv_catpvn(sv, hunk, 4);
5064 sv_catpvn(sv, "\n", 1);
5068 S_is_an_int(pTHX_ char *s, STRLEN l)
5071 SV *result = newSVpvn(s, l);
5072 char *result_c = SvPV(result, n_a); /* convenience */
5073 char *out = result_c;
5083 SvREFCNT_dec(result);
5106 SvREFCNT_dec(result);
5112 SvCUR_set(result, out - result_c);
5116 /* pnum must be '\0' terminated */
5118 S_div128(pTHX_ SV *pnum, bool *done)
5121 char *s = SvPV(pnum, len);
5130 i = m * 10 + (*t - '0');
5132 r = (i >> 7); /* r < 10 */
5139 SvCUR_set(pnum, (STRLEN) (t - s));
5146 djSP; dMARK; dORIGMARK; dTARGET;
5147 register SV *cat = TARG;
5150 register char *pat = SvPVx(*++MARK, fromlen);
5152 register char *patend = pat + fromlen;
5157 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5158 static char *space10 = " ";
5160 /* These must not be in registers: */
5175 #ifdef PERL_NATINT_PACK
5176 int natint; /* native integer */
5181 sv_setpvn(cat, "", 0);
5183 while (pat < patend) {
5184 SV *lengthcode = Nullsv;
5185 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5186 datumtype = *pat++ & 0xFF;
5187 #ifdef PERL_NATINT_PACK
5190 if (isSPACE(datumtype)) {
5194 if (datumtype == 'U' && pat == patcopy+1)
5196 if (datumtype == '#') {
5197 while (pat < patend && *pat != '\n')
5202 char *natstr = "sSiIlL";
5204 if (strchr(natstr, datumtype)) {
5205 #ifdef PERL_NATINT_PACK
5211 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5214 len = strchr("@Xxu", datumtype) ? 0 : items;
5217 else if (isDIGIT(*pat)) {
5219 while (isDIGIT(*pat)) {
5220 len = (len * 10) + (*pat++ - '0');
5222 DIE(aTHX_ "Repeat count in pack overflows");
5229 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5230 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5231 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5232 ? *MARK : &PL_sv_no)
5233 + (*pat == 'Z' ? 1 : 0)));
5237 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5238 case ',': /* grandfather in commas but with a warning */
5239 if (commas++ == 0 && ckWARN(WARN_PACK))
5240 Perl_warner(aTHX_ WARN_PACK,
5241 "Invalid type in pack: '%c'", (int)datumtype);
5244 DIE(aTHX_ "%% may only be used in unpack");
5255 if (SvCUR(cat) < len)
5256 DIE(aTHX_ "X outside of string");
5263 sv_catpvn(cat, null10, 10);
5266 sv_catpvn(cat, null10, len);
5272 aptr = SvPV(fromstr, fromlen);
5273 if (pat[-1] == '*') {
5275 if (datumtype == 'Z')
5278 if (fromlen >= len) {
5279 sv_catpvn(cat, aptr, len);
5280 if (datumtype == 'Z')
5281 *(SvEND(cat)-1) = '\0';
5284 sv_catpvn(cat, aptr, fromlen);
5286 if (datumtype == 'A') {
5288 sv_catpvn(cat, space10, 10);
5291 sv_catpvn(cat, space10, len);
5295 sv_catpvn(cat, null10, 10);
5298 sv_catpvn(cat, null10, len);
5310 str = SvPV(fromstr, fromlen);
5314 SvCUR(cat) += (len+7)/8;
5315 SvGROW(cat, SvCUR(cat) + 1);
5316 aptr = SvPVX(cat) + aint;
5321 if (datumtype == 'B') {
5322 for (len = 0; len++ < aint;) {
5323 items |= *str++ & 1;
5327 *aptr++ = items & 0xff;
5333 for (len = 0; len++ < aint;) {
5339 *aptr++ = items & 0xff;
5345 if (datumtype == 'B')
5346 items <<= 7 - (aint & 7);
5348 items >>= 7 - (aint & 7);
5349 *aptr++ = items & 0xff;
5351 str = SvPVX(cat) + SvCUR(cat);
5366 str = SvPV(fromstr, fromlen);
5370 SvCUR(cat) += (len+1)/2;
5371 SvGROW(cat, SvCUR(cat) + 1);
5372 aptr = SvPVX(cat) + aint;
5377 if (datumtype == 'H') {
5378 for (len = 0; len++ < aint;) {
5380 items |= ((*str++ & 15) + 9) & 15;
5382 items |= *str++ & 15;
5386 *aptr++ = items & 0xff;
5392 for (len = 0; len++ < aint;) {
5394 items |= (((*str++ & 15) + 9) & 15) << 4;
5396 items |= (*str++ & 15) << 4;
5400 *aptr++ = items & 0xff;
5406 *aptr++ = items & 0xff;
5407 str = SvPVX(cat) + SvCUR(cat);
5418 aint = SvIV(fromstr);
5420 sv_catpvn(cat, &achar, sizeof(char));
5426 auint = SvUV(fromstr);
5427 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5428 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
5433 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5438 afloat = (float)SvNV(fromstr);
5439 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5446 adouble = (double)SvNV(fromstr);
5447 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5453 ashort = (I16)SvIV(fromstr);
5455 ashort = PerlSock_htons(ashort);
5457 CAT16(cat, &ashort);
5463 ashort = (I16)SvIV(fromstr);
5465 ashort = htovs(ashort);
5467 CAT16(cat, &ashort);
5471 #if SHORTSIZE != SIZE16
5473 unsigned short aushort;
5477 aushort = SvUV(fromstr);
5478 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5488 aushort = (U16)SvUV(fromstr);
5489 CAT16(cat, &aushort);
5495 #if SHORTSIZE != SIZE16
5501 ashort = SvIV(fromstr);
5502 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5510 ashort = (I16)SvIV(fromstr);
5511 CAT16(cat, &ashort);
5518 auint = SvUV(fromstr);
5519 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5525 adouble = Perl_floor(SvNV(fromstr));
5528 DIE(aTHX_ "Cannot compress negative numbers");
5531 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5532 adouble <= 0xffffffff
5534 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5535 adouble <= UV_MAX_cxux
5542 char buf[1 + sizeof(UV)];
5543 char *in = buf + sizeof(buf);
5544 UV auv = U_V(adouble);
5547 *--in = (auv & 0x7f) | 0x80;
5550 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5551 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5553 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5554 char *from, *result, *in;
5559 /* Copy string and check for compliance */
5560 from = SvPV(fromstr, len);
5561 if ((norm = is_an_int(from, len)) == NULL)
5562 DIE(aTHX_ "can compress only unsigned integer");
5564 New('w', result, len, char);
5568 *--in = div128(norm, &done) | 0x80;
5569 result[len - 1] &= 0x7F; /* clear continue bit */
5570 sv_catpvn(cat, in, (result + len) - in);
5572 SvREFCNT_dec(norm); /* free norm */
5574 else if (SvNOKp(fromstr)) {
5575 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5576 char *in = buf + sizeof(buf);
5579 double next = floor(adouble / 128);
5580 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5581 if (in <= buf) /* this cannot happen ;-) */
5582 DIE(aTHX_ "Cannot compress integer");
5585 } while (adouble > 0);
5586 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5587 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5590 DIE(aTHX_ "Cannot compress non integer");
5596 aint = SvIV(fromstr);
5597 sv_catpvn(cat, (char*)&aint, sizeof(int));
5603 aulong = SvUV(fromstr);
5605 aulong = PerlSock_htonl(aulong);
5607 CAT32(cat, &aulong);
5613 aulong = SvUV(fromstr);
5615 aulong = htovl(aulong);
5617 CAT32(cat, &aulong);
5621 #if LONGSIZE != SIZE32
5623 unsigned long aulong;
5627 aulong = SvUV(fromstr);
5628 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5636 aulong = SvUV(fromstr);
5637 CAT32(cat, &aulong);
5642 #if LONGSIZE != SIZE32
5648 along = SvIV(fromstr);
5649 sv_catpvn(cat, (char *)&along, sizeof(long));
5657 along = SvIV(fromstr);
5666 auquad = (Uquad_t)SvUV(fromstr);
5667 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5673 aquad = (Quad_t)SvIV(fromstr);
5674 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5679 len = 1; /* assume SV is correct length */
5684 if (fromstr == &PL_sv_undef)
5688 /* XXX better yet, could spirit away the string to
5689 * a safe spot and hang on to it until the result
5690 * of pack() (and all copies of the result) are
5693 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5694 || (SvPADTMP(fromstr)
5695 && !SvREADONLY(fromstr))))
5697 Perl_warner(aTHX_ WARN_PACK,
5698 "Attempt to pack pointer to temporary value");
5700 if (SvPOK(fromstr) || SvNIOK(fromstr))
5701 aptr = SvPV(fromstr,n_a);
5703 aptr = SvPV_force(fromstr,n_a);
5705 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5710 aptr = SvPV(fromstr, fromlen);
5711 SvGROW(cat, fromlen * 4 / 3);
5716 while (fromlen > 0) {
5723 doencodes(cat, aptr, todo);
5742 register IV limit = POPi; /* note, negative is forever */
5745 register char *s = SvPV(sv, len);
5746 bool do_utf8 = DO_UTF8(sv);
5747 char *strend = s + len;
5749 register REGEXP *rx;
5753 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5754 I32 maxiters = slen + 10;
5757 I32 origlimit = limit;
5760 AV *oldstack = PL_curstack;
5761 I32 gimme = GIMME_V;
5762 I32 oldsave = PL_savestack_ix;
5763 I32 make_mortal = 1;
5764 MAGIC *mg = (MAGIC *) NULL;
5767 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5772 DIE(aTHX_ "panic: pp_split");
5773 rx = pm->op_pmregexp;
5775 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5776 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5778 if (pm->op_pmreplroot) {
5780 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5782 ary = GvAVn((GV*)pm->op_pmreplroot);
5785 else if (gimme != G_ARRAY)
5787 ary = (AV*)PL_curpad[0];
5789 ary = GvAVn(PL_defgv);
5790 #endif /* USE_THREADS */
5793 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5799 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5801 XPUSHs(SvTIED_obj((SV*)ary, mg));
5807 for (i = AvFILLp(ary); i >= 0; i--)
5808 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5810 /* temporarily switch stacks */
5811 SWITCHSTACK(PL_curstack, ary);
5815 base = SP - PL_stack_base;
5817 if (pm->op_pmflags & PMf_SKIPWHITE) {
5818 if (pm->op_pmflags & PMf_LOCALE) {
5819 while (isSPACE_LC(*s))
5827 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5828 SAVEINT(PL_multiline);
5829 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5833 limit = maxiters + 2;
5834 if (pm->op_pmflags & PMf_WHITE) {
5837 while (m < strend &&
5838 !((pm->op_pmflags & PMf_LOCALE)
5839 ? isSPACE_LC(*m) : isSPACE(*m)))
5844 dstr = NEWSV(30, m-s);
5845 sv_setpvn(dstr, s, m-s);
5849 (void)SvUTF8_on(dstr);
5853 while (s < strend &&
5854 ((pm->op_pmflags & PMf_LOCALE)
5855 ? isSPACE_LC(*s) : isSPACE(*s)))
5859 else if (strEQ("^", rx->precomp)) {
5862 for (m = s; m < strend && *m != '\n'; m++) ;
5866 dstr = NEWSV(30, m-s);
5867 sv_setpvn(dstr, s, m-s);
5871 (void)SvUTF8_on(dstr);
5876 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5877 && (rx->reganch & ROPT_CHECK_ALL)
5878 && !(rx->reganch & ROPT_ANCH)) {
5879 int tail = (rx->reganch & RE_INTUIT_TAIL);
5880 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5883 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5885 char c = *SvPV(csv, n_a);
5888 for (m = s; m < strend && *m != c; m++) ;
5891 dstr = NEWSV(30, m-s);
5892 sv_setpvn(dstr, s, m-s);
5896 (void)SvUTF8_on(dstr);
5898 /* The rx->minlen is in characters but we want to step
5899 * s ahead by bytes. */
5901 s = (char*)utf8_hop((U8*)m, len);
5903 s = m + len; /* Fake \n at the end */
5908 while (s < strend && --limit &&
5909 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5910 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5913 dstr = NEWSV(31, m-s);
5914 sv_setpvn(dstr, s, m-s);
5918 (void)SvUTF8_on(dstr);
5920 /* The rx->minlen is in characters but we want to step
5921 * s ahead by bytes. */
5923 s = (char*)utf8_hop((U8*)m, len);
5925 s = m + len; /* Fake \n at the end */
5930 maxiters += slen * rx->nparens;
5931 while (s < strend && --limit
5932 /* && (!rx->check_substr
5933 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5935 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5936 1 /* minend */, sv, NULL, 0))
5938 TAINT_IF(RX_MATCH_TAINTED(rx));
5939 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5944 strend = s + (strend - m);
5946 m = rx->startp[0] + orig;
5947 dstr = NEWSV(32, m-s);
5948 sv_setpvn(dstr, s, m-s);
5952 (void)SvUTF8_on(dstr);
5955 for (i = 1; i <= rx->nparens; i++) {
5956 s = rx->startp[i] + orig;
5957 m = rx->endp[i] + orig;
5959 dstr = NEWSV(33, m-s);
5960 sv_setpvn(dstr, s, m-s);
5963 dstr = NEWSV(33, 0);
5967 (void)SvUTF8_on(dstr);
5971 s = rx->endp[0] + orig;
5975 LEAVE_SCOPE(oldsave);
5976 iters = (SP - PL_stack_base) - base;
5977 if (iters > maxiters)
5978 DIE(aTHX_ "Split loop");
5980 /* keep field after final delim? */
5981 if (s < strend || (iters && origlimit)) {
5982 STRLEN l = strend - s;
5983 dstr = NEWSV(34, l);
5984 sv_setpvn(dstr, s, l);
5988 (void)SvUTF8_on(dstr);
5992 else if (!origlimit) {
5993 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5999 SWITCHSTACK(ary, oldstack);
6000 if (SvSMAGICAL(ary)) {
6005 if (gimme == G_ARRAY) {
6007 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6015 call_method("PUSH",G_SCALAR|G_DISCARD);
6018 if (gimme == G_ARRAY) {
6019 /* EXTEND should not be needed - we just popped them */
6021 for (i=0; i < iters; i++) {
6022 SV **svp = av_fetch(ary, i, FALSE);
6023 PUSHs((svp) ? *svp : &PL_sv_undef);
6030 if (gimme == G_ARRAY)
6033 if (iters || !pm->op_pmreplroot) {
6043 Perl_unlock_condpair(pTHX_ void *svv)
6045 MAGIC *mg = mg_find((SV*)svv, 'm');
6048 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6049 MUTEX_LOCK(MgMUTEXP(mg));
6050 if (MgOWNER(mg) != thr)
6051 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6053 COND_SIGNAL(MgOWNERCONDP(mg));
6054 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6055 PTR2UV(thr), PTR2UV(svv));)
6056 MUTEX_UNLOCK(MgMUTEXP(mg));
6058 #endif /* USE_THREADS */
6067 #endif /* USE_THREADS */
6068 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6069 || SvTYPE(retsv) == SVt_PVCV) {
6070 retsv = refto(retsv);
6081 if (PL_op->op_private & OPpLVAL_INTRO)
6082 PUSHs(*save_threadsv(PL_op->op_targ));
6084 PUSHs(THREADSV(PL_op->op_targ));
6087 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6088 #endif /* USE_THREADS */