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) && !CvLVALUE(cv))
389 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
392 cv = (CV*)&PL_sv_undef;
406 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
407 char *s = SvPVX(TOPs);
408 if (strnEQ(s, "CORE::", 6)) {
411 code = keyword(s + 6, SvCUR(TOPs) - 6);
412 if (code < 0) { /* Overridable. */
413 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
414 int i = 0, n = 0, seen_question = 0;
416 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
418 while (i < MAXO) { /* The slow way. */
419 if (strEQ(s + 6, PL_op_name[i])
420 || strEQ(s + 6, PL_op_desc[i]))
426 goto nonesuch; /* Should not happen... */
428 oa = PL_opargs[i] >> OASHIFT;
430 if (oa & OA_OPTIONAL && !seen_question) {
434 else if (n && str[0] == ';' && seen_question)
435 goto set; /* XXXX system, exec */
436 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
437 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
440 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
441 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
445 ret = sv_2mortal(newSVpvn(str, n - 1));
447 else if (code) /* Non-Overridable */
449 else { /* None such */
451 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
455 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
457 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
466 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
468 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
484 if (GIMME != G_ARRAY) {
488 *MARK = &PL_sv_undef;
489 *MARK = refto(*MARK);
493 EXTEND_MORTAL(SP - MARK);
495 *MARK = refto(*MARK);
500 S_refto(pTHX_ SV *sv)
504 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
507 if (!(sv = LvTARG(sv)))
510 (void)SvREFCNT_inc(sv);
512 else if (SvTYPE(sv) == SVt_PVAV) {
513 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
516 (void)SvREFCNT_inc(sv);
518 else if (SvPADTMP(sv))
522 (void)SvREFCNT_inc(sv);
525 sv_upgrade(rv, SVt_RV);
539 if (sv && SvGMAGICAL(sv))
542 if (!sv || !SvROK(sv))
546 pv = sv_reftype(sv,TRUE);
547 PUSHp(pv, strlen(pv));
557 stash = CopSTASH(PL_curcop);
563 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
564 Perl_croak(aTHX_ "Attempt to bless into a reference");
566 if (ckWARN(WARN_MISC) && len == 0)
567 Perl_warner(aTHX_ WARN_MISC,
568 "Explicit blessing to '' (assuming package main)");
569 stash = gv_stashpvn(ptr, len, TRUE);
572 (void)sv_bless(TOPs, stash);
586 elem = SvPV(sv, n_a);
590 switch (elem ? *elem : '\0')
593 if (strEQ(elem, "ARRAY"))
594 tmpRef = (SV*)GvAV(gv);
597 if (strEQ(elem, "CODE"))
598 tmpRef = (SV*)GvCVu(gv);
601 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
602 tmpRef = (SV*)GvIOp(gv);
604 if (strEQ(elem, "FORMAT"))
605 tmpRef = (SV*)GvFORM(gv);
608 if (strEQ(elem, "GLOB"))
612 if (strEQ(elem, "HASH"))
613 tmpRef = (SV*)GvHV(gv);
616 if (strEQ(elem, "IO"))
617 tmpRef = (SV*)GvIOp(gv);
620 if (strEQ(elem, "NAME"))
621 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
624 if (strEQ(elem, "PACKAGE"))
625 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
628 if (strEQ(elem, "SCALAR"))
642 /* Pattern matching */
647 register unsigned char *s;
650 register I32 *sfirst;
654 if (sv == PL_lastscream) {
660 SvSCREAM_off(PL_lastscream);
661 SvREFCNT_dec(PL_lastscream);
663 PL_lastscream = SvREFCNT_inc(sv);
666 s = (unsigned char*)(SvPV(sv, len));
670 if (pos > PL_maxscream) {
671 if (PL_maxscream < 0) {
672 PL_maxscream = pos + 80;
673 New(301, PL_screamfirst, 256, I32);
674 New(302, PL_screamnext, PL_maxscream, I32);
677 PL_maxscream = pos + pos / 4;
678 Renew(PL_screamnext, PL_maxscream, I32);
682 sfirst = PL_screamfirst;
683 snext = PL_screamnext;
685 if (!sfirst || !snext)
686 DIE(aTHX_ "do_study: out of memory");
688 for (ch = 256; ch; --ch)
695 snext[pos] = sfirst[ch] - pos;
702 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
711 if (PL_op->op_flags & OPf_STACKED)
717 TARG = sv_newmortal();
722 /* Lvalue operators. */
734 djSP; dMARK; dTARGET;
744 SETi(do_chomp(TOPs));
750 djSP; dMARK; dTARGET;
751 register I32 count = 0;
754 count += do_chomp(POPs);
765 if (!sv || !SvANY(sv))
767 switch (SvTYPE(sv)) {
769 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
773 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
777 if (CvROOT(sv) || CvXSUB(sv))
794 if (!PL_op->op_private) {
803 if (SvTHINKFIRST(sv))
806 switch (SvTYPE(sv)) {
816 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
817 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
818 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
822 /* let user-undef'd sub keep its identity */
823 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
830 SvSetMagicSV(sv, &PL_sv_undef);
834 Newz(602, gp, 1, GP);
835 GvGP(sv) = gp_ref(gp);
836 GvSV(sv) = NEWSV(72,0);
837 GvLINE(sv) = CopLINE(PL_curcop);
843 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
846 SvPV_set(sv, Nullch);
859 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
860 DIE(aTHX_ PL_no_modify);
861 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
862 SvIVX(TOPs) != IV_MIN)
865 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
876 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
877 DIE(aTHX_ PL_no_modify);
878 sv_setsv(TARG, TOPs);
879 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
880 SvIVX(TOPs) != IV_MAX)
883 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
897 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
898 DIE(aTHX_ PL_no_modify);
899 sv_setsv(TARG, TOPs);
900 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
901 SvIVX(TOPs) != IV_MIN)
904 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
913 /* Ordinary operators. */
917 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
920 SETn( Perl_pow( left, right) );
927 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
928 #ifdef PERL_PRESERVE_IVUV
931 /* Unless the left argument is integer in range we are going to have to
932 use NV maths. Hence only attempt to coerce the right argument if
933 we know the left is integer. */
934 /* Left operand is defined, so is it IV? */
937 bool auvok = SvUOK(TOPm1s);
938 bool buvok = SvUOK(TOPs);
939 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
940 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
947 alow = SvUVX(TOPm1s);
949 IV aiv = SvIVX(TOPm1s);
952 auvok = TRUE; /* effectively it's a UV now */
954 alow = -aiv; /* abs, auvok == false records sign */
960 IV biv = SvIVX(TOPs);
963 buvok = TRUE; /* effectively it's a UV now */
965 blow = -biv; /* abs, buvok == false records sign */
969 /* If this does sign extension on unsigned it's time for plan B */
970 ahigh = alow >> (4 * sizeof (UV));
972 bhigh = blow >> (4 * sizeof (UV));
974 if (ahigh && bhigh) {
975 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
976 which is overflow. Drop to NVs below. */
977 } else if (!ahigh && !bhigh) {
978 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
979 so the unsigned multiply cannot overflow. */
980 UV product = alow * blow;
981 if (auvok == buvok) {
982 /* -ve * -ve or +ve * +ve gives a +ve result. */
986 } else if (product <= (UV)IV_MIN) {
987 /* 2s complement assumption that (UV)-IV_MIN is correct. */
988 /* -ve result, which could overflow an IV */
992 } /* else drop to NVs below. */
994 /* One operand is large, 1 small */
997 /* swap the operands */
999 bhigh = blow; /* bhigh now the temp var for the swap */
1003 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1004 multiplies can't overflow. shift can, add can, -ve can. */
1005 product_middle = ahigh * blow;
1006 if (!(product_middle & topmask)) {
1007 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1009 product_middle <<= (4 * sizeof (UV));
1010 product_low = alow * blow;
1012 /* as for pp_add, UV + something mustn't get smaller.
1013 IIRC ANSI mandates this wrapping *behaviour* for
1014 unsigned whatever the actual representation*/
1015 product_low += product_middle;
1016 if (product_low >= product_middle) {
1017 /* didn't overflow */
1018 if (auvok == buvok) {
1019 /* -ve * -ve or +ve * +ve gives a +ve result. */
1021 SETu( product_low );
1023 } else if (product_low <= (UV)IV_MIN) {
1024 /* 2s complement assumption again */
1025 /* -ve result, which could overflow an IV */
1027 SETi( -product_low );
1029 } /* else drop to NVs below. */
1031 } /* product_middle too large */
1032 } /* ahigh && bhigh */
1033 } /* SvIOK(TOPm1s) */
1038 SETn( left * right );
1045 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1050 DIE(aTHX_ "Illegal division by zero");
1052 /* insure that 20./5. == 4. */
1055 if ((NV)I_V(left) == left &&
1056 (NV)I_V(right) == right &&
1057 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1061 value = left / right;
1065 value = left / right;
1074 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1080 bool use_double = 0;
1084 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1086 right = (right_neg = (i < 0)) ? -i : i;
1091 right_neg = dright < 0;
1096 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1098 left = (left_neg = (i < 0)) ? -i : i;
1106 left_neg = dleft < 0;
1115 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1117 # define CAST_D2UV(d) U_V(d)
1119 # define CAST_D2UV(d) ((UV)(d))
1121 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1122 * or, in other words, precision of UV more than of NV.
1123 * But in fact the approach below turned out to be an
1124 * optimization - floor() may be slow */
1125 if (dright <= UV_MAX && dleft <= UV_MAX) {
1126 right = CAST_D2UV(dright);
1127 left = CAST_D2UV(dleft);
1132 /* Backward-compatibility clause: */
1133 dright = Perl_floor(dright + 0.5);
1134 dleft = Perl_floor(dleft + 0.5);
1137 DIE(aTHX_ "Illegal modulus zero");
1139 dans = Perl_fmod(dleft, dright);
1140 if ((left_neg != right_neg) && dans)
1141 dans = dright - dans;
1144 sv_setnv(TARG, dans);
1151 DIE(aTHX_ "Illegal modulus zero");
1154 if ((left_neg != right_neg) && ans)
1157 /* XXX may warn: unary minus operator applied to unsigned type */
1158 /* could change -foo to be (~foo)+1 instead */
1159 if (ans <= ~((UV)IV_MAX)+1)
1160 sv_setiv(TARG, ~ans+1);
1162 sv_setnv(TARG, -(NV)ans);
1165 sv_setuv(TARG, ans);
1174 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1176 register IV count = POPi;
1177 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1179 I32 items = SP - MARK;
1182 max = items * count;
1191 repeatcpy((char*)(MARK + items), (char*)MARK,
1192 items * sizeof(SV*), count - 1);
1195 else if (count <= 0)
1198 else { /* Note: mark already snarfed by pp_list */
1201 bool isutf = DO_UTF8(tmpstr);
1203 SvSetSV(TARG, tmpstr);
1204 SvPV_force(TARG, len);
1209 SvGROW(TARG, (count * len) + 1);
1210 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1211 SvCUR(TARG) *= count;
1213 *SvEND(TARG) = '\0';
1216 (void)SvPOK_only_UTF8(TARG);
1218 (void)SvPOK_only(TARG);
1227 djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1228 useleft = USE_LEFT(TOPm1s);
1229 #ifdef PERL_PRESERVE_IVUV
1230 /* We must see if we can perform the addition with integers if possible,
1231 as the integer code detects overflow while the NV code doesn't.
1232 If either argument hasn't had a numeric conversion yet attempt to get
1233 the IV. It's important to do this now, rather than just assuming that
1234 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1235 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1236 integer in case the second argument is IV=9223372036854775806
1237 We can (now) rely on sv_2iv to do the right thing, only setting the
1238 public IOK flag if the value in the NV (or PV) slot is truly integer.
1240 A side effect is that this also aggressively prefers integer maths over
1241 fp maths for integer values. */
1244 /* Unless the left argument is integer in range we are going to have to
1245 use NV maths. Hence only attempt to coerce the right argument if
1246 we know the left is integer. */
1248 /* left operand is undef, treat as zero. + 0 is identity. */
1250 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
1251 if (value <= (UV)IV_MIN) {
1252 /* 2s complement assumption. */
1255 } /* else drop through into NVs below */
1262 /* Left operand is defined, so is it IV? */
1263 SvIV_please(TOPm1s);
1264 if (SvIOK(TOPm1s)) {
1265 bool auvok = SvUOK(TOPm1s);
1266 bool buvok = SvUOK(TOPs);
1268 if (!auvok && !buvok) { /* ## IV - IV ## */
1269 IV aiv = SvIVX(TOPm1s);
1270 IV biv = SvIVX(TOPs);
1271 IV result = aiv - biv;
1273 if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
1278 /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
1279 /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
1280 /* -ve - +ve can only overflow too negative. */
1281 /* leaving +ve - -ve, which will go UV */
1282 if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
1283 /* 2s complement assumption for IV_MIN */
1284 UV result = (UV)aiv + (UV)-biv;
1285 /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
1286 overflow UV (2s complement assumption */
1287 assert (result >= (UV) aiv);
1292 /* Overflow, drop through to NVs */
1293 } else if (auvok && buvok) { /* ## UV - UV ## */
1294 UV auv = SvUVX(TOPm1s);
1295 UV buv = SvUVX(TOPs);
1303 /* Blatant 2s complement assumption. */
1304 result = (IV)(auv - buv);
1310 /* Overflow on IV - IV, drop through to NVs */
1311 } else if (auvok) { /* ## Mixed UV - IV ## */
1312 UV auv = SvUVX(TOPm1s);
1313 IV biv = SvIVX(TOPs);
1316 /* 2s complement assumptions for IV_MIN */
1317 UV result = auv + ((UV)-biv);
1318 /* UV + UV can only get bigger... */
1319 if (result >= auv) {
1324 /* and if it gets too big for UV then it's NV time. */
1325 } else if (auv > (UV)IV_MAX) {
1326 /* I think I'm making an implicit 2s complement
1327 assumption that IV_MIN == -IV_MAX - 1 */
1329 UV result = auv - (UV)biv;
1330 assert (result <= auv);
1336 IV result = (IV)auv - biv;
1337 assert (result <= (IV)auv);
1342 } else { /* ## Mixed IV - UV ## */
1343 IV aiv = SvIVX(TOPm1s);
1344 UV buv = SvUVX(TOPs);
1345 IV result = aiv - (IV)buv; /* 2s complement assumption. */
1347 /* result must not get larger. */
1348 if (result <= aiv) {
1352 } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
1361 /* left operand is undef, treat as zero - value */
1365 SETn( TOPn - value );
1372 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1375 if (PL_op->op_private & HINT_INTEGER) {
1389 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1392 if (PL_op->op_private & HINT_INTEGER) {
1406 djSP; tryAMAGICbinSET(lt,0);
1407 #ifdef PERL_PRESERVE_IVUV
1410 SvIV_please(TOPm1s);
1411 if (SvIOK(TOPm1s)) {
1412 bool auvok = SvUOK(TOPm1s);
1413 bool buvok = SvUOK(TOPs);
1415 if (!auvok && !buvok) { /* ## IV < IV ## */
1416 IV aiv = SvIVX(TOPm1s);
1417 IV biv = SvIVX(TOPs);
1420 SETs(boolSV(aiv < biv));
1423 if (auvok && buvok) { /* ## UV < UV ## */
1424 UV auv = SvUVX(TOPm1s);
1425 UV buv = SvUVX(TOPs);
1428 SETs(boolSV(auv < buv));
1431 if (auvok) { /* ## UV < IV ## */
1438 /* As (a) is a UV, it's >=0, so it cannot be < */
1443 if (auv >= (UV) IV_MAX) {
1444 /* As (b) is an IV, it cannot be > IV_MAX */
1448 SETs(boolSV(auv < (UV)biv));
1451 { /* ## IV < UV ## */
1455 aiv = SvIVX(TOPm1s);
1457 /* As (b) is a UV, it's >=0, so it must be < */
1464 if (buv > (UV) IV_MAX) {
1465 /* As (a) is an IV, it cannot be > IV_MAX */
1469 SETs(boolSV((UV)aiv < buv));
1477 SETs(boolSV(TOPn < value));
1484 djSP; tryAMAGICbinSET(gt,0);
1485 #ifdef PERL_PRESERVE_IVUV
1488 SvIV_please(TOPm1s);
1489 if (SvIOK(TOPm1s)) {
1490 bool auvok = SvUOK(TOPm1s);
1491 bool buvok = SvUOK(TOPs);
1493 if (!auvok && !buvok) { /* ## IV > IV ## */
1494 IV aiv = SvIVX(TOPm1s);
1495 IV biv = SvIVX(TOPs);
1498 SETs(boolSV(aiv > biv));
1501 if (auvok && buvok) { /* ## UV > UV ## */
1502 UV auv = SvUVX(TOPm1s);
1503 UV buv = SvUVX(TOPs);
1506 SETs(boolSV(auv > buv));
1509 if (auvok) { /* ## UV > IV ## */
1516 /* As (a) is a UV, it's >=0, so it must be > */
1521 if (auv > (UV) IV_MAX) {
1522 /* As (b) is an IV, it cannot be > IV_MAX */
1526 SETs(boolSV(auv > (UV)biv));
1529 { /* ## IV > UV ## */
1533 aiv = SvIVX(TOPm1s);
1535 /* As (b) is a UV, it's >=0, so it cannot be > */
1542 if (buv >= (UV) IV_MAX) {
1543 /* As (a) is an IV, it cannot be > IV_MAX */
1547 SETs(boolSV((UV)aiv > buv));
1555 SETs(boolSV(TOPn > value));
1562 djSP; tryAMAGICbinSET(le,0);
1563 #ifdef PERL_PRESERVE_IVUV
1566 SvIV_please(TOPm1s);
1567 if (SvIOK(TOPm1s)) {
1568 bool auvok = SvUOK(TOPm1s);
1569 bool buvok = SvUOK(TOPs);
1571 if (!auvok && !buvok) { /* ## IV <= IV ## */
1572 IV aiv = SvIVX(TOPm1s);
1573 IV biv = SvIVX(TOPs);
1576 SETs(boolSV(aiv <= biv));
1579 if (auvok && buvok) { /* ## UV <= UV ## */
1580 UV auv = SvUVX(TOPm1s);
1581 UV buv = SvUVX(TOPs);
1584 SETs(boolSV(auv <= buv));
1587 if (auvok) { /* ## UV <= IV ## */
1594 /* As (a) is a UV, it's >=0, so a cannot be <= */
1599 if (auv > (UV) IV_MAX) {
1600 /* As (b) is an IV, it cannot be > IV_MAX */
1604 SETs(boolSV(auv <= (UV)biv));
1607 { /* ## IV <= UV ## */
1611 aiv = SvIVX(TOPm1s);
1613 /* As (b) is a UV, it's >=0, so a must be <= */
1620 if (buv >= (UV) IV_MAX) {
1621 /* As (a) is an IV, it cannot be > IV_MAX */
1625 SETs(boolSV((UV)aiv <= buv));
1633 SETs(boolSV(TOPn <= value));
1640 djSP; tryAMAGICbinSET(ge,0);
1641 #ifdef PERL_PRESERVE_IVUV
1644 SvIV_please(TOPm1s);
1645 if (SvIOK(TOPm1s)) {
1646 bool auvok = SvUOK(TOPm1s);
1647 bool buvok = SvUOK(TOPs);
1649 if (!auvok && !buvok) { /* ## IV >= IV ## */
1650 IV aiv = SvIVX(TOPm1s);
1651 IV biv = SvIVX(TOPs);
1654 SETs(boolSV(aiv >= biv));
1657 if (auvok && buvok) { /* ## UV >= UV ## */
1658 UV auv = SvUVX(TOPm1s);
1659 UV buv = SvUVX(TOPs);
1662 SETs(boolSV(auv >= buv));
1665 if (auvok) { /* ## UV >= IV ## */
1672 /* As (a) is a UV, it's >=0, so it must be >= */
1677 if (auv >= (UV) IV_MAX) {
1678 /* As (b) is an IV, it cannot be > IV_MAX */
1682 SETs(boolSV(auv >= (UV)biv));
1685 { /* ## IV >= UV ## */
1689 aiv = SvIVX(TOPm1s);
1691 /* As (b) is a UV, it's >=0, so a cannot be >= */
1698 if (buv > (UV) IV_MAX) {
1699 /* As (a) is an IV, it cannot be > IV_MAX */
1703 SETs(boolSV((UV)aiv >= buv));
1711 SETs(boolSV(TOPn >= value));
1718 djSP; tryAMAGICbinSET(ne,0);
1719 #ifdef PERL_PRESERVE_IVUV
1722 SvIV_please(TOPm1s);
1723 if (SvIOK(TOPm1s)) {
1724 bool auvok = SvUOK(TOPm1s);
1725 bool buvok = SvUOK(TOPs);
1727 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1728 IV aiv = SvIVX(TOPm1s);
1729 IV biv = SvIVX(TOPs);
1732 SETs(boolSV(aiv != biv));
1735 if (auvok && buvok) { /* ## UV != UV ## */
1736 UV auv = SvUVX(TOPm1s);
1737 UV buv = SvUVX(TOPs);
1740 SETs(boolSV(auv != buv));
1743 { /* ## Mixed IV,UV ## */
1747 /* != is commutative so swap if needed (save code) */
1749 /* swap. top of stack (b) is the iv */
1753 /* As (a) is a UV, it's >0, so it cannot be == */
1762 /* As (b) is a UV, it's >0, so it cannot be == */
1766 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1768 /* we know iv is >= 0 */
1769 if (uv > (UV) IV_MAX) {
1773 SETs(boolSV((UV)iv != uv));
1781 SETs(boolSV(TOPn != value));
1788 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1789 #ifdef PERL_PRESERVE_IVUV
1790 /* Fortunately it seems NaN isn't IOK */
1793 SvIV_please(TOPm1s);
1794 if (SvIOK(TOPm1s)) {
1795 bool leftuvok = SvUOK(TOPm1s);
1796 bool rightuvok = SvUOK(TOPs);
1798 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1799 IV leftiv = SvIVX(TOPm1s);
1800 IV rightiv = SvIVX(TOPs);
1802 if (leftiv > rightiv)
1804 else if (leftiv < rightiv)
1808 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1809 UV leftuv = SvUVX(TOPm1s);
1810 UV rightuv = SvUVX(TOPs);
1812 if (leftuv > rightuv)
1814 else if (leftuv < rightuv)
1818 } else if (leftuvok) { /* ## UV <=> IV ## */
1822 rightiv = SvIVX(TOPs);
1824 /* As (a) is a UV, it's >=0, so it cannot be < */
1827 leftuv = SvUVX(TOPm1s);
1828 if (leftuv > (UV) IV_MAX) {
1829 /* As (b) is an IV, it cannot be > IV_MAX */
1831 } else if (leftuv > (UV)rightiv) {
1833 } else if (leftuv < (UV)rightiv) {
1839 } else { /* ## IV <=> UV ## */
1843 leftiv = SvIVX(TOPm1s);
1845 /* As (b) is a UV, it's >=0, so it must be < */
1848 rightuv = SvUVX(TOPs);
1849 if (rightuv > (UV) IV_MAX) {
1850 /* As (a) is an IV, it cannot be > IV_MAX */
1852 } else if (leftiv > (UV)rightuv) {
1854 } else if (leftiv < (UV)rightuv) {
1872 if (Perl_isnan(left) || Perl_isnan(right)) {
1876 value = (left > right) - (left < right);
1880 else if (left < right)
1882 else if (left > right)
1896 djSP; tryAMAGICbinSET(slt,0);
1899 int cmp = ((PL_op->op_private & OPpLOCALE)
1900 ? sv_cmp_locale(left, right)
1901 : sv_cmp(left, right));
1902 SETs(boolSV(cmp < 0));
1909 djSP; tryAMAGICbinSET(sgt,0);
1912 int cmp = ((PL_op->op_private & OPpLOCALE)
1913 ? sv_cmp_locale(left, right)
1914 : sv_cmp(left, right));
1915 SETs(boolSV(cmp > 0));
1922 djSP; tryAMAGICbinSET(sle,0);
1925 int cmp = ((PL_op->op_private & OPpLOCALE)
1926 ? sv_cmp_locale(left, right)
1927 : sv_cmp(left, right));
1928 SETs(boolSV(cmp <= 0));
1935 djSP; tryAMAGICbinSET(sge,0);
1938 int cmp = ((PL_op->op_private & OPpLOCALE)
1939 ? sv_cmp_locale(left, right)
1940 : sv_cmp(left, right));
1941 SETs(boolSV(cmp >= 0));
1948 djSP; tryAMAGICbinSET(seq,0);
1951 SETs(boolSV(sv_eq(left, right)));
1958 djSP; tryAMAGICbinSET(sne,0);
1961 SETs(boolSV(!sv_eq(left, right)));
1968 djSP; dTARGET; tryAMAGICbin(scmp,0);
1971 int cmp = ((PL_op->op_private & OPpLOCALE)
1972 ? sv_cmp_locale(left, right)
1973 : sv_cmp(left, right));
1981 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1984 if (SvNIOKp(left) || SvNIOKp(right)) {
1985 if (PL_op->op_private & HINT_INTEGER) {
1986 IV i = SvIV(left) & SvIV(right);
1990 UV u = SvUV(left) & SvUV(right);
1995 do_vop(PL_op->op_type, TARG, left, right);
2004 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2007 if (SvNIOKp(left) || SvNIOKp(right)) {
2008 if (PL_op->op_private & HINT_INTEGER) {
2009 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2013 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2018 do_vop(PL_op->op_type, TARG, left, right);
2027 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2030 if (SvNIOKp(left) || SvNIOKp(right)) {
2031 if (PL_op->op_private & HINT_INTEGER) {
2032 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2036 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2041 do_vop(PL_op->op_type, TARG, left, right);
2050 djSP; dTARGET; tryAMAGICun(neg);
2053 int flags = SvFLAGS(sv);
2056 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2057 /* It's publicly an integer, or privately an integer-not-float */
2060 if (SvIVX(sv) == IV_MIN) {
2061 /* 2s complement assumption. */
2062 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2065 else if (SvUVX(sv) <= IV_MAX) {
2070 else if (SvIVX(sv) != IV_MIN) {
2074 #ifdef PERL_PRESERVE_IVUV
2083 else if (SvPOKp(sv)) {
2085 char *s = SvPV(sv, len);
2086 if (isIDFIRST(*s)) {
2087 sv_setpvn(TARG, "-", 1);
2090 else if (*s == '+' || *s == '-') {
2092 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2094 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
2095 sv_setpvn(TARG, "-", 1);
2101 goto oops_its_an_int;
2102 sv_setnv(TARG, -SvNV(sv));
2114 djSP; tryAMAGICunSET(not);
2115 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2121 djSP; dTARGET; tryAMAGICun(compl);
2125 if (PL_op->op_private & HINT_INTEGER) {
2140 tmps = (U8*)SvPV_force(TARG, len);
2143 /* Calculate exact length, let's not estimate. */
2152 while (tmps < send) {
2153 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2154 tmps += UTF8SKIP(tmps);
2155 targlen += UNISKIP(~c);
2161 /* Now rewind strings and write them. */
2165 Newz(0, result, targlen + 1, U8);
2166 while (tmps < send) {
2167 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2168 tmps += UTF8SKIP(tmps);
2169 result = uv_to_utf8(result, ~c);
2173 sv_setpvn(TARG, (char*)result, targlen);
2177 Newz(0, result, nchar + 1, U8);
2178 while (tmps < send) {
2179 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
2180 tmps += UTF8SKIP(tmps);
2185 sv_setpvn(TARG, (char*)result, nchar);
2193 register long *tmpl;
2194 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2197 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2202 for ( ; anum > 0; anum--, tmps++)
2211 /* integer versions of some of the above */
2215 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2218 SETi( left * right );
2225 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2229 DIE(aTHX_ "Illegal division by zero");
2230 value = POPi / value;
2238 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2242 DIE(aTHX_ "Illegal modulus zero");
2243 SETi( left % right );
2250 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2253 SETi( left + right );
2260 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2263 SETi( left - right );
2270 djSP; tryAMAGICbinSET(lt,0);
2273 SETs(boolSV(left < right));
2280 djSP; tryAMAGICbinSET(gt,0);
2283 SETs(boolSV(left > right));
2290 djSP; tryAMAGICbinSET(le,0);
2293 SETs(boolSV(left <= right));
2300 djSP; tryAMAGICbinSET(ge,0);
2303 SETs(boolSV(left >= right));
2310 djSP; tryAMAGICbinSET(eq,0);
2313 SETs(boolSV(left == right));
2320 djSP; tryAMAGICbinSET(ne,0);
2323 SETs(boolSV(left != right));
2330 djSP; dTARGET; tryAMAGICbin(ncmp,0);
2337 else if (left < right)
2348 djSP; dTARGET; tryAMAGICun(neg);
2353 /* High falutin' math. */
2357 djSP; dTARGET; tryAMAGICbin(atan2,0);
2360 SETn(Perl_atan2(left, right));
2367 djSP; dTARGET; tryAMAGICun(sin);
2371 value = Perl_sin(value);
2379 djSP; dTARGET; tryAMAGICun(cos);
2383 value = Perl_cos(value);
2389 /* Support Configure command-line overrides for rand() functions.
2390 After 5.005, perhaps we should replace this by Configure support
2391 for drand48(), random(), or rand(). For 5.005, though, maintain
2392 compatibility by calling rand() but allow the user to override it.
2393 See INSTALL for details. --Andy Dougherty 15 July 1998
2395 /* Now it's after 5.005, and Configure supports drand48() and random(),
2396 in addition to rand(). So the overrides should not be needed any more.
2397 --Jarkko Hietaniemi 27 September 1998
2400 #ifndef HAS_DRAND48_PROTO
2401 extern double drand48 (void);
2414 if (!PL_srand_called) {
2415 (void)seedDrand01((Rand_seed_t)seed());
2416 PL_srand_called = TRUE;
2431 (void)seedDrand01((Rand_seed_t)anum);
2432 PL_srand_called = TRUE;
2441 * This is really just a quick hack which grabs various garbage
2442 * values. It really should be a real hash algorithm which
2443 * spreads the effect of every input bit onto every output bit,
2444 * if someone who knows about such things would bother to write it.
2445 * Might be a good idea to add that function to CORE as well.
2446 * No numbers below come from careful analysis or anything here,
2447 * except they are primes and SEED_C1 > 1E6 to get a full-width
2448 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2449 * probably be bigger too.
2452 # define SEED_C1 1000003
2453 #define SEED_C4 73819
2455 # define SEED_C1 25747
2456 #define SEED_C4 20639
2460 #define SEED_C5 26107
2462 #ifndef PERL_NO_DEV_RANDOM
2467 # include <starlet.h>
2468 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2469 * in 100-ns units, typically incremented ever 10 ms. */
2470 unsigned int when[2];
2472 # ifdef HAS_GETTIMEOFDAY
2473 struct timeval when;
2479 /* This test is an escape hatch, this symbol isn't set by Configure. */
2480 #ifndef PERL_NO_DEV_RANDOM
2481 #ifndef PERL_RANDOM_DEVICE
2482 /* /dev/random isn't used by default because reads from it will block
2483 * if there isn't enough entropy available. You can compile with
2484 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2485 * is enough real entropy to fill the seed. */
2486 # define PERL_RANDOM_DEVICE "/dev/urandom"
2488 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2490 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2499 _ckvmssts(sys$gettim(when));
2500 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2502 # ifdef HAS_GETTIMEOFDAY
2503 gettimeofday(&when,(struct timezone *) 0);
2504 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2507 u = (U32)SEED_C1 * when;
2510 u += SEED_C3 * (U32)PerlProc_getpid();
2511 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2512 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2513 u += SEED_C5 * (U32)PTR2UV(&when);
2520 djSP; dTARGET; tryAMAGICun(exp);
2524 value = Perl_exp(value);
2532 djSP; dTARGET; tryAMAGICun(log);
2537 SET_NUMERIC_STANDARD();
2538 DIE(aTHX_ "Can't take log of %g", value);
2540 value = Perl_log(value);
2548 djSP; dTARGET; tryAMAGICun(sqrt);
2553 SET_NUMERIC_STANDARD();
2554 DIE(aTHX_ "Can't take sqrt of %g", value);
2556 value = Perl_sqrt(value);
2567 IV iv = TOPi; /* attempt to convert to IV if possible. */
2568 /* XXX it's arguable that compiler casting to IV might be subtly
2569 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2570 else preferring IV has introduced a subtle behaviour change bug. OTOH
2571 relying on floating point to be accurate is a bug. */
2582 if (value < (NV)UV_MAX + 0.5) {
2585 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2586 (void)Perl_modf(value, &value);
2588 double tmp = (double)value;
2589 (void)Perl_modf(tmp, &tmp);
2595 if (value > (NV)IV_MIN - 0.5) {
2598 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2599 (void)Perl_modf(-value, &value);
2602 double tmp = (double)value;
2603 (void)Perl_modf(-tmp, &tmp);
2616 djSP; dTARGET; tryAMAGICun(abs);
2618 /* This will cache the NV value if string isn't actually integer */
2622 /* IVX is precise */
2624 SETu(TOPu); /* force it to be numeric only */
2632 /* 2s complement assumption. Also, not really needed as
2633 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2656 argtype = 1; /* allow underscores */
2657 XPUSHn(scan_hex(tmps, 99, &argtype));
2670 while (*tmps && isSPACE(*tmps))
2674 argtype = 1; /* allow underscores */
2676 value = scan_hex(++tmps, 99, &argtype);
2677 else if (*tmps == 'b')
2678 value = scan_bin(++tmps, 99, &argtype);
2680 value = scan_oct(tmps, 99, &argtype);
2693 SETi(sv_len_utf8(sv));
2709 I32 lvalue = PL_op->op_flags & OPf_MOD;
2711 I32 arybase = PL_curcop->cop_arybase;
2715 SvTAINTED_off(TARG); /* decontaminate */
2716 SvUTF8_off(TARG); /* decontaminate */
2720 repl = SvPV(sv, repl_len);
2727 tmps = SvPV(sv, curlen);
2729 utfcurlen = sv_len_utf8(sv);
2730 if (utfcurlen == curlen)
2738 if (pos >= arybase) {
2756 else if (len >= 0) {
2758 if (rem > (I32)curlen)
2773 Perl_croak(aTHX_ "substr outside of string");
2774 if (ckWARN(WARN_SUBSTR))
2775 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2780 sv_pos_u2b(sv, &pos, &rem);
2782 sv_setpvn(TARG, tmps, rem);
2786 sv_insert(sv, pos, rem, repl, repl_len);
2787 else if (lvalue) { /* it's an lvalue! */
2788 if (!SvGMAGICAL(sv)) {
2792 if (ckWARN(WARN_SUBSTR))
2793 Perl_warner(aTHX_ WARN_SUBSTR,
2794 "Attempt to use reference as lvalue in substr");
2796 if (SvOK(sv)) /* is it defined ? */
2797 (void)SvPOK_only_UTF8(sv);
2799 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2802 if (SvTYPE(TARG) < SVt_PVLV) {
2803 sv_upgrade(TARG, SVt_PVLV);
2804 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2808 if (LvTARG(TARG) != sv) {
2810 SvREFCNT_dec(LvTARG(TARG));
2811 LvTARG(TARG) = SvREFCNT_inc(sv);
2813 LvTARGOFF(TARG) = pos;
2814 LvTARGLEN(TARG) = rem;
2818 PUSHs(TARG); /* avoid SvSETMAGIC here */
2825 register IV size = POPi;
2826 register IV offset = POPi;
2827 register SV *src = POPs;
2828 I32 lvalue = PL_op->op_flags & OPf_MOD;
2830 SvTAINTED_off(TARG); /* decontaminate */
2831 if (lvalue) { /* it's an lvalue! */
2832 if (SvTYPE(TARG) < SVt_PVLV) {
2833 sv_upgrade(TARG, SVt_PVLV);
2834 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2837 if (LvTARG(TARG) != src) {
2839 SvREFCNT_dec(LvTARG(TARG));
2840 LvTARG(TARG) = SvREFCNT_inc(src);
2842 LvTARGOFF(TARG) = offset;
2843 LvTARGLEN(TARG) = size;
2846 sv_setuv(TARG, do_vecget(src, offset, size));
2861 I32 arybase = PL_curcop->cop_arybase;
2866 offset = POPi - arybase;
2869 tmps = SvPV(big, biglen);
2870 if (offset > 0 && DO_UTF8(big))
2871 sv_pos_u2b(big, &offset, 0);
2874 else if (offset > biglen)
2876 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2877 (unsigned char*)tmps + biglen, little, 0)))
2880 retval = tmps2 - tmps;
2881 if (retval > 0 && DO_UTF8(big))
2882 sv_pos_b2u(big, &retval);
2883 PUSHi(retval + arybase);
2898 I32 arybase = PL_curcop->cop_arybase;
2904 tmps2 = SvPV(little, llen);
2905 tmps = SvPV(big, blen);
2909 if (offset > 0 && DO_UTF8(big))
2910 sv_pos_u2b(big, &offset, 0);
2911 offset = offset - arybase + llen;
2915 else if (offset > blen)
2917 if (!(tmps2 = rninstr(tmps, tmps + offset,
2918 tmps2, tmps2 + llen)))
2921 retval = tmps2 - tmps;
2922 if (retval > 0 && DO_UTF8(big))
2923 sv_pos_b2u(big, &retval);
2924 PUSHi(retval + arybase);
2930 djSP; dMARK; dORIGMARK; dTARGET;
2931 do_sprintf(TARG, SP-MARK, MARK+1);
2932 TAINT_IF(SvTAINTED(TARG));
2944 U8 *tmps = (U8*)SvPVx(tmpsv, len);
2947 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2948 value = utf8_to_uv(tmps, len, &retlen, 0);
2950 value = (UV)(*tmps & 255);
2961 (void)SvUPGRADE(TARG,SVt_PV);
2963 if ((value > 255 && !IN_BYTE) || (value & 0x80 && 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);
2980 (void)SvPOK_only(TARG);
2987 djSP; dTARGET; dPOPTOPssrl;
2990 char *tmps = SvPV(left, n_a);
2992 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2994 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2998 "The crypt() function is unimplemented due to excessive paranoia.");
3011 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
3013 U8 tmpbuf[UTF8_MAXLEN+1];
3015 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3017 if (PL_op->op_private & OPpLOCALE) {
3020 uv = toTITLE_LC_uni(uv);
3023 uv = toTITLE_utf8(s);
3025 tend = uv_to_utf8(tmpbuf, uv);
3027 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3029 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3030 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3035 s = (U8*)SvPV_force(sv, slen);
3036 Copy(tmpbuf, s, ulen, U8);
3040 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3042 SvUTF8_off(TARG); /* decontaminate */
3047 s = (U8*)SvPV_force(sv, slen);
3049 if (PL_op->op_private & OPpLOCALE) {
3052 *s = toUPPER_LC(*s);
3070 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
3072 U8 tmpbuf[UTF8_MAXLEN+1];
3074 UV uv = utf8_to_uv(s, slen, &ulen, 0);
3076 if (PL_op->op_private & OPpLOCALE) {
3079 uv = toLOWER_LC_uni(uv);
3082 uv = toLOWER_utf8(s);
3084 tend = uv_to_utf8(tmpbuf, uv);
3086 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3088 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3089 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3094 s = (U8*)SvPV_force(sv, slen);
3095 Copy(tmpbuf, s, ulen, U8);
3099 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3101 SvUTF8_off(TARG); /* decontaminate */
3106 s = (U8*)SvPV_force(sv, slen);
3108 if (PL_op->op_private & OPpLOCALE) {
3111 *s = toLOWER_LC(*s);
3135 s = (U8*)SvPV(sv,len);
3137 SvUTF8_off(TARG); /* decontaminate */
3138 sv_setpvn(TARG, "", 0);
3142 (void)SvUPGRADE(TARG, SVt_PV);
3143 SvGROW(TARG, (len * 2) + 1);
3144 (void)SvPOK_only(TARG);
3145 d = (U8*)SvPVX(TARG);
3147 if (PL_op->op_private & OPpLOCALE) {
3151 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3157 d = uv_to_utf8(d, toUPPER_utf8( s ));
3163 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3168 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3170 SvUTF8_off(TARG); /* decontaminate */
3175 s = (U8*)SvPV_force(sv, len);
3177 register U8 *send = s + len;
3179 if (PL_op->op_private & OPpLOCALE) {
3182 for (; s < send; s++)
3183 *s = toUPPER_LC(*s);
3186 for (; s < send; s++)
3209 s = (U8*)SvPV(sv,len);
3211 SvUTF8_off(TARG); /* decontaminate */
3212 sv_setpvn(TARG, "", 0);
3216 (void)SvUPGRADE(TARG, SVt_PV);
3217 SvGROW(TARG, (len * 2) + 1);
3218 (void)SvPOK_only(TARG);
3219 d = (U8*)SvPVX(TARG);
3221 if (PL_op->op_private & OPpLOCALE) {
3225 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
3231 d = uv_to_utf8(d, toLOWER_utf8(s));
3237 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3242 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3244 SvUTF8_off(TARG); /* decontaminate */
3250 s = (U8*)SvPV_force(sv, len);
3252 register U8 *send = s + len;
3254 if (PL_op->op_private & OPpLOCALE) {
3257 for (; s < send; s++)
3258 *s = toLOWER_LC(*s);
3261 for (; s < send; s++)
3276 register char *s = SvPV(sv,len);
3279 SvUTF8_off(TARG); /* decontaminate */
3281 (void)SvUPGRADE(TARG, SVt_PV);
3282 SvGROW(TARG, (len * 2) + 1);
3287 STRLEN ulen = UTF8SKIP(s);
3311 SvCUR_set(TARG, d - SvPVX(TARG));
3312 (void)SvPOK_only_UTF8(TARG);
3315 sv_setpvn(TARG, s, len);
3317 if (SvSMAGICAL(TARG))
3326 djSP; dMARK; dORIGMARK;
3328 register AV* av = (AV*)POPs;
3329 register I32 lval = PL_op->op_flags & OPf_MOD;
3330 I32 arybase = PL_curcop->cop_arybase;
3333 if (SvTYPE(av) == SVt_PVAV) {
3334 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3336 for (svp = MARK + 1; svp <= SP; svp++) {
3341 if (max > AvMAX(av))
3344 while (++MARK <= SP) {
3345 elem = SvIVx(*MARK);
3349 svp = av_fetch(av, elem, lval);
3351 if (!svp || *svp == &PL_sv_undef)
3352 DIE(aTHX_ PL_no_aelem, elem);
3353 if (PL_op->op_private & OPpLVAL_INTRO)
3354 save_aelem(av, elem, svp);
3356 *MARK = svp ? *svp : &PL_sv_undef;
3359 if (GIMME != G_ARRAY) {
3367 /* Associative arrays. */
3372 HV *hash = (HV*)POPs;
3374 I32 gimme = GIMME_V;
3375 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3378 /* might clobber stack_sp */
3379 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3384 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3385 if (gimme == G_ARRAY) {
3388 /* might clobber stack_sp */
3390 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3395 else if (gimme == G_SCALAR)
3414 I32 gimme = GIMME_V;
3415 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3419 if (PL_op->op_private & OPpSLICE) {
3423 hvtype = SvTYPE(hv);
3424 if (hvtype == SVt_PVHV) { /* hash element */
3425 while (++MARK <= SP) {
3426 sv = hv_delete_ent(hv, *MARK, discard, 0);
3427 *MARK = sv ? sv : &PL_sv_undef;
3430 else if (hvtype == SVt_PVAV) {
3431 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3432 while (++MARK <= SP) {
3433 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3434 *MARK = sv ? sv : &PL_sv_undef;
3437 else { /* pseudo-hash element */
3438 while (++MARK <= SP) {
3439 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3440 *MARK = sv ? sv : &PL_sv_undef;
3445 DIE(aTHX_ "Not a HASH reference");
3448 else if (gimme == G_SCALAR) {
3457 if (SvTYPE(hv) == SVt_PVHV)
3458 sv = hv_delete_ent(hv, keysv, discard, 0);
3459 else if (SvTYPE(hv) == SVt_PVAV) {
3460 if (PL_op->op_flags & OPf_SPECIAL)
3461 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3463 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3466 DIE(aTHX_ "Not a HASH reference");
3481 if (PL_op->op_private & OPpEXISTS_SUB) {
3485 cv = sv_2cv(sv, &hv, &gv, FALSE);
3488 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3494 if (SvTYPE(hv) == SVt_PVHV) {
3495 if (hv_exists_ent(hv, tmpsv, 0))
3498 else if (SvTYPE(hv) == SVt_PVAV) {
3499 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3500 if (av_exists((AV*)hv, SvIV(tmpsv)))
3503 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3507 DIE(aTHX_ "Not a HASH reference");
3514 djSP; dMARK; dORIGMARK;
3515 register HV *hv = (HV*)POPs;
3516 register I32 lval = PL_op->op_flags & OPf_MOD;
3517 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3519 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3520 DIE(aTHX_ "Can't localize pseudo-hash element");
3522 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3523 while (++MARK <= SP) {
3526 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3528 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3529 svp = he ? &HeVAL(he) : 0;
3532 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3535 if (!svp || *svp == &PL_sv_undef) {
3537 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3539 if (PL_op->op_private & OPpLVAL_INTRO) {
3541 save_helem(hv, keysv, svp);
3544 char *key = SvPV(keysv, keylen);
3545 save_delete(hv, key, keylen);
3549 *MARK = svp ? *svp : &PL_sv_undef;
3552 if (GIMME != G_ARRAY) {
3560 /* List operators. */
3565 if (GIMME != G_ARRAY) {
3567 *MARK = *SP; /* unwanted list, return last item */
3569 *MARK = &PL_sv_undef;
3578 SV **lastrelem = PL_stack_sp;
3579 SV **lastlelem = PL_stack_base + POPMARK;
3580 SV **firstlelem = PL_stack_base + POPMARK + 1;
3581 register SV **firstrelem = lastlelem + 1;
3582 I32 arybase = PL_curcop->cop_arybase;
3583 I32 lval = PL_op->op_flags & OPf_MOD;
3584 I32 is_something_there = lval;
3586 register I32 max = lastrelem - lastlelem;
3587 register SV **lelem;
3590 if (GIMME != G_ARRAY) {
3591 ix = SvIVx(*lastlelem);
3596 if (ix < 0 || ix >= max)
3597 *firstlelem = &PL_sv_undef;
3599 *firstlelem = firstrelem[ix];
3605 SP = firstlelem - 1;
3609 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3615 if (ix < 0 || ix >= max)
3616 *lelem = &PL_sv_undef;
3618 is_something_there = TRUE;
3619 if (!(*lelem = firstrelem[ix]))
3620 *lelem = &PL_sv_undef;
3623 if (is_something_there)
3626 SP = firstlelem - 1;
3632 djSP; dMARK; dORIGMARK;
3633 I32 items = SP - MARK;
3634 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3635 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3642 djSP; dMARK; dORIGMARK;
3643 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3647 SV *val = NEWSV(46, 0);
3649 sv_setsv(val, *++MARK);
3650 else if (ckWARN(WARN_MISC))
3651 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3652 (void)hv_store_ent(hv,key,val,0);
3661 djSP; dMARK; dORIGMARK;
3662 register AV *ary = (AV*)*++MARK;
3666 register I32 offset;
3667 register I32 length;
3674 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3675 *MARK-- = SvTIED_obj((SV*)ary, mg);
3679 call_method("SPLICE",GIMME_V);
3688 offset = i = SvIVx(*MARK);
3690 offset += AvFILLp(ary) + 1;
3692 offset -= PL_curcop->cop_arybase;
3694 DIE(aTHX_ PL_no_aelem, i);
3696 length = SvIVx(*MARK++);
3698 length += AvFILLp(ary) - offset + 1;
3704 length = AvMAX(ary) + 1; /* close enough to infinity */
3708 length = AvMAX(ary) + 1;
3710 if (offset > AvFILLp(ary) + 1)
3711 offset = AvFILLp(ary) + 1;
3712 after = AvFILLp(ary) + 1 - (offset + length);
3713 if (after < 0) { /* not that much array */
3714 length += after; /* offset+length now in array */
3720 /* At this point, MARK .. SP-1 is our new LIST */
3723 diff = newlen - length;
3724 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3727 if (diff < 0) { /* shrinking the area */
3729 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3730 Copy(MARK, tmparyval, newlen, SV*);
3733 MARK = ORIGMARK + 1;
3734 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3735 MEXTEND(MARK, length);
3736 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3738 EXTEND_MORTAL(length);
3739 for (i = length, dst = MARK; i; i--) {
3740 sv_2mortal(*dst); /* free them eventualy */
3747 *MARK = AvARRAY(ary)[offset+length-1];
3750 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3751 SvREFCNT_dec(*dst++); /* free them now */
3754 AvFILLp(ary) += diff;
3756 /* pull up or down? */
3758 if (offset < after) { /* easier to pull up */
3759 if (offset) { /* esp. if nothing to pull */
3760 src = &AvARRAY(ary)[offset-1];
3761 dst = src - diff; /* diff is negative */
3762 for (i = offset; i > 0; i--) /* can't trust Copy */
3766 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3770 if (after) { /* anything to pull down? */
3771 src = AvARRAY(ary) + offset + length;
3772 dst = src + diff; /* diff is negative */
3773 Move(src, dst, after, SV*);
3775 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3776 /* avoid later double free */
3780 dst[--i] = &PL_sv_undef;
3783 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3785 *dst = NEWSV(46, 0);
3786 sv_setsv(*dst++, *src++);
3788 Safefree(tmparyval);
3791 else { /* no, expanding (or same) */
3793 New(452, tmparyval, length, SV*); /* so remember deletion */
3794 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3797 if (diff > 0) { /* expanding */
3799 /* push up or down? */
3801 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3805 Move(src, dst, offset, SV*);
3807 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3809 AvFILLp(ary) += diff;
3812 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3813 av_extend(ary, AvFILLp(ary) + diff);
3814 AvFILLp(ary) += diff;
3817 dst = AvARRAY(ary) + AvFILLp(ary);
3819 for (i = after; i; i--) {
3826 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3827 *dst = NEWSV(46, 0);
3828 sv_setsv(*dst++, *src++);
3830 MARK = ORIGMARK + 1;
3831 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3833 Copy(tmparyval, MARK, length, SV*);
3835 EXTEND_MORTAL(length);
3836 for (i = length, dst = MARK; i; i--) {
3837 sv_2mortal(*dst); /* free them eventualy */
3841 Safefree(tmparyval);
3845 else if (length--) {
3846 *MARK = tmparyval[length];
3849 while (length-- > 0)
3850 SvREFCNT_dec(tmparyval[length]);
3852 Safefree(tmparyval);
3855 *MARK = &PL_sv_undef;
3863 djSP; dMARK; dORIGMARK; dTARGET;
3864 register AV *ary = (AV*)*++MARK;
3865 register SV *sv = &PL_sv_undef;
3868 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3869 *MARK-- = SvTIED_obj((SV*)ary, mg);
3873 call_method("PUSH",G_SCALAR|G_DISCARD);
3878 /* Why no pre-extend of ary here ? */
3879 for (++MARK; MARK <= SP; MARK++) {
3882 sv_setsv(sv, *MARK);
3887 PUSHi( AvFILL(ary) + 1 );
3895 SV *sv = av_pop(av);
3897 (void)sv_2mortal(sv);
3906 SV *sv = av_shift(av);
3911 (void)sv_2mortal(sv);
3918 djSP; dMARK; dORIGMARK; dTARGET;
3919 register AV *ary = (AV*)*++MARK;
3924 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3925 *MARK-- = SvTIED_obj((SV*)ary, mg);
3929 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3934 av_unshift(ary, SP - MARK);
3937 sv_setsv(sv, *++MARK);
3938 (void)av_store(ary, i++, sv);
3942 PUSHi( AvFILL(ary) + 1 );
3952 if (GIMME == G_ARRAY) {
3959 /* safe as long as stack cannot get extended in the above */
3964 register char *down;
3969 SvUTF8_off(TARG); /* decontaminate */
3971 do_join(TARG, &PL_sv_no, MARK, SP);
3973 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3974 up = SvPV_force(TARG, len);
3976 if (DO_UTF8(TARG)) { /* first reverse each character */
3977 U8* s = (U8*)SvPVX(TARG);
3978 U8* send = (U8*)(s + len);
3987 down = (char*)(s - 1);
3988 if (s > send || !((*down & 0xc0) == 0x80)) {
3989 if (ckWARN_d(WARN_UTF8))
3990 Perl_warner(aTHX_ WARN_UTF8,
3991 "Malformed UTF-8 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 (!(*s++ & 0x80)) {
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 */
5744 bool doutf8 = DO_UTF8(sv);
5746 register char *s = SvPV(sv, len);
5747 char *strend = s + len;
5749 register REGEXP *rx;
5753 I32 maxiters = (strend - s) + 10;
5756 I32 origlimit = limit;
5759 AV *oldstack = PL_curstack;
5760 I32 gimme = GIMME_V;
5761 I32 oldsave = PL_savestack_ix;
5762 I32 make_mortal = 1;
5763 MAGIC *mg = (MAGIC *) NULL;
5766 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5771 DIE(aTHX_ "panic: do_split");
5772 rx = pm->op_pmregexp;
5774 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5775 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5777 if (pm->op_pmreplroot) {
5779 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5781 ary = GvAVn((GV*)pm->op_pmreplroot);
5784 else if (gimme != G_ARRAY)
5786 ary = (AV*)PL_curpad[0];
5788 ary = GvAVn(PL_defgv);
5789 #endif /* USE_THREADS */
5792 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5798 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5800 XPUSHs(SvTIED_obj((SV*)ary, mg));
5806 for (i = AvFILLp(ary); i >= 0; i--)
5807 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5809 /* temporarily switch stacks */
5810 SWITCHSTACK(PL_curstack, ary);
5814 base = SP - PL_stack_base;
5816 if (pm->op_pmflags & PMf_SKIPWHITE) {
5817 if (pm->op_pmflags & PMf_LOCALE) {
5818 while (isSPACE_LC(*s))
5826 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5827 SAVEINT(PL_multiline);
5828 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5832 limit = maxiters + 2;
5833 if (pm->op_pmflags & PMf_WHITE) {
5836 while (m < strend &&
5837 !((pm->op_pmflags & PMf_LOCALE)
5838 ? isSPACE_LC(*m) : isSPACE(*m)))
5843 dstr = NEWSV(30, m-s);
5844 sv_setpvn(dstr, s, m-s);
5848 (void)SvUTF8_on(dstr);
5852 while (s < strend &&
5853 ((pm->op_pmflags & PMf_LOCALE)
5854 ? isSPACE_LC(*s) : isSPACE(*s)))
5858 else if (strEQ("^", rx->precomp)) {
5861 for (m = s; m < strend && *m != '\n'; m++) ;
5865 dstr = NEWSV(30, m-s);
5866 sv_setpvn(dstr, s, m-s);
5870 (void)SvUTF8_on(dstr);
5875 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5876 && (rx->reganch & ROPT_CHECK_ALL)
5877 && !(rx->reganch & ROPT_ANCH)) {
5878 int tail = (rx->reganch & RE_INTUIT_TAIL);
5879 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5882 if (len == 1 && !tail) {
5884 char c = *SvPV(csv, n_a);
5887 for (m = s; m < strend && *m != c; m++) ;
5890 dstr = NEWSV(30, m-s);
5891 sv_setpvn(dstr, s, m-s);
5895 (void)SvUTF8_on(dstr);
5897 /* The rx->minlen is in characters but we want to step
5898 * s ahead by bytes. */
5899 s = m + (doutf8 ? SvCUR(csv) : len);
5904 while (s < strend && --limit &&
5905 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5906 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5909 dstr = NEWSV(31, m-s);
5910 sv_setpvn(dstr, s, m-s);
5914 (void)SvUTF8_on(dstr);
5916 /* The rx->minlen is in characters but we want to step
5917 * s ahead by bytes. */
5918 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5923 maxiters += (strend - s) * rx->nparens;
5924 while (s < strend && --limit
5925 /* && (!rx->check_substr
5926 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5928 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5929 1 /* minend */, sv, NULL, 0))
5931 TAINT_IF(RX_MATCH_TAINTED(rx));
5932 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5937 strend = s + (strend - m);
5939 m = rx->startp[0] + orig;
5940 dstr = NEWSV(32, m-s);
5941 sv_setpvn(dstr, s, m-s);
5945 (void)SvUTF8_on(dstr);
5948 for (i = 1; i <= rx->nparens; i++) {
5949 s = rx->startp[i] + orig;
5950 m = rx->endp[i] + orig;
5952 dstr = NEWSV(33, m-s);
5953 sv_setpvn(dstr, s, m-s);
5956 dstr = NEWSV(33, 0);
5960 (void)SvUTF8_on(dstr);
5964 s = rx->endp[0] + orig;
5968 LEAVE_SCOPE(oldsave);
5969 iters = (SP - PL_stack_base) - base;
5970 if (iters > maxiters)
5971 DIE(aTHX_ "Split loop");
5973 /* keep field after final delim? */
5974 if (s < strend || (iters && origlimit)) {
5975 STRLEN l = strend - s;
5976 dstr = NEWSV(34, l);
5977 sv_setpvn(dstr, s, l);
5981 (void)SvUTF8_on(dstr);
5985 else if (!origlimit) {
5986 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5992 SWITCHSTACK(ary, oldstack);
5993 if (SvSMAGICAL(ary)) {
5998 if (gimme == G_ARRAY) {
6000 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6008 call_method("PUSH",G_SCALAR|G_DISCARD);
6011 if (gimme == G_ARRAY) {
6012 /* EXTEND should not be needed - we just popped them */
6014 for (i=0; i < iters; i++) {
6015 SV **svp = av_fetch(ary, i, FALSE);
6016 PUSHs((svp) ? *svp : &PL_sv_undef);
6023 if (gimme == G_ARRAY)
6026 if (iters || !pm->op_pmreplroot) {
6036 Perl_unlock_condpair(pTHX_ void *svv)
6038 MAGIC *mg = mg_find((SV*)svv, 'm');
6041 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6042 MUTEX_LOCK(MgMUTEXP(mg));
6043 if (MgOWNER(mg) != thr)
6044 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6046 COND_SIGNAL(MgOWNERCONDP(mg));
6047 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6048 PTR2UV(thr), PTR2UV(svv));)
6049 MUTEX_UNLOCK(MgMUTEXP(mg));
6051 #endif /* USE_THREADS */
6060 #endif /* USE_THREADS */
6061 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6062 || SvTYPE(retsv) == SVt_PVCV) {
6063 retsv = refto(retsv);
6074 if (PL_op->op_private & OPpLVAL_INTRO)
6075 PUSHs(*save_threadsv(PL_op->op_targ));
6077 PUSHs(THREADSV(PL_op->op_targ));
6080 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6081 #endif /* USE_THREADS */