3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if LONGSIZE > 4 && defined(_CRAY)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
85 /* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
89 #ifdef NEED_GETPID_PROTO
90 extern Pid_t getpid (void);
96 if (GIMME_V == G_SCALAR)
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
114 if (PL_op->op_flags & OPf_REF) {
118 if (GIMME == G_ARRAY) {
119 I32 maxarg = AvFILL((AV*)TARG) + 1;
121 if (SvMAGICAL(TARG)) {
123 for (i=0; i < maxarg; i++) {
124 SV **svp = av_fetch((AV*)TARG, i, FALSE);
125 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
129 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
134 SV* sv = sv_newmortal();
135 I32 maxarg = AvFILL((AV*)TARG) + 1;
136 sv_setiv(sv, maxarg);
148 if (PL_op->op_private & OPpLVAL_INTRO)
149 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
150 if (PL_op->op_flags & OPf_REF)
153 if (gimme == G_ARRAY) {
156 else if (gimme == G_SCALAR) {
157 SV* sv = sv_newmortal();
158 if (HvFILL((HV*)TARG))
159 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
160 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
170 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
181 tryAMAGICunDEREF(to_gv);
184 if (SvTYPE(sv) == SVt_PVIO) {
185 GV *gv = (GV*) sv_newmortal();
186 gv_init(gv, 0, "", 0, 0);
187 GvIOp(gv) = (IO *)sv;
188 (void)SvREFCNT_inc(sv);
191 else if (SvTYPE(sv) != SVt_PVGV)
192 DIE(aTHX_ "Not a GLOB reference");
195 if (SvTYPE(sv) != SVt_PVGV) {
199 if (SvGMAGICAL(sv)) {
204 if (!SvOK(sv) && sv != &PL_sv_undef) {
205 /* If this is a 'my' scalar and flag is set then vivify
208 if (PL_op->op_private & OPpDEREF) {
211 if (cUNOP->op_targ) {
213 SV *namesv = PL_curpad[cUNOP->op_targ];
214 name = SvPV(namesv, len);
215 gv = (GV*)NEWSV(0,0);
216 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
219 name = CopSTASHPV(PL_curcop);
222 if (SvTYPE(sv) < SVt_RV)
223 sv_upgrade(sv, SVt_RV);
229 if (PL_op->op_flags & OPf_REF ||
230 PL_op->op_private & HINT_STRICT_REFS)
231 DIE(aTHX_ PL_no_usym, "a symbol");
232 if (ckWARN(WARN_UNINITIALIZED))
237 if ((PL_op->op_flags & OPf_SPECIAL) &&
238 !(PL_op->op_flags & OPf_MOD))
240 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
242 && (!is_gv_magical(sym,len,0)
243 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
249 if (PL_op->op_private & HINT_STRICT_REFS)
250 DIE(aTHX_ PL_no_symref, sym, "a symbol");
251 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
255 if (PL_op->op_private & OPpLVAL_INTRO)
256 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
267 tryAMAGICunDEREF(to_sv);
270 switch (SvTYPE(sv)) {
274 DIE(aTHX_ "Not a SCALAR reference");
282 if (SvTYPE(gv) != SVt_PVGV) {
283 if (SvGMAGICAL(sv)) {
289 if (PL_op->op_flags & OPf_REF ||
290 PL_op->op_private & HINT_STRICT_REFS)
291 DIE(aTHX_ PL_no_usym, "a SCALAR");
292 if (ckWARN(WARN_UNINITIALIZED))
297 if ((PL_op->op_flags & OPf_SPECIAL) &&
298 !(PL_op->op_flags & OPf_MOD))
300 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
302 && (!is_gv_magical(sym,len,0)
303 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
309 if (PL_op->op_private & HINT_STRICT_REFS)
310 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
311 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
316 if (PL_op->op_flags & OPf_MOD) {
317 if (PL_op->op_private & OPpLVAL_INTRO)
318 sv = save_scalar((GV*)TOPs);
319 else if (PL_op->op_private & OPpDEREF)
320 vivify_ref(sv, PL_op->op_private & OPpDEREF);
330 SV *sv = AvARYLEN(av);
332 AvARYLEN(av) = sv = NEWSV(0,0);
333 sv_upgrade(sv, SVt_IV);
334 sv_magic(sv, (SV*)av, '#', Nullch, 0);
342 djSP; dTARGET; dPOPss;
344 if (PL_op->op_flags & OPf_MOD) {
345 if (SvTYPE(TARG) < SVt_PVLV) {
346 sv_upgrade(TARG, SVt_PVLV);
347 sv_magic(TARG, Nullsv, '.', Nullch, 0);
351 if (LvTARG(TARG) != sv) {
353 SvREFCNT_dec(LvTARG(TARG));
354 LvTARG(TARG) = SvREFCNT_inc(sv);
356 PUSHs(TARG); /* no SvSETMAGIC */
362 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
363 mg = mg_find(sv, 'g');
364 if (mg && mg->mg_len >= 0) {
368 PUSHi(i + PL_curcop->cop_arybase);
382 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
383 /* (But not in defined().) */
384 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
387 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
388 if ((PL_op->op_private & OPpLVAL_INTRO)) {
389 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
392 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
396 cv = (CV*)&PL_sv_undef;
410 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
411 char *s = SvPVX(TOPs);
412 if (strnEQ(s, "CORE::", 6)) {
415 code = keyword(s + 6, SvCUR(TOPs) - 6);
416 if (code < 0) { /* Overridable. */
417 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
418 int i = 0, n = 0, seen_question = 0;
420 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
422 while (i < MAXO) { /* The slow way. */
423 if (strEQ(s + 6, PL_op_name[i])
424 || strEQ(s + 6, PL_op_desc[i]))
430 goto nonesuch; /* Should not happen... */
432 oa = PL_opargs[i] >> OASHIFT;
434 if (oa & OA_OPTIONAL && !seen_question) {
438 else if (n && str[0] == ';' && seen_question)
439 goto set; /* XXXX system, exec */
440 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
441 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
444 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
445 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
449 ret = sv_2mortal(newSVpvn(str, n - 1));
451 else if (code) /* Non-Overridable */
453 else { /* None such */
455 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
459 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
461 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
470 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
472 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
488 if (GIMME != G_ARRAY) {
492 *MARK = &PL_sv_undef;
493 *MARK = refto(*MARK);
497 EXTEND_MORTAL(SP - MARK);
499 *MARK = refto(*MARK);
504 S_refto(pTHX_ SV *sv)
508 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
511 if (!(sv = LvTARG(sv)))
514 (void)SvREFCNT_inc(sv);
516 else if (SvTYPE(sv) == SVt_PVAV) {
517 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
520 (void)SvREFCNT_inc(sv);
522 else if (SvPADTMP(sv))
526 (void)SvREFCNT_inc(sv);
529 sv_upgrade(rv, SVt_RV);
543 if (sv && SvGMAGICAL(sv))
546 if (!sv || !SvROK(sv))
550 pv = sv_reftype(sv,TRUE);
551 PUSHp(pv, strlen(pv));
561 stash = CopSTASH(PL_curcop);
567 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
568 Perl_croak(aTHX_ "Attempt to bless into a reference");
570 if (ckWARN(WARN_MISC) && len == 0)
571 Perl_warner(aTHX_ WARN_MISC,
572 "Explicit blessing to '' (assuming package main)");
573 stash = gv_stashpvn(ptr, len, TRUE);
576 (void)sv_bless(TOPs, stash);
590 elem = SvPV(sv, n_a);
594 switch (elem ? *elem : '\0')
597 if (strEQ(elem, "ARRAY"))
598 tmpRef = (SV*)GvAV(gv);
601 if (strEQ(elem, "CODE"))
602 tmpRef = (SV*)GvCVu(gv);
605 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
606 tmpRef = (SV*)GvIOp(gv);
608 if (strEQ(elem, "FORMAT"))
609 tmpRef = (SV*)GvFORM(gv);
612 if (strEQ(elem, "GLOB"))
616 if (strEQ(elem, "HASH"))
617 tmpRef = (SV*)GvHV(gv);
620 if (strEQ(elem, "IO"))
621 tmpRef = (SV*)GvIOp(gv);
624 if (strEQ(elem, "NAME"))
625 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
628 if (strEQ(elem, "PACKAGE"))
629 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
632 if (strEQ(elem, "SCALAR"))
646 /* Pattern matching */
651 register unsigned char *s;
654 register I32 *sfirst;
658 if (sv == PL_lastscream) {
664 SvSCREAM_off(PL_lastscream);
665 SvREFCNT_dec(PL_lastscream);
667 PL_lastscream = SvREFCNT_inc(sv);
670 s = (unsigned char*)(SvPV(sv, len));
674 if (pos > PL_maxscream) {
675 if (PL_maxscream < 0) {
676 PL_maxscream = pos + 80;
677 New(301, PL_screamfirst, 256, I32);
678 New(302, PL_screamnext, PL_maxscream, I32);
681 PL_maxscream = pos + pos / 4;
682 Renew(PL_screamnext, PL_maxscream, I32);
686 sfirst = PL_screamfirst;
687 snext = PL_screamnext;
689 if (!sfirst || !snext)
690 DIE(aTHX_ "do_study: out of memory");
692 for (ch = 256; ch; --ch)
699 snext[pos] = sfirst[ch] - pos;
706 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
715 if (PL_op->op_flags & OPf_STACKED)
721 TARG = sv_newmortal();
726 /* Lvalue operators. */
738 djSP; dMARK; dTARGET;
748 SETi(do_chomp(TOPs));
754 djSP; dMARK; dTARGET;
755 register I32 count = 0;
758 count += do_chomp(POPs);
769 if (!sv || !SvANY(sv))
771 switch (SvTYPE(sv)) {
773 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
777 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
781 if (CvROOT(sv) || CvXSUB(sv))
798 if (!PL_op->op_private) {
807 if (SvTHINKFIRST(sv))
810 switch (SvTYPE(sv)) {
820 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
821 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
822 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
826 /* let user-undef'd sub keep its identity */
827 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
834 SvSetMagicSV(sv, &PL_sv_undef);
838 Newz(602, gp, 1, GP);
839 GvGP(sv) = gp_ref(gp);
840 GvSV(sv) = NEWSV(72,0);
841 GvLINE(sv) = CopLINE(PL_curcop);
847 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
850 SvPV_set(sv, Nullch);
863 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
864 DIE(aTHX_ PL_no_modify);
865 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
866 SvIVX(TOPs) != IV_MIN)
869 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
880 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
881 DIE(aTHX_ PL_no_modify);
882 sv_setsv(TARG, TOPs);
883 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
884 SvIVX(TOPs) != IV_MAX)
887 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
901 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
902 DIE(aTHX_ PL_no_modify);
903 sv_setsv(TARG, TOPs);
904 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
905 SvIVX(TOPs) != IV_MIN)
908 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
917 /* Ordinary operators. */
921 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
924 SETn( Perl_pow( left, right) );
931 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
932 #ifdef PERL_PRESERVE_IVUV
935 /* Unless the left argument is integer in range we are going to have to
936 use NV maths. Hence only attempt to coerce the right argument if
937 we know the left is integer. */
938 /* Left operand is defined, so is it IV? */
941 bool auvok = SvUOK(TOPm1s);
942 bool buvok = SvUOK(TOPs);
943 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
944 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
951 alow = SvUVX(TOPm1s);
953 IV aiv = SvIVX(TOPm1s);
956 auvok = TRUE; /* effectively it's a UV now */
958 alow = -aiv; /* abs, auvok == false records sign */
964 IV biv = SvIVX(TOPs);
967 buvok = TRUE; /* effectively it's a UV now */
969 blow = -biv; /* abs, buvok == false records sign */
973 /* If this does sign extension on unsigned it's time for plan B */
974 ahigh = alow >> (4 * sizeof (UV));
976 bhigh = blow >> (4 * sizeof (UV));
978 if (ahigh && bhigh) {
979 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
980 which is overflow. Drop to NVs below. */
981 } else if (!ahigh && !bhigh) {
982 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
983 so the unsigned multiply cannot overflow. */
984 UV product = alow * blow;
985 if (auvok == buvok) {
986 /* -ve * -ve or +ve * +ve gives a +ve result. */
990 } else if (product <= (UV)IV_MIN) {
991 /* 2s complement assumption that (UV)-IV_MIN is correct. */
992 /* -ve result, which could overflow an IV */
996 } /* else drop to NVs below. */
998 /* One operand is large, 1 small */
1001 /* swap the operands */
1003 bhigh = blow; /* bhigh now the temp var for the swap */
1007 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1008 multiplies can't overflow. shift can, add can, -ve can. */
1009 product_middle = ahigh * blow;
1010 if (!(product_middle & topmask)) {
1011 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1013 product_middle <<= (4 * sizeof (UV));
1014 product_low = alow * blow;
1016 /* as for pp_add, UV + something mustn't get smaller.
1017 IIRC ANSI mandates this wrapping *behaviour* for
1018 unsigned whatever the actual representation*/
1019 product_low += product_middle;
1020 if (product_low >= product_middle) {
1021 /* didn't overflow */
1022 if (auvok == buvok) {
1023 /* -ve * -ve or +ve * +ve gives a +ve result. */
1025 SETu( product_low );
1027 } else if (product_low <= (UV)IV_MIN) {
1028 /* 2s complement assumption again */
1029 /* -ve result, which could overflow an IV */
1031 SETi( -product_low );
1033 } /* else drop to NVs below. */
1035 } /* product_middle too large */
1036 } /* ahigh && bhigh */
1037 } /* SvIOK(TOPm1s) */
1042 SETn( left * right );
1049 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1054 DIE(aTHX_ "Illegal division by zero");
1056 /* insure that 20./5. == 4. */
1059 if ((NV)I_V(left) == left &&
1060 (NV)I_V(right) == right &&
1061 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1065 value = left / right;
1069 value = left / right;
1078 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1084 bool use_double = 0;
1088 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1090 right = (right_neg = (i < 0)) ? -i : i;
1095 right_neg = dright < 0;
1100 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1102 left = (left_neg = (i < 0)) ? -i : i;
1110 left_neg = dleft < 0;
1119 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1121 # define CAST_D2UV(d) U_V(d)
1123 # define CAST_D2UV(d) ((UV)(d))
1125 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1126 * or, in other words, precision of UV more than of NV.
1127 * But in fact the approach below turned out to be an
1128 * optimization - floor() may be slow */
1129 if (dright <= UV_MAX && dleft <= UV_MAX) {
1130 right = CAST_D2UV(dright);
1131 left = CAST_D2UV(dleft);
1136 /* Backward-compatibility clause: */
1137 dright = Perl_floor(dright + 0.5);
1138 dleft = Perl_floor(dleft + 0.5);
1141 DIE(aTHX_ "Illegal modulus zero");
1143 dans = Perl_fmod(dleft, dright);
1144 if ((left_neg != right_neg) && dans)
1145 dans = dright - dans;
1148 sv_setnv(TARG, dans);
1155 DIE(aTHX_ "Illegal modulus zero");
1158 if ((left_neg != right_neg) && ans)
1161 /* XXX may warn: unary minus operator applied to unsigned type */
1162 /* could change -foo to be (~foo)+1 instead */
1163 if (ans <= ~((UV)IV_MAX)+1)
1164 sv_setiv(TARG, ~ans+1);
1166 sv_setnv(TARG, -(NV)ans);
1169 sv_setuv(TARG, ans);
1178 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1180 register IV count = POPi;
1181 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1183 I32 items = SP - MARK;
1186 max = items * count;
1195 repeatcpy((char*)(MARK + items), (char*)MARK,
1196 items * sizeof(SV*), count - 1);
1199 else if (count <= 0)
1202 else { /* Note: mark already snarfed by pp_list */
1205 bool isutf = DO_UTF8(tmpstr);
1207 SvSetSV(TARG, tmpstr);
1208 SvPV_force(TARG, len);
1213 SvGROW(TARG, (count * len) + 1);
1214 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1215 SvCUR(TARG) *= count;
1217 *SvEND(TARG) = '\0';
1220 (void)SvPOK_only_UTF8(TARG);
1222 (void)SvPOK_only(TARG);
1231 djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1232 useleft = USE_LEFT(TOPm1s);
1233 #ifdef PERL_PRESERVE_IVUV
1234 /* We must see if we can perform the addition with integers if possible,
1235 as the integer code detects overflow while the NV code doesn't.
1236 If either argument hasn't had a numeric conversion yet attempt to get
1237 the IV. It's important to do this now, rather than just assuming that
1238 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1239 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1240 integer in case the second argument is IV=9223372036854775806
1241 We can (now) rely on sv_2iv to do the right thing, only setting the
1242 public IOK flag if the value in the NV (or PV) slot is truly integer.
1244 A side effect is that this also aggressively prefers integer maths over
1245 fp maths for integer values. */
1248 /* Unless the left argument is integer in range we are going to have to
1249 use NV maths. Hence only attempt to coerce the right argument if
1250 we know the left is integer. */
1252 /* left operand is undef, treat as zero. + 0 is identity. */
1254 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
1255 if (value <= (UV)IV_MIN) {
1256 /* 2s complement assumption. */
1259 } /* else drop through into NVs below */
1266 /* Left operand is defined, so is it IV? */
1267 SvIV_please(TOPm1s);
1268 if (SvIOK(TOPm1s)) {
1269 bool auvok = SvUOK(TOPm1s);
1270 bool buvok = SvUOK(TOPs);
1272 if (!auvok && !buvok) { /* ## IV - IV ## */
1273 IV aiv = SvIVX(TOPm1s);
1274 IV biv = SvIVX(TOPs);
1275 IV result = aiv - biv;
1277 if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
1282 /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
1283 /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
1284 /* -ve - +ve can only overflow too negative. */
1285 /* leaving +ve - -ve, which will go UV */
1286 if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
1287 /* 2s complement assumption for IV_MIN */
1288 UV result = (UV)aiv + (UV)-biv;
1289 /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
1290 overflow UV (2s complement assumption */
1291 assert (result >= (UV) aiv);
1296 /* Overflow, drop through to NVs */
1297 } else if (auvok && buvok) { /* ## UV - UV ## */
1298 UV auv = SvUVX(TOPm1s);
1299 UV buv = SvUVX(TOPs);
1307 /* Blatant 2s complement assumption. */
1308 result = (IV)(auv - buv);
1314 /* Overflow on IV - IV, drop through to NVs */
1315 } else if (auvok) { /* ## Mixed UV - IV ## */
1316 UV auv = SvUVX(TOPm1s);
1317 IV biv = SvIVX(TOPs);
1320 /* 2s complement assumptions for IV_MIN */
1321 UV result = auv + ((UV)-biv);
1322 /* UV + UV can only get bigger... */
1323 if (result >= auv) {
1328 /* and if it gets too big for UV then it's NV time. */
1329 } else if (auv > (UV)IV_MAX) {
1330 /* I think I'm making an implicit 2s complement
1331 assumption that IV_MIN == -IV_MAX - 1 */
1333 UV result = auv - (UV)biv;
1334 assert (result <= auv);
1340 IV result = (IV)auv - biv;
1341 assert (result <= (IV)auv);
1346 } else { /* ## Mixed IV - UV ## */
1347 IV aiv = SvIVX(TOPm1s);
1348 UV buv = SvUVX(TOPs);
1349 IV result = aiv - (IV)buv; /* 2s complement assumption. */
1351 /* result must not get larger. */
1352 if (result <= aiv) {
1356 } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
1365 /* left operand is undef, treat as zero - value */
1369 SETn( TOPn - value );
1376 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1379 if (PL_op->op_private & HINT_INTEGER) {
1393 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1396 if (PL_op->op_private & HINT_INTEGER) {
1410 djSP; tryAMAGICbinSET(lt,0);
1411 #ifdef PERL_PRESERVE_IVUV
1414 SvIV_please(TOPm1s);
1415 if (SvIOK(TOPm1s)) {
1416 bool auvok = SvUOK(TOPm1s);
1417 bool buvok = SvUOK(TOPs);
1419 if (!auvok && !buvok) { /* ## IV < IV ## */
1420 IV aiv = SvIVX(TOPm1s);
1421 IV biv = SvIVX(TOPs);
1424 SETs(boolSV(aiv < biv));
1427 if (auvok && buvok) { /* ## UV < UV ## */
1428 UV auv = SvUVX(TOPm1s);
1429 UV buv = SvUVX(TOPs);
1432 SETs(boolSV(auv < buv));
1435 if (auvok) { /* ## UV < IV ## */
1442 /* As (a) is a UV, it's >=0, so it cannot be < */
1447 if (auv >= (UV) IV_MAX) {
1448 /* As (b) is an IV, it cannot be > IV_MAX */
1452 SETs(boolSV(auv < (UV)biv));
1455 { /* ## IV < UV ## */
1459 aiv = SvIVX(TOPm1s);
1461 /* As (b) is a UV, it's >=0, so it must be < */
1468 if (buv > (UV) IV_MAX) {
1469 /* As (a) is an IV, it cannot be > IV_MAX */
1473 SETs(boolSV((UV)aiv < buv));
1481 SETs(boolSV(TOPn < value));
1488 djSP; tryAMAGICbinSET(gt,0);
1489 #ifdef PERL_PRESERVE_IVUV
1492 SvIV_please(TOPm1s);
1493 if (SvIOK(TOPm1s)) {
1494 bool auvok = SvUOK(TOPm1s);
1495 bool buvok = SvUOK(TOPs);
1497 if (!auvok && !buvok) { /* ## IV > IV ## */
1498 IV aiv = SvIVX(TOPm1s);
1499 IV biv = SvIVX(TOPs);
1502 SETs(boolSV(aiv > biv));
1505 if (auvok && buvok) { /* ## UV > UV ## */
1506 UV auv = SvUVX(TOPm1s);
1507 UV buv = SvUVX(TOPs);
1510 SETs(boolSV(auv > buv));
1513 if (auvok) { /* ## UV > IV ## */
1520 /* As (a) is a UV, it's >=0, so it must be > */
1525 if (auv > (UV) IV_MAX) {
1526 /* As (b) is an IV, it cannot be > IV_MAX */
1530 SETs(boolSV(auv > (UV)biv));
1533 { /* ## IV > UV ## */
1537 aiv = SvIVX(TOPm1s);
1539 /* As (b) is a UV, it's >=0, so it cannot be > */
1546 if (buv >= (UV) IV_MAX) {
1547 /* As (a) is an IV, it cannot be > IV_MAX */
1551 SETs(boolSV((UV)aiv > buv));
1559 SETs(boolSV(TOPn > value));
1566 djSP; tryAMAGICbinSET(le,0);
1567 #ifdef PERL_PRESERVE_IVUV
1570 SvIV_please(TOPm1s);
1571 if (SvIOK(TOPm1s)) {
1572 bool auvok = SvUOK(TOPm1s);
1573 bool buvok = SvUOK(TOPs);
1575 if (!auvok && !buvok) { /* ## IV <= IV ## */
1576 IV aiv = SvIVX(TOPm1s);
1577 IV biv = SvIVX(TOPs);
1580 SETs(boolSV(aiv <= biv));
1583 if (auvok && buvok) { /* ## UV <= UV ## */
1584 UV auv = SvUVX(TOPm1s);
1585 UV buv = SvUVX(TOPs);
1588 SETs(boolSV(auv <= buv));
1591 if (auvok) { /* ## UV <= IV ## */
1598 /* As (a) is a UV, it's >=0, so a cannot be <= */
1603 if (auv > (UV) IV_MAX) {
1604 /* As (b) is an IV, it cannot be > IV_MAX */
1608 SETs(boolSV(auv <= (UV)biv));
1611 { /* ## IV <= UV ## */
1615 aiv = SvIVX(TOPm1s);
1617 /* As (b) is a UV, it's >=0, so a must be <= */
1624 if (buv >= (UV) IV_MAX) {
1625 /* As (a) is an IV, it cannot be > IV_MAX */
1629 SETs(boolSV((UV)aiv <= buv));
1637 SETs(boolSV(TOPn <= value));
1644 djSP; tryAMAGICbinSET(ge,0);
1645 #ifdef PERL_PRESERVE_IVUV
1648 SvIV_please(TOPm1s);
1649 if (SvIOK(TOPm1s)) {
1650 bool auvok = SvUOK(TOPm1s);
1651 bool buvok = SvUOK(TOPs);
1653 if (!auvok && !buvok) { /* ## IV >= IV ## */
1654 IV aiv = SvIVX(TOPm1s);
1655 IV biv = SvIVX(TOPs);
1658 SETs(boolSV(aiv >= biv));
1661 if (auvok && buvok) { /* ## UV >= UV ## */
1662 UV auv = SvUVX(TOPm1s);
1663 UV buv = SvUVX(TOPs);
1666 SETs(boolSV(auv >= buv));
1669 if (auvok) { /* ## UV >= IV ## */
1676 /* As (a) is a UV, it's >=0, so it must be >= */
1681 if (auv >= (UV) IV_MAX) {
1682 /* As (b) is an IV, it cannot be > IV_MAX */
1686 SETs(boolSV(auv >= (UV)biv));
1689 { /* ## IV >= UV ## */
1693 aiv = SvIVX(TOPm1s);
1695 /* As (b) is a UV, it's >=0, so a cannot be >= */
1702 if (buv > (UV) IV_MAX) {
1703 /* As (a) is an IV, it cannot be > IV_MAX */
1707 SETs(boolSV((UV)aiv >= buv));
1715 SETs(boolSV(TOPn >= value));
1722 djSP; tryAMAGICbinSET(ne,0);
1723 #ifdef PERL_PRESERVE_IVUV
1726 SvIV_please(TOPm1s);
1727 if (SvIOK(TOPm1s)) {
1728 bool auvok = SvUOK(TOPm1s);
1729 bool buvok = SvUOK(TOPs);
1731 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1732 IV aiv = SvIVX(TOPm1s);
1733 IV biv = SvIVX(TOPs);
1736 SETs(boolSV(aiv != biv));
1739 if (auvok && buvok) { /* ## UV != UV ## */
1740 UV auv = SvUVX(TOPm1s);
1741 UV buv = SvUVX(TOPs);
1744 SETs(boolSV(auv != buv));
1747 { /* ## Mixed IV,UV ## */
1751 /* != is commutative so swap if needed (save code) */
1753 /* swap. top of stack (b) is the iv */
1757 /* As (a) is a UV, it's >0, so it cannot be == */
1766 /* As (b) is a UV, it's >0, so it cannot be == */
1770 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1772 /* we know iv is >= 0 */
1773 if (uv > (UV) IV_MAX) {
1777 SETs(boolSV((UV)iv != uv));
1785 SETs(boolSV(TOPn != value));
1792 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1793 #ifdef PERL_PRESERVE_IVUV
1794 /* Fortunately it seems NaN isn't IOK */
1797 SvIV_please(TOPm1s);
1798 if (SvIOK(TOPm1s)) {
1799 bool leftuvok = SvUOK(TOPm1s);
1800 bool rightuvok = SvUOK(TOPs);
1802 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1803 IV leftiv = SvIVX(TOPm1s);
1804 IV rightiv = SvIVX(TOPs);
1806 if (leftiv > rightiv)
1808 else if (leftiv < rightiv)
1812 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1813 UV leftuv = SvUVX(TOPm1s);
1814 UV rightuv = SvUVX(TOPs);
1816 if (leftuv > rightuv)
1818 else if (leftuv < rightuv)
1822 } else if (leftuvok) { /* ## UV <=> IV ## */
1826 rightiv = SvIVX(TOPs);
1828 /* As (a) is a UV, it's >=0, so it cannot be < */
1831 leftuv = SvUVX(TOPm1s);
1832 if (leftuv > (UV) IV_MAX) {
1833 /* As (b) is an IV, it cannot be > IV_MAX */
1835 } else if (leftuv > (UV)rightiv) {
1837 } else if (leftuv < (UV)rightiv) {
1843 } else { /* ## IV <=> UV ## */
1847 leftiv = SvIVX(TOPm1s);
1849 /* As (b) is a UV, it's >=0, so it must be < */
1852 rightuv = SvUVX(TOPs);
1853 if (rightuv > (UV) IV_MAX) {
1854 /* As (a) is an IV, it cannot be > IV_MAX */
1856 } else if (leftiv > (UV)rightuv) {
1858 } else if (leftiv < (UV)rightuv) {
1876 if (Perl_isnan(left) || Perl_isnan(right)) {
1880 value = (left > right) - (left < right);
1884 else if (left < right)
1886 else if (left > right)
1900 djSP; tryAMAGICbinSET(slt,0);
1903 int cmp = ((PL_op->op_private & OPpLOCALE)
1904 ? sv_cmp_locale(left, right)
1905 : sv_cmp(left, right));
1906 SETs(boolSV(cmp < 0));
1913 djSP; tryAMAGICbinSET(sgt,0);
1916 int cmp = ((PL_op->op_private & OPpLOCALE)
1917 ? sv_cmp_locale(left, right)
1918 : sv_cmp(left, right));
1919 SETs(boolSV(cmp > 0));
1926 djSP; tryAMAGICbinSET(sle,0);
1929 int cmp = ((PL_op->op_private & OPpLOCALE)
1930 ? sv_cmp_locale(left, right)
1931 : sv_cmp(left, right));
1932 SETs(boolSV(cmp <= 0));
1939 djSP; tryAMAGICbinSET(sge,0);
1942 int cmp = ((PL_op->op_private & OPpLOCALE)
1943 ? sv_cmp_locale(left, right)
1944 : sv_cmp(left, right));
1945 SETs(boolSV(cmp >= 0));
1952 djSP; tryAMAGICbinSET(seq,0);
1955 SETs(boolSV(sv_eq(left, right)));
1962 djSP; tryAMAGICbinSET(sne,0);
1965 SETs(boolSV(!sv_eq(left, right)));
1972 djSP; dTARGET; tryAMAGICbin(scmp,0);
1975 int cmp = ((PL_op->op_private & OPpLOCALE)
1976 ? sv_cmp_locale(left, right)
1977 : sv_cmp(left, right));
1985 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1988 if (SvNIOKp(left) || SvNIOKp(right)) {
1989 if (PL_op->op_private & HINT_INTEGER) {
1990 IV i = SvIV(left) & SvIV(right);
1994 UV u = SvUV(left) & SvUV(right);
1999 do_vop(PL_op->op_type, TARG, left, right);
2008 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2011 if (SvNIOKp(left) || SvNIOKp(right)) {
2012 if (PL_op->op_private & HINT_INTEGER) {
2013 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2017 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2022 do_vop(PL_op->op_type, TARG, left, right);
2031 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2034 if (SvNIOKp(left) || SvNIOKp(right)) {
2035 if (PL_op->op_private & HINT_INTEGER) {
2036 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2040 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2045 do_vop(PL_op->op_type, TARG, left, right);
2054 djSP; dTARGET; tryAMAGICun(neg);
2057 int flags = SvFLAGS(sv);
2060 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2061 /* It's publicly an integer, or privately an integer-not-float */
2064 if (SvIVX(sv) == IV_MIN) {
2065 /* 2s complement assumption. */
2066 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2069 else if (SvUVX(sv) <= IV_MAX) {
2074 else if (SvIVX(sv) != IV_MIN) {
2078 #ifdef PERL_PRESERVE_IVUV
2087 else if (SvPOKp(sv)) {
2089 char *s = SvPV(sv, len);
2090 if (isIDFIRST(*s)) {
2091 sv_setpvn(TARG, "-", 1);
2094 else if (*s == '+' || *s == '-') {
2096 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2098 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
2099 sv_setpvn(TARG, "-", 1);
2105 goto oops_its_an_int;
2106 sv_setnv(TARG, -SvNV(sv));
2118 djSP; tryAMAGICunSET(not);
2119 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2125 djSP; dTARGET; tryAMAGICun(compl);
2129 if (PL_op->op_private & HINT_INTEGER) {
2144 tmps = (U8*)SvPV_force(TARG, len);
2147 /* Calculate exact length, let's not estimate. */
2156 while (tmps < send) {
2157 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2158 tmps += UTF8SKIP(tmps);
2159 targlen += UNISKIP(~c);
2165 /* Now rewind strings and write them. */
2169 Newz(0, result, targlen + 1, U8);
2170 while (tmps < send) {
2171 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2172 tmps += UTF8SKIP(tmps);
2173 result = uv_to_utf8(result, ~c);
2177 sv_setpvn(TARG, (char*)result, targlen);
2181 Newz(0, result, nchar + 1, U8);
2182 while (tmps < send) {
2183 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
2184 tmps += UTF8SKIP(tmps);
2189 sv_setpvn(TARG, (char*)result, nchar);
2197 register long *tmpl;
2198 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2201 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2206 for ( ; anum > 0; anum--, tmps++)
2215 /* integer versions of some of the above */
2219 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2222 SETi( left * right );
2229 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2233 DIE(aTHX_ "Illegal division by zero");
2234 value = POPi / value;
2242 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2246 DIE(aTHX_ "Illegal modulus zero");
2247 SETi( left % right );
2254 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2257 SETi( left + right );
2264 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2267 SETi( left - right );
2274 djSP; tryAMAGICbinSET(lt,0);
2277 SETs(boolSV(left < right));
2284 djSP; tryAMAGICbinSET(gt,0);
2287 SETs(boolSV(left > right));
2294 djSP; tryAMAGICbinSET(le,0);
2297 SETs(boolSV(left <= right));
2304 djSP; tryAMAGICbinSET(ge,0);
2307 SETs(boolSV(left >= right));
2314 djSP; tryAMAGICbinSET(eq,0);
2317 SETs(boolSV(left == right));
2324 djSP; tryAMAGICbinSET(ne,0);
2327 SETs(boolSV(left != right));
2334 djSP; dTARGET; tryAMAGICbin(ncmp,0);
2341 else if (left < right)
2352 djSP; dTARGET; tryAMAGICun(neg);
2357 /* High falutin' math. */
2361 djSP; dTARGET; tryAMAGICbin(atan2,0);
2364 SETn(Perl_atan2(left, right));
2371 djSP; dTARGET; tryAMAGICun(sin);
2375 value = Perl_sin(value);
2383 djSP; dTARGET; tryAMAGICun(cos);
2387 value = Perl_cos(value);
2393 /* Support Configure command-line overrides for rand() functions.
2394 After 5.005, perhaps we should replace this by Configure support
2395 for drand48(), random(), or rand(). For 5.005, though, maintain
2396 compatibility by calling rand() but allow the user to override it.
2397 See INSTALL for details. --Andy Dougherty 15 July 1998
2399 /* Now it's after 5.005, and Configure supports drand48() and random(),
2400 in addition to rand(). So the overrides should not be needed any more.
2401 --Jarkko Hietaniemi 27 September 1998
2404 #ifndef HAS_DRAND48_PROTO
2405 extern double drand48 (void);
2418 if (!PL_srand_called) {
2419 (void)seedDrand01((Rand_seed_t)seed());
2420 PL_srand_called = TRUE;
2435 (void)seedDrand01((Rand_seed_t)anum);
2436 PL_srand_called = TRUE;
2445 * This is really just a quick hack which grabs various garbage
2446 * values. It really should be a real hash algorithm which
2447 * spreads the effect of every input bit onto every output bit,
2448 * if someone who knows about such things would bother to write it.
2449 * Might be a good idea to add that function to CORE as well.
2450 * No numbers below come from careful analysis or anything here,
2451 * except they are primes and SEED_C1 > 1E6 to get a full-width
2452 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2453 * probably be bigger too.
2456 # define SEED_C1 1000003
2457 #define SEED_C4 73819
2459 # define SEED_C1 25747
2460 #define SEED_C4 20639
2464 #define SEED_C5 26107
2466 #ifndef PERL_NO_DEV_RANDOM
2471 # include <starlet.h>
2472 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2473 * in 100-ns units, typically incremented ever 10 ms. */
2474 unsigned int when[2];
2476 # ifdef HAS_GETTIMEOFDAY
2477 struct timeval when;
2483 /* This test is an escape hatch, this symbol isn't set by Configure. */
2484 #ifndef PERL_NO_DEV_RANDOM
2485 #ifndef PERL_RANDOM_DEVICE
2486 /* /dev/random isn't used by default because reads from it will block
2487 * if there isn't enough entropy available. You can compile with
2488 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2489 * is enough real entropy to fill the seed. */
2490 # define PERL_RANDOM_DEVICE "/dev/urandom"
2492 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2494 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2503 _ckvmssts(sys$gettim(when));
2504 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2506 # ifdef HAS_GETTIMEOFDAY
2507 gettimeofday(&when,(struct timezone *) 0);
2508 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2511 u = (U32)SEED_C1 * when;
2514 u += SEED_C3 * (U32)PerlProc_getpid();
2515 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2516 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2517 u += SEED_C5 * (U32)PTR2UV(&when);
2524 djSP; dTARGET; tryAMAGICun(exp);
2528 value = Perl_exp(value);
2536 djSP; dTARGET; tryAMAGICun(log);
2541 SET_NUMERIC_STANDARD();
2542 DIE(aTHX_ "Can't take log of %g", value);
2544 value = Perl_log(value);
2552 djSP; dTARGET; tryAMAGICun(sqrt);
2557 SET_NUMERIC_STANDARD();
2558 DIE(aTHX_ "Can't take sqrt of %g", value);
2560 value = Perl_sqrt(value);
2571 IV iv = TOPi; /* attempt to convert to IV if possible. */
2572 /* XXX it's arguable that compiler casting to IV might be subtly
2573 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2574 else preferring IV has introduced a subtle behaviour change bug. OTOH
2575 relying on floating point to be accurate is a bug. */
2586 if (value < (NV)UV_MAX + 0.5) {
2589 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2590 (void)Perl_modf(value, &value);
2592 double tmp = (double)value;
2593 (void)Perl_modf(tmp, &tmp);
2599 if (value > (NV)IV_MIN - 0.5) {
2602 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2603 (void)Perl_modf(-value, &value);
2606 double tmp = (double)value;
2607 (void)Perl_modf(-tmp, &tmp);
2620 djSP; dTARGET; tryAMAGICun(abs);
2622 /* This will cache the NV value if string isn't actually integer */
2626 /* IVX is precise */
2628 SETu(TOPu); /* force it to be numeric only */
2636 /* 2s complement assumption. Also, not really needed as
2637 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2660 argtype = 1; /* allow underscores */
2661 XPUSHn(scan_hex(tmps, 99, &argtype));
2674 while (*tmps && isSPACE(*tmps))
2678 argtype = 1; /* allow underscores */
2680 value = scan_hex(++tmps, 99, &argtype);
2681 else if (*tmps == 'b')
2682 value = scan_bin(++tmps, 99, &argtype);
2684 value = scan_oct(tmps, 99, &argtype);
2697 SETi(sv_len_utf8(sv));
2713 I32 lvalue = PL_op->op_flags & OPf_MOD;
2715 I32 arybase = PL_curcop->cop_arybase;
2719 SvTAINTED_off(TARG); /* decontaminate */
2720 SvUTF8_off(TARG); /* decontaminate */
2724 repl = SvPV(sv, repl_len);
2731 tmps = SvPV(sv, curlen);
2733 utfcurlen = sv_len_utf8(sv);
2734 if (utfcurlen == curlen)
2742 if (pos >= arybase) {
2760 else if (len >= 0) {
2762 if (rem > (I32)curlen)
2777 Perl_croak(aTHX_ "substr outside of string");
2778 if (ckWARN(WARN_SUBSTR))
2779 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2784 sv_pos_u2b(sv, &pos, &rem);
2786 sv_setpvn(TARG, tmps, rem);
2790 sv_insert(sv, pos, rem, repl, repl_len);
2791 else if (lvalue) { /* it's an lvalue! */
2792 if (!SvGMAGICAL(sv)) {
2796 if (ckWARN(WARN_SUBSTR))
2797 Perl_warner(aTHX_ WARN_SUBSTR,
2798 "Attempt to use reference as lvalue in substr");
2800 if (SvOK(sv)) /* is it defined ? */
2801 (void)SvPOK_only_UTF8(sv);
2803 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2806 if (SvTYPE(TARG) < SVt_PVLV) {
2807 sv_upgrade(TARG, SVt_PVLV);
2808 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2812 if (LvTARG(TARG) != sv) {
2814 SvREFCNT_dec(LvTARG(TARG));
2815 LvTARG(TARG) = SvREFCNT_inc(sv);
2817 LvTARGOFF(TARG) = pos;
2818 LvTARGLEN(TARG) = rem;
2822 PUSHs(TARG); /* avoid SvSETMAGIC here */
2829 register IV size = POPi;
2830 register IV offset = POPi;
2831 register SV *src = POPs;
2832 I32 lvalue = PL_op->op_flags & OPf_MOD;
2834 SvTAINTED_off(TARG); /* decontaminate */
2835 if (lvalue) { /* it's an lvalue! */
2836 if (SvTYPE(TARG) < SVt_PVLV) {
2837 sv_upgrade(TARG, SVt_PVLV);
2838 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2841 if (LvTARG(TARG) != src) {
2843 SvREFCNT_dec(LvTARG(TARG));
2844 LvTARG(TARG) = SvREFCNT_inc(src);
2846 LvTARGOFF(TARG) = offset;
2847 LvTARGLEN(TARG) = size;
2850 sv_setuv(TARG, do_vecget(src, offset, size));
2865 I32 arybase = PL_curcop->cop_arybase;
2870 offset = POPi - arybase;
2873 tmps = SvPV(big, biglen);
2874 if (offset > 0 && DO_UTF8(big))
2875 sv_pos_u2b(big, &offset, 0);
2878 else if (offset > biglen)
2880 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2881 (unsigned char*)tmps + biglen, little, 0)))
2884 retval = tmps2 - tmps;
2885 if (retval > 0 && DO_UTF8(big))
2886 sv_pos_b2u(big, &retval);
2887 PUSHi(retval + arybase);
2902 I32 arybase = PL_curcop->cop_arybase;
2908 tmps2 = SvPV(little, llen);
2909 tmps = SvPV(big, blen);
2913 if (offset > 0 && DO_UTF8(big))
2914 sv_pos_u2b(big, &offset, 0);
2915 offset = offset - arybase + llen;
2919 else if (offset > blen)
2921 if (!(tmps2 = rninstr(tmps, tmps + offset,
2922 tmps2, tmps2 + llen)))
2925 retval = tmps2 - tmps;
2926 if (retval > 0 && DO_UTF8(big))
2927 sv_pos_b2u(big, &retval);
2928 PUSHi(retval + arybase);
2934 djSP; dMARK; dORIGMARK; dTARGET;
2935 do_sprintf(TARG, SP-MARK, MARK+1);
2936 TAINT_IF(SvTAINTED(TARG));
2948 U8 *tmps = (U8*)SvPVx(tmpsv, len);
2951 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2952 value = utf8_to_uv(tmps, len, &retlen, 0);
2954 value = (UV)(*tmps & 255);
2965 (void)SvUPGRADE(TARG,SVt_PV);
2967 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2968 SvGROW(TARG, UTF8_MAXLEN+1);
2970 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2971 SvCUR_set(TARG, tmps - SvPVX(TARG));
2973 (void)SvPOK_only(TARG);
2984 (void)SvPOK_only(TARG);
2991 djSP; dTARGET; dPOPTOPssrl;
2994 char *tmps = SvPV(left, n_a);
2996 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2998 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3002 "The crypt() function is unimplemented due to excessive paranoia.");
3015 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
3017 U8 tmpbuf[UTF8_MAXLEN+1];
3019 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3021 if (PL_op->op_private & OPpLOCALE) {
3024 uv = toTITLE_LC_uni(uv);
3027 uv = toTITLE_utf8(s);
3029 tend = uv_to_utf8(tmpbuf, uv);
3031 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3033 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3034 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3039 s = (U8*)SvPV_force(sv, slen);
3040 Copy(tmpbuf, s, ulen, U8);
3044 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3046 SvUTF8_off(TARG); /* decontaminate */
3051 s = (U8*)SvPV_force(sv, slen);
3053 if (PL_op->op_private & OPpLOCALE) {
3056 *s = toUPPER_LC(*s);
3074 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
3076 U8 tmpbuf[UTF8_MAXLEN+1];
3078 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3080 if (PL_op->op_private & OPpLOCALE) {
3083 uv = toLOWER_LC_uni(uv);
3086 uv = toLOWER_utf8(s);
3088 tend = uv_to_utf8(tmpbuf, uv);
3090 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3092 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3093 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3098 s = (U8*)SvPV_force(sv, slen);
3099 Copy(tmpbuf, s, ulen, U8);
3103 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3105 SvUTF8_off(TARG); /* decontaminate */
3110 s = (U8*)SvPV_force(sv, slen);
3112 if (PL_op->op_private & OPpLOCALE) {
3115 *s = toLOWER_LC(*s);
3139 s = (U8*)SvPV(sv,len);
3141 SvUTF8_off(TARG); /* decontaminate */
3142 sv_setpvn(TARG, "", 0);
3146 (void)SvUPGRADE(TARG, SVt_PV);
3147 SvGROW(TARG, (len * 2) + 1);
3148 (void)SvPOK_only(TARG);
3149 d = (U8*)SvPVX(TARG);
3151 if (PL_op->op_private & OPpLOCALE) {
3155 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3161 d = uv_to_utf8(d, toUPPER_utf8( s ));
3167 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3172 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3174 SvUTF8_off(TARG); /* decontaminate */
3179 s = (U8*)SvPV_force(sv, len);
3181 register U8 *send = s + len;
3183 if (PL_op->op_private & OPpLOCALE) {
3186 for (; s < send; s++)
3187 *s = toUPPER_LC(*s);
3190 for (; s < send; s++)
3213 s = (U8*)SvPV(sv,len);
3215 SvUTF8_off(TARG); /* decontaminate */
3216 sv_setpvn(TARG, "", 0);
3220 (void)SvUPGRADE(TARG, SVt_PV);
3221 SvGROW(TARG, (len * 2) + 1);
3222 (void)SvPOK_only(TARG);
3223 d = (U8*)SvPVX(TARG);
3225 if (PL_op->op_private & OPpLOCALE) {
3229 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3235 d = uv_to_utf8(d, toLOWER_utf8(s));
3241 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3246 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3248 SvUTF8_off(TARG); /* decontaminate */
3254 s = (U8*)SvPV_force(sv, len);
3256 register U8 *send = s + len;
3258 if (PL_op->op_private & OPpLOCALE) {
3261 for (; s < send; s++)
3262 *s = toLOWER_LC(*s);
3265 for (; s < send; s++)
3280 register char *s = SvPV(sv,len);
3283 SvUTF8_off(TARG); /* decontaminate */
3285 (void)SvUPGRADE(TARG, SVt_PV);
3286 SvGROW(TARG, (len * 2) + 1);
3291 STRLEN ulen = UTF8SKIP(s);
3315 SvCUR_set(TARG, d - SvPVX(TARG));
3316 (void)SvPOK_only_UTF8(TARG);
3319 sv_setpvn(TARG, s, len);
3321 if (SvSMAGICAL(TARG))
3330 djSP; dMARK; dORIGMARK;
3332 register AV* av = (AV*)POPs;
3333 register I32 lval = PL_op->op_flags & OPf_MOD;
3334 I32 arybase = PL_curcop->cop_arybase;
3337 if (SvTYPE(av) == SVt_PVAV) {
3338 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3340 for (svp = MARK + 1; svp <= SP; svp++) {
3345 if (max > AvMAX(av))
3348 while (++MARK <= SP) {
3349 elem = SvIVx(*MARK);
3353 svp = av_fetch(av, elem, lval);
3355 if (!svp || *svp == &PL_sv_undef)
3356 DIE(aTHX_ PL_no_aelem, elem);
3357 if (PL_op->op_private & OPpLVAL_INTRO)
3358 save_aelem(av, elem, svp);
3360 *MARK = svp ? *svp : &PL_sv_undef;
3363 if (GIMME != G_ARRAY) {
3371 /* Associative arrays. */
3376 HV *hash = (HV*)POPs;
3378 I32 gimme = GIMME_V;
3379 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3382 /* might clobber stack_sp */
3383 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3388 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3389 if (gimme == G_ARRAY) {
3392 /* might clobber stack_sp */
3394 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3399 else if (gimme == G_SCALAR)
3418 I32 gimme = GIMME_V;
3419 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3423 if (PL_op->op_private & OPpSLICE) {
3427 hvtype = SvTYPE(hv);
3428 if (hvtype == SVt_PVHV) { /* hash element */
3429 while (++MARK <= SP) {
3430 sv = hv_delete_ent(hv, *MARK, discard, 0);
3431 *MARK = sv ? sv : &PL_sv_undef;
3434 else if (hvtype == SVt_PVAV) {
3435 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3436 while (++MARK <= SP) {
3437 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3438 *MARK = sv ? sv : &PL_sv_undef;
3441 else { /* pseudo-hash element */
3442 while (++MARK <= SP) {
3443 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3444 *MARK = sv ? sv : &PL_sv_undef;
3449 DIE(aTHX_ "Not a HASH reference");
3452 else if (gimme == G_SCALAR) {
3461 if (SvTYPE(hv) == SVt_PVHV)
3462 sv = hv_delete_ent(hv, keysv, discard, 0);
3463 else if (SvTYPE(hv) == SVt_PVAV) {
3464 if (PL_op->op_flags & OPf_SPECIAL)
3465 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3467 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3470 DIE(aTHX_ "Not a HASH reference");
3485 if (PL_op->op_private & OPpEXISTS_SUB) {
3489 cv = sv_2cv(sv, &hv, &gv, FALSE);
3492 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3498 if (SvTYPE(hv) == SVt_PVHV) {
3499 if (hv_exists_ent(hv, tmpsv, 0))
3502 else if (SvTYPE(hv) == SVt_PVAV) {
3503 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3504 if (av_exists((AV*)hv, SvIV(tmpsv)))
3507 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3511 DIE(aTHX_ "Not a HASH reference");
3518 djSP; dMARK; dORIGMARK;
3519 register HV *hv = (HV*)POPs;
3520 register I32 lval = PL_op->op_flags & OPf_MOD;
3521 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3523 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3524 DIE(aTHX_ "Can't localize pseudo-hash element");
3526 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3527 while (++MARK <= SP) {
3530 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3532 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3533 svp = he ? &HeVAL(he) : 0;
3536 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3539 if (!svp || *svp == &PL_sv_undef) {
3541 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3543 if (PL_op->op_private & OPpLVAL_INTRO) {
3545 save_helem(hv, keysv, svp);
3548 char *key = SvPV(keysv, keylen);
3549 save_delete(hv, key, keylen);
3553 *MARK = svp ? *svp : &PL_sv_undef;
3556 if (GIMME != G_ARRAY) {
3564 /* List operators. */
3569 if (GIMME != G_ARRAY) {
3571 *MARK = *SP; /* unwanted list, return last item */
3573 *MARK = &PL_sv_undef;
3582 SV **lastrelem = PL_stack_sp;
3583 SV **lastlelem = PL_stack_base + POPMARK;
3584 SV **firstlelem = PL_stack_base + POPMARK + 1;
3585 register SV **firstrelem = lastlelem + 1;
3586 I32 arybase = PL_curcop->cop_arybase;
3587 I32 lval = PL_op->op_flags & OPf_MOD;
3588 I32 is_something_there = lval;
3590 register I32 max = lastrelem - lastlelem;
3591 register SV **lelem;
3594 if (GIMME != G_ARRAY) {
3595 ix = SvIVx(*lastlelem);
3600 if (ix < 0 || ix >= max)
3601 *firstlelem = &PL_sv_undef;
3603 *firstlelem = firstrelem[ix];
3609 SP = firstlelem - 1;
3613 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3619 if (ix < 0 || ix >= max)
3620 *lelem = &PL_sv_undef;
3622 is_something_there = TRUE;
3623 if (!(*lelem = firstrelem[ix]))
3624 *lelem = &PL_sv_undef;
3627 if (is_something_there)
3630 SP = firstlelem - 1;
3636 djSP; dMARK; dORIGMARK;
3637 I32 items = SP - MARK;
3638 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3639 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3646 djSP; dMARK; dORIGMARK;
3647 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3651 SV *val = NEWSV(46, 0);
3653 sv_setsv(val, *++MARK);
3654 else if (ckWARN(WARN_MISC))
3655 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3656 (void)hv_store_ent(hv,key,val,0);
3665 djSP; dMARK; dORIGMARK;
3666 register AV *ary = (AV*)*++MARK;
3670 register I32 offset;
3671 register I32 length;
3678 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3679 *MARK-- = SvTIED_obj((SV*)ary, mg);
3683 call_method("SPLICE",GIMME_V);
3692 offset = i = SvIVx(*MARK);
3694 offset += AvFILLp(ary) + 1;
3696 offset -= PL_curcop->cop_arybase;
3698 DIE(aTHX_ PL_no_aelem, i);
3700 length = SvIVx(*MARK++);
3702 length += AvFILLp(ary) - offset + 1;
3708 length = AvMAX(ary) + 1; /* close enough to infinity */
3712 length = AvMAX(ary) + 1;
3714 if (offset > AvFILLp(ary) + 1)
3715 offset = AvFILLp(ary) + 1;
3716 after = AvFILLp(ary) + 1 - (offset + length);
3717 if (after < 0) { /* not that much array */
3718 length += after; /* offset+length now in array */
3724 /* At this point, MARK .. SP-1 is our new LIST */
3727 diff = newlen - length;
3728 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3731 if (diff < 0) { /* shrinking the area */
3733 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3734 Copy(MARK, tmparyval, newlen, SV*);
3737 MARK = ORIGMARK + 1;
3738 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3739 MEXTEND(MARK, length);
3740 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3742 EXTEND_MORTAL(length);
3743 for (i = length, dst = MARK; i; i--) {
3744 sv_2mortal(*dst); /* free them eventualy */
3751 *MARK = AvARRAY(ary)[offset+length-1];
3754 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3755 SvREFCNT_dec(*dst++); /* free them now */
3758 AvFILLp(ary) += diff;
3760 /* pull up or down? */
3762 if (offset < after) { /* easier to pull up */
3763 if (offset) { /* esp. if nothing to pull */
3764 src = &AvARRAY(ary)[offset-1];
3765 dst = src - diff; /* diff is negative */
3766 for (i = offset; i > 0; i--) /* can't trust Copy */
3770 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3774 if (after) { /* anything to pull down? */
3775 src = AvARRAY(ary) + offset + length;
3776 dst = src + diff; /* diff is negative */
3777 Move(src, dst, after, SV*);
3779 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3780 /* avoid later double free */
3784 dst[--i] = &PL_sv_undef;
3787 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3789 *dst = NEWSV(46, 0);
3790 sv_setsv(*dst++, *src++);
3792 Safefree(tmparyval);
3795 else { /* no, expanding (or same) */
3797 New(452, tmparyval, length, SV*); /* so remember deletion */
3798 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3801 if (diff > 0) { /* expanding */
3803 /* push up or down? */
3805 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3809 Move(src, dst, offset, SV*);
3811 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3813 AvFILLp(ary) += diff;
3816 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3817 av_extend(ary, AvFILLp(ary) + diff);
3818 AvFILLp(ary) += diff;
3821 dst = AvARRAY(ary) + AvFILLp(ary);
3823 for (i = after; i; i--) {
3830 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3831 *dst = NEWSV(46, 0);
3832 sv_setsv(*dst++, *src++);
3834 MARK = ORIGMARK + 1;
3835 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3837 Copy(tmparyval, MARK, length, SV*);
3839 EXTEND_MORTAL(length);
3840 for (i = length, dst = MARK; i; i--) {
3841 sv_2mortal(*dst); /* free them eventualy */
3845 Safefree(tmparyval);
3849 else if (length--) {
3850 *MARK = tmparyval[length];
3853 while (length-- > 0)
3854 SvREFCNT_dec(tmparyval[length]);
3856 Safefree(tmparyval);
3859 *MARK = &PL_sv_undef;
3867 djSP; dMARK; dORIGMARK; dTARGET;
3868 register AV *ary = (AV*)*++MARK;
3869 register SV *sv = &PL_sv_undef;
3872 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3873 *MARK-- = SvTIED_obj((SV*)ary, mg);
3877 call_method("PUSH",G_SCALAR|G_DISCARD);
3882 /* Why no pre-extend of ary here ? */
3883 for (++MARK; MARK <= SP; MARK++) {
3886 sv_setsv(sv, *MARK);
3891 PUSHi( AvFILL(ary) + 1 );
3899 SV *sv = av_pop(av);
3901 (void)sv_2mortal(sv);
3910 SV *sv = av_shift(av);
3915 (void)sv_2mortal(sv);
3922 djSP; dMARK; dORIGMARK; dTARGET;
3923 register AV *ary = (AV*)*++MARK;
3928 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3929 *MARK-- = SvTIED_obj((SV*)ary, mg);
3933 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3938 av_unshift(ary, SP - MARK);
3941 sv_setsv(sv, *++MARK);
3942 (void)av_store(ary, i++, sv);
3946 PUSHi( AvFILL(ary) + 1 );
3956 if (GIMME == G_ARRAY) {
3963 /* safe as long as stack cannot get extended in the above */
3968 register char *down;
3973 SvUTF8_off(TARG); /* decontaminate */
3975 do_join(TARG, &PL_sv_no, MARK, SP);
3977 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3978 up = SvPV_force(TARG, len);
3980 if (DO_UTF8(TARG)) { /* first reverse each character */
3981 U8* s = (U8*)SvPVX(TARG);
3982 U8* send = (U8*)(s + len);
3991 down = (char*)(s - 1);
3992 if (s > send || !((*down & 0xc0) == 0x80)) {
3993 if (ckWARN_d(WARN_UTF8))
3994 Perl_warner(aTHX_ WARN_UTF8,
3995 "Malformed UTF-8 character");
4007 down = SvPVX(TARG) + len - 1;
4013 (void)SvPOK_only_UTF8(TARG);
4022 S_mul128(pTHX_ SV *sv, U8 m)
4025 char *s = SvPV(sv, len);
4029 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4030 SV *tmpNew = newSVpvn("0000000000", 10);
4032 sv_catsv(tmpNew, sv);
4033 SvREFCNT_dec(sv); /* free old sv */
4038 while (!*t) /* trailing '\0'? */
4041 i = ((*t - '0') << 7) + m;
4042 *(t--) = '0' + (i % 10);
4048 /* Explosives and implosives. */
4050 #if 'I' == 73 && 'J' == 74
4051 /* On an ASCII/ISO kind of system */
4052 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4055 Some other sort of character set - use memchr() so we don't match
4058 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4065 I32 start_sp_offset = SP - PL_stack_base;
4066 I32 gimme = GIMME_V;
4070 register char *pat = SvPV(left, llen);
4071 register char *s = SvPV(right, rlen);
4072 char *strend = s + rlen;
4074 register char *patend = pat + llen;
4080 /* These must not be in registers: */
4097 register U32 culong;
4101 #ifdef PERL_NATINT_PACK
4102 int natint; /* native integer */
4103 int unatint; /* unsigned native integer */
4106 if (gimme != G_ARRAY) { /* arrange to do first one only */
4108 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4109 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4111 while (isDIGIT(*patend) || *patend == '*')
4117 while (pat < patend) {
4119 datumtype = *pat++ & 0xFF;
4120 #ifdef PERL_NATINT_PACK
4123 if (isSPACE(datumtype))
4125 if (datumtype == '#') {
4126 while (pat < patend && *pat != '\n')
4131 char *natstr = "sSiIlL";
4133 if (strchr(natstr, datumtype)) {
4134 #ifdef PERL_NATINT_PACK
4140 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4145 else if (*pat == '*') {
4146 len = strend - strbeg; /* long enough */
4150 else if (isDIGIT(*pat)) {
4152 while (isDIGIT(*pat)) {
4153 len = (len * 10) + (*pat++ - '0');
4155 DIE(aTHX_ "Repeat count in unpack overflows");
4159 len = (datumtype != '@');
4163 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4164 case ',': /* grandfather in commas but with a warning */
4165 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4166 Perl_warner(aTHX_ WARN_UNPACK,
4167 "Invalid type in unpack: '%c'", (int)datumtype);
4170 if (len == 1 && pat[-1] != '1')
4179 if (len > strend - strbeg)
4180 DIE(aTHX_ "@ outside of string");
4184 if (len > s - strbeg)
4185 DIE(aTHX_ "X outside of string");
4189 if (len > strend - s)
4190 DIE(aTHX_ "x outside of string");
4194 if (start_sp_offset >= SP - PL_stack_base)
4195 DIE(aTHX_ "/ must follow a numeric type");
4198 pat++; /* ignore '*' for compatibility with pack */
4200 DIE(aTHX_ "/ cannot take a count" );
4207 if (len > strend - s)
4210 goto uchar_checksum;
4211 sv = NEWSV(35, len);
4212 sv_setpvn(sv, s, len);
4214 if (datumtype == 'A' || datumtype == 'Z') {
4215 aptr = s; /* borrow register */
4216 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4221 else { /* 'A' strips both nulls and spaces */
4222 s = SvPVX(sv) + len - 1;
4223 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4227 SvCUR_set(sv, s - SvPVX(sv));
4228 s = aptr; /* unborrow register */
4230 XPUSHs(sv_2mortal(sv));
4234 if (star || len > (strend - s) * 8)
4235 len = (strend - s) * 8;
4238 Newz(601, PL_bitcount, 256, char);
4239 for (bits = 1; bits < 256; bits++) {
4240 if (bits & 1) PL_bitcount[bits]++;
4241 if (bits & 2) PL_bitcount[bits]++;
4242 if (bits & 4) PL_bitcount[bits]++;
4243 if (bits & 8) PL_bitcount[bits]++;
4244 if (bits & 16) PL_bitcount[bits]++;
4245 if (bits & 32) PL_bitcount[bits]++;
4246 if (bits & 64) PL_bitcount[bits]++;
4247 if (bits & 128) PL_bitcount[bits]++;
4251 culong += PL_bitcount[*(unsigned char*)s++];
4256 if (datumtype == 'b') {
4258 if (bits & 1) culong++;
4264 if (bits & 128) culong++;
4271 sv = NEWSV(35, len + 1);
4275 if (datumtype == 'b') {
4277 for (len = 0; len < aint; len++) {
4278 if (len & 7) /*SUPPRESS 595*/
4282 *str++ = '0' + (bits & 1);
4287 for (len = 0; len < aint; len++) {
4292 *str++ = '0' + ((bits & 128) != 0);
4296 XPUSHs(sv_2mortal(sv));
4300 if (star || len > (strend - s) * 2)
4301 len = (strend - s) * 2;
4302 sv = NEWSV(35, len + 1);
4306 if (datumtype == 'h') {
4308 for (len = 0; len < aint; len++) {
4313 *str++ = PL_hexdigit[bits & 15];
4318 for (len = 0; len < aint; len++) {
4323 *str++ = PL_hexdigit[(bits >> 4) & 15];
4327 XPUSHs(sv_2mortal(sv));
4330 if (len > strend - s)
4335 if (aint >= 128) /* fake up signed chars */
4345 if (aint >= 128) /* fake up signed chars */
4348 sv_setiv(sv, (IV)aint);
4349 PUSHs(sv_2mortal(sv));
4354 if (len > strend - s)
4369 sv_setiv(sv, (IV)auint);
4370 PUSHs(sv_2mortal(sv));
4375 if (len > strend - s)
4378 while (len-- > 0 && s < strend) {
4380 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4384 cdouble += (NV)auint;
4392 while (len-- > 0 && s < strend) {
4394 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
4398 sv_setuv(sv, (UV)auint);
4399 PUSHs(sv_2mortal(sv));
4404 #if SHORTSIZE == SIZE16
4405 along = (strend - s) / SIZE16;
4407 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4412 #if SHORTSIZE != SIZE16
4416 COPYNN(s, &ashort, sizeof(short));
4427 #if SHORTSIZE > SIZE16
4439 #if SHORTSIZE != SIZE16
4443 COPYNN(s, &ashort, sizeof(short));
4446 sv_setiv(sv, (IV)ashort);
4447 PUSHs(sv_2mortal(sv));
4455 #if SHORTSIZE > SIZE16
4461 sv_setiv(sv, (IV)ashort);
4462 PUSHs(sv_2mortal(sv));
4470 #if SHORTSIZE == SIZE16
4471 along = (strend - s) / SIZE16;
4473 unatint = natint && datumtype == 'S';
4474 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4479 #if SHORTSIZE != SIZE16
4481 unsigned short aushort;
4483 COPYNN(s, &aushort, sizeof(unsigned short));
4484 s += sizeof(unsigned short);
4492 COPY16(s, &aushort);
4495 if (datumtype == 'n')
4496 aushort = PerlSock_ntohs(aushort);
4499 if (datumtype == 'v')
4500 aushort = vtohs(aushort);
4509 #if SHORTSIZE != SIZE16
4511 unsigned short aushort;
4513 COPYNN(s, &aushort, sizeof(unsigned short));
4514 s += sizeof(unsigned short);
4516 sv_setiv(sv, (UV)aushort);
4517 PUSHs(sv_2mortal(sv));
4524 COPY16(s, &aushort);
4528 if (datumtype == 'n')
4529 aushort = PerlSock_ntohs(aushort);
4532 if (datumtype == 'v')
4533 aushort = vtohs(aushort);
4535 sv_setiv(sv, (UV)aushort);
4536 PUSHs(sv_2mortal(sv));
4542 along = (strend - s) / sizeof(int);
4547 Copy(s, &aint, 1, int);
4550 cdouble += (NV)aint;
4559 Copy(s, &aint, 1, int);
4563 /* Without the dummy below unpack("i", pack("i",-1))
4564 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4565 * cc with optimization turned on.
4567 * The bug was detected in
4568 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4569 * with optimization (-O4) turned on.
4570 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4571 * does not have this problem even with -O4.
4573 * This bug was reported as DECC_BUGS 1431
4574 * and tracked internally as GEM_BUGS 7775.
4576 * The bug is fixed in
4577 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4578 * UNIX V4.0F support: DEC C V5.9-006 or later
4579 * UNIX V4.0E support: DEC C V5.8-011 or later
4582 * See also few lines later for the same bug.
4585 sv_setiv(sv, (IV)aint) :
4587 sv_setiv(sv, (IV)aint);
4588 PUSHs(sv_2mortal(sv));
4593 along = (strend - s) / sizeof(unsigned int);
4598 Copy(s, &auint, 1, unsigned int);
4599 s += sizeof(unsigned int);
4601 cdouble += (NV)auint;
4610 Copy(s, &auint, 1, unsigned int);
4611 s += sizeof(unsigned int);
4614 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4615 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4616 * See details few lines earlier. */
4618 sv_setuv(sv, (UV)auint) :
4620 sv_setuv(sv, (UV)auint);
4621 PUSHs(sv_2mortal(sv));
4626 #if LONGSIZE == SIZE32
4627 along = (strend - s) / SIZE32;
4629 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4634 #if LONGSIZE != SIZE32
4637 COPYNN(s, &along, sizeof(long));
4640 cdouble += (NV)along;
4649 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4653 #if LONGSIZE > SIZE32
4654 if (along > 2147483647)
4655 along -= 4294967296;
4659 cdouble += (NV)along;
4668 #if LONGSIZE != SIZE32
4671 COPYNN(s, &along, sizeof(long));
4674 sv_setiv(sv, (IV)along);
4675 PUSHs(sv_2mortal(sv));
4682 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4686 #if LONGSIZE > SIZE32
4687 if (along > 2147483647)
4688 along -= 4294967296;
4692 sv_setiv(sv, (IV)along);
4693 PUSHs(sv_2mortal(sv));
4701 #if LONGSIZE == SIZE32
4702 along = (strend - s) / SIZE32;
4704 unatint = natint && datumtype == 'L';
4705 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4710 #if LONGSIZE != SIZE32
4712 unsigned long aulong;
4714 COPYNN(s, &aulong, sizeof(unsigned long));
4715 s += sizeof(unsigned long);
4717 cdouble += (NV)aulong;
4729 if (datumtype == 'N')
4730 aulong = PerlSock_ntohl(aulong);
4733 if (datumtype == 'V')
4734 aulong = vtohl(aulong);
4737 cdouble += (NV)aulong;
4746 #if LONGSIZE != SIZE32
4748 unsigned long aulong;
4750 COPYNN(s, &aulong, sizeof(unsigned long));
4751 s += sizeof(unsigned long);
4753 sv_setuv(sv, (UV)aulong);
4754 PUSHs(sv_2mortal(sv));
4764 if (datumtype == 'N')
4765 aulong = PerlSock_ntohl(aulong);
4768 if (datumtype == 'V')
4769 aulong = vtohl(aulong);
4772 sv_setuv(sv, (UV)aulong);
4773 PUSHs(sv_2mortal(sv));
4779 along = (strend - s) / sizeof(char*);
4785 if (sizeof(char*) > strend - s)
4788 Copy(s, &aptr, 1, char*);
4794 PUSHs(sv_2mortal(sv));
4804 while ((len > 0) && (s < strend)) {
4805 auv = (auv << 7) | (*s & 0x7f);
4806 if (!(*s++ & 0x80)) {
4810 PUSHs(sv_2mortal(sv));
4814 else if (++bytes >= sizeof(UV)) { /* promote to string */
4818 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4819 while (s < strend) {
4820 sv = mul128(sv, *s & 0x7f);
4821 if (!(*s++ & 0x80)) {
4830 PUSHs(sv_2mortal(sv));
4835 if ((s >= strend) && bytes)
4836 DIE(aTHX_ "Unterminated compressed integer");
4841 if (sizeof(char*) > strend - s)
4844 Copy(s, &aptr, 1, char*);
4849 sv_setpvn(sv, aptr, len);
4850 PUSHs(sv_2mortal(sv));
4854 along = (strend - s) / sizeof(Quad_t);
4860 if (s + sizeof(Quad_t) > strend)
4863 Copy(s, &aquad, 1, Quad_t);
4864 s += sizeof(Quad_t);
4867 if (aquad >= IV_MIN && aquad <= IV_MAX)
4868 sv_setiv(sv, (IV)aquad);
4870 sv_setnv(sv, (NV)aquad);
4871 PUSHs(sv_2mortal(sv));
4875 along = (strend - s) / sizeof(Quad_t);
4881 if (s + sizeof(Uquad_t) > strend)
4884 Copy(s, &auquad, 1, Uquad_t);
4885 s += sizeof(Uquad_t);
4888 if (auquad <= UV_MAX)
4889 sv_setuv(sv, (UV)auquad);
4891 sv_setnv(sv, (NV)auquad);
4892 PUSHs(sv_2mortal(sv));
4896 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4899 along = (strend - s) / sizeof(float);
4904 Copy(s, &afloat, 1, float);
4913 Copy(s, &afloat, 1, float);
4916 sv_setnv(sv, (NV)afloat);
4917 PUSHs(sv_2mortal(sv));
4923 along = (strend - s) / sizeof(double);
4928 Copy(s, &adouble, 1, double);
4929 s += sizeof(double);
4937 Copy(s, &adouble, 1, double);
4938 s += sizeof(double);
4940 sv_setnv(sv, (NV)adouble);
4941 PUSHs(sv_2mortal(sv));
4947 * Initialise the decode mapping. By using a table driven
4948 * algorithm, the code will be character-set independent
4949 * (and just as fast as doing character arithmetic)
4951 if (PL_uudmap['M'] == 0) {
4954 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4955 PL_uudmap[(U8)PL_uuemap[i]] = i;
4957 * Because ' ' and '`' map to the same value,
4958 * we need to decode them both the same.
4963 along = (strend - s) * 3 / 4;
4964 sv = NEWSV(42, along);
4967 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4972 len = PL_uudmap[*(U8*)s++] & 077;
4974 if (s < strend && ISUUCHAR(*s))
4975 a = PL_uudmap[*(U8*)s++] & 077;
4978 if (s < strend && ISUUCHAR(*s))
4979 b = PL_uudmap[*(U8*)s++] & 077;
4982 if (s < strend && ISUUCHAR(*s))
4983 c = PL_uudmap[*(U8*)s++] & 077;
4986 if (s < strend && ISUUCHAR(*s))
4987 d = PL_uudmap[*(U8*)s++] & 077;
4990 hunk[0] = (a << 2) | (b >> 4);
4991 hunk[1] = (b << 4) | (c >> 2);
4992 hunk[2] = (c << 6) | d;
4993 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4998 else if (s[1] == '\n') /* possible checksum byte */
5001 XPUSHs(sv_2mortal(sv));
5006 if (strchr("fFdD", datumtype) ||
5007 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5011 while (checksum >= 16) {
5015 while (checksum >= 4) {
5021 along = (1 << checksum) - 1;
5022 while (cdouble < 0.0)
5024 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5025 sv_setnv(sv, cdouble);
5028 if (checksum < 32) {
5029 aulong = (1 << checksum) - 1;
5032 sv_setuv(sv, (UV)culong);
5034 XPUSHs(sv_2mortal(sv));
5038 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5039 PUSHs(&PL_sv_undef);
5044 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5048 *hunk = PL_uuemap[len];
5049 sv_catpvn(sv, hunk, 1);
5052 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5053 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5054 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5055 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5056 sv_catpvn(sv, hunk, 4);
5061 char r = (len > 1 ? s[1] : '\0');
5062 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5063 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5064 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5065 hunk[3] = PL_uuemap[0];
5066 sv_catpvn(sv, hunk, 4);
5068 sv_catpvn(sv, "\n", 1);
5072 S_is_an_int(pTHX_ char *s, STRLEN l)
5075 SV *result = newSVpvn(s, l);
5076 char *result_c = SvPV(result, n_a); /* convenience */
5077 char *out = result_c;
5087 SvREFCNT_dec(result);
5110 SvREFCNT_dec(result);
5116 SvCUR_set(result, out - result_c);
5120 /* pnum must be '\0' terminated */
5122 S_div128(pTHX_ SV *pnum, bool *done)
5125 char *s = SvPV(pnum, len);
5134 i = m * 10 + (*t - '0');
5136 r = (i >> 7); /* r < 10 */
5143 SvCUR_set(pnum, (STRLEN) (t - s));
5150 djSP; dMARK; dORIGMARK; dTARGET;
5151 register SV *cat = TARG;
5154 register char *pat = SvPVx(*++MARK, fromlen);
5156 register char *patend = pat + fromlen;
5161 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5162 static char *space10 = " ";
5164 /* These must not be in registers: */
5179 #ifdef PERL_NATINT_PACK
5180 int natint; /* native integer */
5185 sv_setpvn(cat, "", 0);
5187 while (pat < patend) {
5188 SV *lengthcode = Nullsv;
5189 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5190 datumtype = *pat++ & 0xFF;
5191 #ifdef PERL_NATINT_PACK
5194 if (isSPACE(datumtype)) {
5198 if (datumtype == 'U' && pat == patcopy+1)
5200 if (datumtype == '#') {
5201 while (pat < patend && *pat != '\n')
5206 char *natstr = "sSiIlL";
5208 if (strchr(natstr, datumtype)) {
5209 #ifdef PERL_NATINT_PACK
5215 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5218 len = strchr("@Xxu", datumtype) ? 0 : items;
5221 else if (isDIGIT(*pat)) {
5223 while (isDIGIT(*pat)) {
5224 len = (len * 10) + (*pat++ - '0');
5226 DIE(aTHX_ "Repeat count in pack overflows");
5233 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5234 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5235 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5236 ? *MARK : &PL_sv_no)
5237 + (*pat == 'Z' ? 1 : 0)));
5241 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5242 case ',': /* grandfather in commas but with a warning */
5243 if (commas++ == 0 && ckWARN(WARN_PACK))
5244 Perl_warner(aTHX_ WARN_PACK,
5245 "Invalid type in pack: '%c'", (int)datumtype);
5248 DIE(aTHX_ "%% may only be used in unpack");
5259 if (SvCUR(cat) < len)
5260 DIE(aTHX_ "X outside of string");
5267 sv_catpvn(cat, null10, 10);
5270 sv_catpvn(cat, null10, len);
5276 aptr = SvPV(fromstr, fromlen);
5277 if (pat[-1] == '*') {
5279 if (datumtype == 'Z')
5282 if (fromlen >= len) {
5283 sv_catpvn(cat, aptr, len);
5284 if (datumtype == 'Z')
5285 *(SvEND(cat)-1) = '\0';
5288 sv_catpvn(cat, aptr, fromlen);
5290 if (datumtype == 'A') {
5292 sv_catpvn(cat, space10, 10);
5295 sv_catpvn(cat, space10, len);
5299 sv_catpvn(cat, null10, 10);
5302 sv_catpvn(cat, null10, len);
5314 str = SvPV(fromstr, fromlen);
5318 SvCUR(cat) += (len+7)/8;
5319 SvGROW(cat, SvCUR(cat) + 1);
5320 aptr = SvPVX(cat) + aint;
5325 if (datumtype == 'B') {
5326 for (len = 0; len++ < aint;) {
5327 items |= *str++ & 1;
5331 *aptr++ = items & 0xff;
5337 for (len = 0; len++ < aint;) {
5343 *aptr++ = items & 0xff;
5349 if (datumtype == 'B')
5350 items <<= 7 - (aint & 7);
5352 items >>= 7 - (aint & 7);
5353 *aptr++ = items & 0xff;
5355 str = SvPVX(cat) + SvCUR(cat);
5370 str = SvPV(fromstr, fromlen);
5374 SvCUR(cat) += (len+1)/2;
5375 SvGROW(cat, SvCUR(cat) + 1);
5376 aptr = SvPVX(cat) + aint;
5381 if (datumtype == 'H') {
5382 for (len = 0; len++ < aint;) {
5384 items |= ((*str++ & 15) + 9) & 15;
5386 items |= *str++ & 15;
5390 *aptr++ = items & 0xff;
5396 for (len = 0; len++ < aint;) {
5398 items |= (((*str++ & 15) + 9) & 15) << 4;
5400 items |= (*str++ & 15) << 4;
5404 *aptr++ = items & 0xff;
5410 *aptr++ = items & 0xff;
5411 str = SvPVX(cat) + SvCUR(cat);
5422 aint = SvIV(fromstr);
5424 sv_catpvn(cat, &achar, sizeof(char));
5430 auint = SvUV(fromstr);
5431 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5432 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
5437 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5442 afloat = (float)SvNV(fromstr);
5443 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5450 adouble = (double)SvNV(fromstr);
5451 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5457 ashort = (I16)SvIV(fromstr);
5459 ashort = PerlSock_htons(ashort);
5461 CAT16(cat, &ashort);
5467 ashort = (I16)SvIV(fromstr);
5469 ashort = htovs(ashort);
5471 CAT16(cat, &ashort);
5475 #if SHORTSIZE != SIZE16
5477 unsigned short aushort;
5481 aushort = SvUV(fromstr);
5482 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5492 aushort = (U16)SvUV(fromstr);
5493 CAT16(cat, &aushort);
5499 #if SHORTSIZE != SIZE16
5505 ashort = SvIV(fromstr);
5506 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5514 ashort = (I16)SvIV(fromstr);
5515 CAT16(cat, &ashort);
5522 auint = SvUV(fromstr);
5523 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5529 adouble = Perl_floor(SvNV(fromstr));
5532 DIE(aTHX_ "Cannot compress negative numbers");
5535 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5536 adouble <= 0xffffffff
5538 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5539 adouble <= UV_MAX_cxux
5546 char buf[1 + sizeof(UV)];
5547 char *in = buf + sizeof(buf);
5548 UV auv = U_V(adouble);
5551 *--in = (auv & 0x7f) | 0x80;
5554 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5555 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5557 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5558 char *from, *result, *in;
5563 /* Copy string and check for compliance */
5564 from = SvPV(fromstr, len);
5565 if ((norm = is_an_int(from, len)) == NULL)
5566 DIE(aTHX_ "can compress only unsigned integer");
5568 New('w', result, len, char);
5572 *--in = div128(norm, &done) | 0x80;
5573 result[len - 1] &= 0x7F; /* clear continue bit */
5574 sv_catpvn(cat, in, (result + len) - in);
5576 SvREFCNT_dec(norm); /* free norm */
5578 else if (SvNOKp(fromstr)) {
5579 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5580 char *in = buf + sizeof(buf);
5583 double next = floor(adouble / 128);
5584 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5585 if (in <= buf) /* this cannot happen ;-) */
5586 DIE(aTHX_ "Cannot compress integer");
5589 } while (adouble > 0);
5590 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5591 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5594 DIE(aTHX_ "Cannot compress non integer");
5600 aint = SvIV(fromstr);
5601 sv_catpvn(cat, (char*)&aint, sizeof(int));
5607 aulong = SvUV(fromstr);
5609 aulong = PerlSock_htonl(aulong);
5611 CAT32(cat, &aulong);
5617 aulong = SvUV(fromstr);
5619 aulong = htovl(aulong);
5621 CAT32(cat, &aulong);
5625 #if LONGSIZE != SIZE32
5627 unsigned long aulong;
5631 aulong = SvUV(fromstr);
5632 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5640 aulong = SvUV(fromstr);
5641 CAT32(cat, &aulong);
5646 #if LONGSIZE != SIZE32
5652 along = SvIV(fromstr);
5653 sv_catpvn(cat, (char *)&along, sizeof(long));
5661 along = SvIV(fromstr);
5670 auquad = (Uquad_t)SvUV(fromstr);
5671 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5677 aquad = (Quad_t)SvIV(fromstr);
5678 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5683 len = 1; /* assume SV is correct length */
5688 if (fromstr == &PL_sv_undef)
5692 /* XXX better yet, could spirit away the string to
5693 * a safe spot and hang on to it until the result
5694 * of pack() (and all copies of the result) are
5697 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5698 || (SvPADTMP(fromstr)
5699 && !SvREADONLY(fromstr))))
5701 Perl_warner(aTHX_ WARN_PACK,
5702 "Attempt to pack pointer to temporary value");
5704 if (SvPOK(fromstr) || SvNIOK(fromstr))
5705 aptr = SvPV(fromstr,n_a);
5707 aptr = SvPV_force(fromstr,n_a);
5709 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5714 aptr = SvPV(fromstr, fromlen);
5715 SvGROW(cat, fromlen * 4 / 3);
5720 while (fromlen > 0) {
5727 doencodes(cat, aptr, todo);
5746 register IV limit = POPi; /* note, negative is forever */
5748 bool doutf8 = DO_UTF8(sv);
5750 register char *s = SvPV(sv, len);
5751 char *strend = s + len;
5753 register REGEXP *rx;
5757 I32 maxiters = (strend - s) + 10;
5760 I32 origlimit = limit;
5763 AV *oldstack = PL_curstack;
5764 I32 gimme = GIMME_V;
5765 I32 oldsave = PL_savestack_ix;
5766 I32 make_mortal = 1;
5767 MAGIC *mg = (MAGIC *) NULL;
5770 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5775 DIE(aTHX_ "panic: pp_split");
5776 rx = pm->op_pmregexp;
5778 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5779 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5781 if (pm->op_pmreplroot) {
5783 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5785 ary = GvAVn((GV*)pm->op_pmreplroot);
5788 else if (gimme != G_ARRAY)
5790 ary = (AV*)PL_curpad[0];
5792 ary = GvAVn(PL_defgv);
5793 #endif /* USE_THREADS */
5796 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5802 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5804 XPUSHs(SvTIED_obj((SV*)ary, mg));
5810 for (i = AvFILLp(ary); i >= 0; i--)
5811 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5813 /* temporarily switch stacks */
5814 SWITCHSTACK(PL_curstack, ary);
5818 base = SP - PL_stack_base;
5820 if (pm->op_pmflags & PMf_SKIPWHITE) {
5821 if (pm->op_pmflags & PMf_LOCALE) {
5822 while (isSPACE_LC(*s))
5830 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5831 SAVEINT(PL_multiline);
5832 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5836 limit = maxiters + 2;
5837 if (pm->op_pmflags & PMf_WHITE) {
5840 while (m < strend &&
5841 !((pm->op_pmflags & PMf_LOCALE)
5842 ? isSPACE_LC(*m) : isSPACE(*m)))
5847 dstr = NEWSV(30, m-s);
5848 sv_setpvn(dstr, s, m-s);
5852 (void)SvUTF8_on(dstr);
5856 while (s < strend &&
5857 ((pm->op_pmflags & PMf_LOCALE)
5858 ? isSPACE_LC(*s) : isSPACE(*s)))
5862 else if (strEQ("^", rx->precomp)) {
5865 for (m = s; m < strend && *m != '\n'; m++) ;
5869 dstr = NEWSV(30, m-s);
5870 sv_setpvn(dstr, s, m-s);
5874 (void)SvUTF8_on(dstr);
5879 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5880 && (rx->reganch & ROPT_CHECK_ALL)
5881 && !(rx->reganch & ROPT_ANCH)) {
5882 int tail = (rx->reganch & RE_INTUIT_TAIL);
5883 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5886 if (len == 1 && !tail) {
5888 char c = *SvPV(csv, n_a);
5891 for (m = s; m < strend && *m != c; m++) ;
5894 dstr = NEWSV(30, m-s);
5895 sv_setpvn(dstr, s, m-s);
5899 (void)SvUTF8_on(dstr);
5901 /* The rx->minlen is in characters but we want to step
5902 * s ahead by bytes. */
5903 s = m + (doutf8 ? SvCUR(csv) : len);
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. */
5922 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5927 maxiters += (strend - s) * rx->nparens;
5928 while (s < strend && --limit
5929 /* && (!rx->check_substr
5930 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5932 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5933 1 /* minend */, sv, NULL, 0))
5935 TAINT_IF(RX_MATCH_TAINTED(rx));
5936 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5941 strend = s + (strend - m);
5943 m = rx->startp[0] + orig;
5944 dstr = NEWSV(32, m-s);
5945 sv_setpvn(dstr, s, m-s);
5949 (void)SvUTF8_on(dstr);
5952 for (i = 1; i <= rx->nparens; i++) {
5953 s = rx->startp[i] + orig;
5954 m = rx->endp[i] + orig;
5956 dstr = NEWSV(33, m-s);
5957 sv_setpvn(dstr, s, m-s);
5960 dstr = NEWSV(33, 0);
5964 (void)SvUTF8_on(dstr);
5968 s = rx->endp[0] + orig;
5972 LEAVE_SCOPE(oldsave);
5973 iters = (SP - PL_stack_base) - base;
5974 if (iters > maxiters)
5975 DIE(aTHX_ "Split loop");
5977 /* keep field after final delim? */
5978 if (s < strend || (iters && origlimit)) {
5979 STRLEN l = strend - s;
5980 dstr = NEWSV(34, l);
5981 sv_setpvn(dstr, s, l);
5985 (void)SvUTF8_on(dstr);
5989 else if (!origlimit) {
5990 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5996 SWITCHSTACK(ary, oldstack);
5997 if (SvSMAGICAL(ary)) {
6002 if (gimme == G_ARRAY) {
6004 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6012 call_method("PUSH",G_SCALAR|G_DISCARD);
6015 if (gimme == G_ARRAY) {
6016 /* EXTEND should not be needed - we just popped them */
6018 for (i=0; i < iters; i++) {
6019 SV **svp = av_fetch(ary, i, FALSE);
6020 PUSHs((svp) ? *svp : &PL_sv_undef);
6027 if (gimme == G_ARRAY)
6030 if (iters || !pm->op_pmreplroot) {
6040 Perl_unlock_condpair(pTHX_ void *svv)
6042 MAGIC *mg = mg_find((SV*)svv, 'm');
6045 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6046 MUTEX_LOCK(MgMUTEXP(mg));
6047 if (MgOWNER(mg) != thr)
6048 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6050 COND_SIGNAL(MgOWNERCONDP(mg));
6051 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6052 PTR2UV(thr), PTR2UV(svv));)
6053 MUTEX_UNLOCK(MgMUTEXP(mg));
6055 #endif /* USE_THREADS */
6064 #endif /* USE_THREADS */
6065 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6066 || SvTYPE(retsv) == SVt_PVCV) {
6067 retsv = refto(retsv);
6078 if (PL_op->op_private & OPpLVAL_INTRO)
6079 PUSHs(*save_threadsv(PL_op->op_targ));
6081 PUSHs(THREADSV(PL_op->op_targ));
6084 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6085 #endif /* USE_THREADS */