3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if LONGSIZE > 4 && defined(_CRAY)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
85 /* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
89 #ifdef NEED_GETPID_PROTO
90 extern Pid_t getpid (void);
96 if (GIMME_V == G_SCALAR)
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
114 if (PL_op->op_flags & OPf_REF) {
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
123 if (GIMME == G_ARRAY) {
124 I32 maxarg = AvFILL((AV*)TARG) + 1;
126 if (SvMAGICAL(TARG)) {
128 for (i=0; i < maxarg; i++) {
129 SV **svp = av_fetch((AV*)TARG, i, FALSE);
130 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
134 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
139 SV* sv = sv_newmortal();
140 I32 maxarg = AvFILL((AV*)TARG) + 1;
141 sv_setiv(sv, maxarg);
153 if (PL_op->op_private & OPpLVAL_INTRO)
154 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
155 if (PL_op->op_flags & OPf_REF)
158 if (GIMME == G_SCALAR)
159 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
163 if (gimme == G_ARRAY) {
166 else if (gimme == G_SCALAR) {
167 SV* sv = sv_newmortal();
168 if (HvFILL((HV*)TARG))
169 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
170 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
180 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
191 tryAMAGICunDEREF(to_gv);
194 if (SvTYPE(sv) == SVt_PVIO) {
195 GV *gv = (GV*) sv_newmortal();
196 gv_init(gv, 0, "", 0, 0);
197 GvIOp(gv) = (IO *)sv;
198 (void)SvREFCNT_inc(sv);
201 else if (SvTYPE(sv) != SVt_PVGV)
202 DIE(aTHX_ "Not a GLOB reference");
205 if (SvTYPE(sv) != SVt_PVGV) {
209 if (SvGMAGICAL(sv)) {
214 if (!SvOK(sv) && sv != &PL_sv_undef) {
215 /* If this is a 'my' scalar and flag is set then vivify
218 if (PL_op->op_private & OPpDEREF) {
221 if (cUNOP->op_targ) {
223 SV *namesv = PL_curpad[cUNOP->op_targ];
224 name = SvPV(namesv, len);
225 gv = (GV*)NEWSV(0,0);
226 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
229 name = CopSTASHPV(PL_curcop);
232 if (SvTYPE(sv) < SVt_RV)
233 sv_upgrade(sv, SVt_RV);
239 if (PL_op->op_flags & OPf_REF ||
240 PL_op->op_private & HINT_STRICT_REFS)
241 DIE(aTHX_ PL_no_usym, "a symbol");
242 if (ckWARN(WARN_UNINITIALIZED))
247 if ((PL_op->op_flags & OPf_SPECIAL) &&
248 !(PL_op->op_flags & OPf_MOD))
250 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
252 && (!is_gv_magical(sym,len,0)
253 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
259 if (PL_op->op_private & HINT_STRICT_REFS)
260 DIE(aTHX_ PL_no_symref, sym, "a symbol");
261 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
265 if (PL_op->op_private & OPpLVAL_INTRO)
266 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
277 tryAMAGICunDEREF(to_sv);
280 switch (SvTYPE(sv)) {
284 DIE(aTHX_ "Not a SCALAR reference");
292 if (SvTYPE(gv) != SVt_PVGV) {
293 if (SvGMAGICAL(sv)) {
299 if (PL_op->op_flags & OPf_REF ||
300 PL_op->op_private & HINT_STRICT_REFS)
301 DIE(aTHX_ PL_no_usym, "a SCALAR");
302 if (ckWARN(WARN_UNINITIALIZED))
307 if ((PL_op->op_flags & OPf_SPECIAL) &&
308 !(PL_op->op_flags & OPf_MOD))
310 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
312 && (!is_gv_magical(sym,len,0)
313 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
319 if (PL_op->op_private & HINT_STRICT_REFS)
320 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
321 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
326 if (PL_op->op_flags & OPf_MOD) {
327 if (PL_op->op_private & OPpLVAL_INTRO)
328 sv = save_scalar((GV*)TOPs);
329 else if (PL_op->op_private & OPpDEREF)
330 vivify_ref(sv, PL_op->op_private & OPpDEREF);
340 SV *sv = AvARYLEN(av);
342 AvARYLEN(av) = sv = NEWSV(0,0);
343 sv_upgrade(sv, SVt_IV);
344 sv_magic(sv, (SV*)av, '#', Nullch, 0);
352 dSP; dTARGET; dPOPss;
354 if (PL_op->op_flags & OPf_MOD || LVRET) {
355 if (SvTYPE(TARG) < SVt_PVLV) {
356 sv_upgrade(TARG, SVt_PVLV);
357 sv_magic(TARG, Nullsv, '.', Nullch, 0);
361 if (LvTARG(TARG) != sv) {
363 SvREFCNT_dec(LvTARG(TARG));
364 LvTARG(TARG) = SvREFCNT_inc(sv);
366 PUSHs(TARG); /* no SvSETMAGIC */
372 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
373 mg = mg_find(sv, 'g');
374 if (mg && mg->mg_len >= 0) {
378 PUSHi(i + PL_curcop->cop_arybase);
392 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
393 /* (But not in defined().) */
394 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
397 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
398 if ((PL_op->op_private & OPpLVAL_INTRO)) {
399 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
402 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
406 cv = (CV*)&PL_sv_undef;
420 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
421 char *s = SvPVX(TOPs);
422 if (strnEQ(s, "CORE::", 6)) {
425 code = keyword(s + 6, SvCUR(TOPs) - 6);
426 if (code < 0) { /* Overridable. */
427 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
428 int i = 0, n = 0, seen_question = 0;
430 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
432 while (i < MAXO) { /* The slow way. */
433 if (strEQ(s + 6, PL_op_name[i])
434 || strEQ(s + 6, PL_op_desc[i]))
440 goto nonesuch; /* Should not happen... */
442 oa = PL_opargs[i] >> OASHIFT;
444 if (oa & OA_OPTIONAL && !seen_question) {
448 else if (n && str[0] == ';' && seen_question)
449 goto set; /* XXXX system, exec */
450 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
451 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
452 /* But globs are already references (kinda) */
453 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
457 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
461 ret = sv_2mortal(newSVpvn(str, n - 1));
463 else if (code) /* Non-Overridable */
465 else { /* None such */
467 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
471 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
473 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
482 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
484 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
500 if (GIMME != G_ARRAY) {
504 *MARK = &PL_sv_undef;
505 *MARK = refto(*MARK);
509 EXTEND_MORTAL(SP - MARK);
511 *MARK = refto(*MARK);
516 S_refto(pTHX_ SV *sv)
520 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
523 if (!(sv = LvTARG(sv)))
526 (void)SvREFCNT_inc(sv);
528 else if (SvTYPE(sv) == SVt_PVAV) {
529 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
532 (void)SvREFCNT_inc(sv);
534 else if (SvPADTMP(sv))
538 (void)SvREFCNT_inc(sv);
541 sv_upgrade(rv, SVt_RV);
555 if (sv && SvGMAGICAL(sv))
558 if (!sv || !SvROK(sv))
562 pv = sv_reftype(sv,TRUE);
563 PUSHp(pv, strlen(pv));
573 stash = CopSTASH(PL_curcop);
579 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
580 Perl_croak(aTHX_ "Attempt to bless into a reference");
582 if (ckWARN(WARN_MISC) && len == 0)
583 Perl_warner(aTHX_ WARN_MISC,
584 "Explicit blessing to '' (assuming package main)");
585 stash = gv_stashpvn(ptr, len, TRUE);
588 (void)sv_bless(TOPs, stash);
602 elem = SvPV(sv, n_a);
606 switch (elem ? *elem : '\0')
609 if (strEQ(elem, "ARRAY"))
610 tmpRef = (SV*)GvAV(gv);
613 if (strEQ(elem, "CODE"))
614 tmpRef = (SV*)GvCVu(gv);
617 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
618 tmpRef = (SV*)GvIOp(gv);
620 if (strEQ(elem, "FORMAT"))
621 tmpRef = (SV*)GvFORM(gv);
624 if (strEQ(elem, "GLOB"))
628 if (strEQ(elem, "HASH"))
629 tmpRef = (SV*)GvHV(gv);
632 if (strEQ(elem, "IO"))
633 tmpRef = (SV*)GvIOp(gv);
636 if (strEQ(elem, "NAME"))
637 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
640 if (strEQ(elem, "PACKAGE"))
641 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
644 if (strEQ(elem, "SCALAR"))
658 /* Pattern matching */
663 register unsigned char *s;
666 register I32 *sfirst;
670 if (sv == PL_lastscream) {
676 SvSCREAM_off(PL_lastscream);
677 SvREFCNT_dec(PL_lastscream);
679 PL_lastscream = SvREFCNT_inc(sv);
682 s = (unsigned char*)(SvPV(sv, len));
686 if (pos > PL_maxscream) {
687 if (PL_maxscream < 0) {
688 PL_maxscream = pos + 80;
689 New(301, PL_screamfirst, 256, I32);
690 New(302, PL_screamnext, PL_maxscream, I32);
693 PL_maxscream = pos + pos / 4;
694 Renew(PL_screamnext, PL_maxscream, I32);
698 sfirst = PL_screamfirst;
699 snext = PL_screamnext;
701 if (!sfirst || !snext)
702 DIE(aTHX_ "do_study: out of memory");
704 for (ch = 256; ch; --ch)
711 snext[pos] = sfirst[ch] - pos;
718 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
727 if (PL_op->op_flags & OPf_STACKED)
733 TARG = sv_newmortal();
738 /* Lvalue operators. */
750 dSP; dMARK; dTARGET; dORIGMARK;
752 do_chop(TARG, *++MARK);
761 SETi(do_chomp(TOPs));
768 register I32 count = 0;
771 count += do_chomp(POPs);
782 if (!sv || !SvANY(sv))
784 switch (SvTYPE(sv)) {
786 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
790 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
794 if (CvROOT(sv) || CvXSUB(sv))
811 if (!PL_op->op_private) {
820 if (SvTHINKFIRST(sv))
823 switch (SvTYPE(sv)) {
833 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
834 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
835 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
839 /* let user-undef'd sub keep its identity */
840 GV* gv = CvGV((CV*)sv);
847 SvSetMagicSV(sv, &PL_sv_undef);
851 Newz(602, gp, 1, GP);
852 GvGP(sv) = gp_ref(gp);
853 GvSV(sv) = NEWSV(72,0);
854 GvLINE(sv) = CopLINE(PL_curcop);
860 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
863 SvPV_set(sv, Nullch);
876 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
877 DIE(aTHX_ PL_no_modify);
878 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
879 SvIVX(TOPs) != IV_MIN)
882 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
893 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
894 DIE(aTHX_ PL_no_modify);
895 sv_setsv(TARG, TOPs);
896 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
897 SvIVX(TOPs) != IV_MAX)
900 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
914 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
915 DIE(aTHX_ PL_no_modify);
916 sv_setsv(TARG, TOPs);
917 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
918 SvIVX(TOPs) != IV_MIN)
921 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
930 /* Ordinary operators. */
934 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
937 SETn( Perl_pow( left, right) );
944 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
945 #ifdef PERL_PRESERVE_IVUV
948 /* Unless the left argument is integer in range we are going to have to
949 use NV maths. Hence only attempt to coerce the right argument if
950 we know the left is integer. */
951 /* Left operand is defined, so is it IV? */
954 bool auvok = SvUOK(TOPm1s);
955 bool buvok = SvUOK(TOPs);
956 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
957 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
964 alow = SvUVX(TOPm1s);
966 IV aiv = SvIVX(TOPm1s);
969 auvok = TRUE; /* effectively it's a UV now */
971 alow = -aiv; /* abs, auvok == false records sign */
977 IV biv = SvIVX(TOPs);
980 buvok = TRUE; /* effectively it's a UV now */
982 blow = -biv; /* abs, buvok == false records sign */
986 /* If this does sign extension on unsigned it's time for plan B */
987 ahigh = alow >> (4 * sizeof (UV));
989 bhigh = blow >> (4 * sizeof (UV));
991 if (ahigh && bhigh) {
992 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
993 which is overflow. Drop to NVs below. */
994 } else if (!ahigh && !bhigh) {
995 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
996 so the unsigned multiply cannot overflow. */
997 UV product = alow * blow;
998 if (auvok == buvok) {
999 /* -ve * -ve or +ve * +ve gives a +ve result. */
1003 } else if (product <= (UV)IV_MIN) {
1004 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1005 /* -ve result, which could overflow an IV */
1009 } /* else drop to NVs below. */
1011 /* One operand is large, 1 small */
1014 /* swap the operands */
1016 bhigh = blow; /* bhigh now the temp var for the swap */
1020 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1021 multiplies can't overflow. shift can, add can, -ve can. */
1022 product_middle = ahigh * blow;
1023 if (!(product_middle & topmask)) {
1024 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1026 product_middle <<= (4 * sizeof (UV));
1027 product_low = alow * blow;
1029 /* as for pp_add, UV + something mustn't get smaller.
1030 IIRC ANSI mandates this wrapping *behaviour* for
1031 unsigned whatever the actual representation*/
1032 product_low += product_middle;
1033 if (product_low >= product_middle) {
1034 /* didn't overflow */
1035 if (auvok == buvok) {
1036 /* -ve * -ve or +ve * +ve gives a +ve result. */
1038 SETu( product_low );
1040 } else if (product_low <= (UV)IV_MIN) {
1041 /* 2s complement assumption again */
1042 /* -ve result, which could overflow an IV */
1044 SETi( -product_low );
1046 } /* else drop to NVs below. */
1048 } /* product_middle too large */
1049 } /* ahigh && bhigh */
1050 } /* SvIOK(TOPm1s) */
1055 SETn( left * right );
1062 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1067 DIE(aTHX_ "Illegal division by zero");
1069 /* insure that 20./5. == 4. */
1072 if ((NV)I_V(left) == left &&
1073 (NV)I_V(right) == right &&
1074 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1078 value = left / right;
1082 value = left / right;
1091 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1097 bool use_double = 0;
1101 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1103 right = (right_neg = (i < 0)) ? -i : i;
1108 right_neg = dright < 0;
1113 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1115 left = (left_neg = (i < 0)) ? -i : i;
1123 left_neg = dleft < 0;
1132 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1134 # define CAST_D2UV(d) U_V(d)
1136 # define CAST_D2UV(d) ((UV)(d))
1138 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1139 * or, in other words, precision of UV more than of NV.
1140 * But in fact the approach below turned out to be an
1141 * optimization - floor() may be slow */
1142 if (dright <= UV_MAX && dleft <= UV_MAX) {
1143 right = CAST_D2UV(dright);
1144 left = CAST_D2UV(dleft);
1149 /* Backward-compatibility clause: */
1150 dright = Perl_floor(dright + 0.5);
1151 dleft = Perl_floor(dleft + 0.5);
1154 DIE(aTHX_ "Illegal modulus zero");
1156 dans = Perl_fmod(dleft, dright);
1157 if ((left_neg != right_neg) && dans)
1158 dans = dright - dans;
1161 sv_setnv(TARG, dans);
1168 DIE(aTHX_ "Illegal modulus zero");
1171 if ((left_neg != right_neg) && ans)
1174 /* XXX may warn: unary minus operator applied to unsigned type */
1175 /* could change -foo to be (~foo)+1 instead */
1176 if (ans <= ~((UV)IV_MAX)+1)
1177 sv_setiv(TARG, ~ans+1);
1179 sv_setnv(TARG, -(NV)ans);
1182 sv_setuv(TARG, ans);
1191 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1193 register IV count = POPi;
1194 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1196 I32 items = SP - MARK;
1199 max = items * count;
1208 repeatcpy((char*)(MARK + items), (char*)MARK,
1209 items * sizeof(SV*), count - 1);
1212 else if (count <= 0)
1215 else { /* Note: mark already snarfed by pp_list */
1220 SvSetSV(TARG, tmpstr);
1221 SvPV_force(TARG, len);
1222 isutf = DO_UTF8(TARG);
1227 SvGROW(TARG, (count * len) + 1);
1228 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1229 SvCUR(TARG) *= count;
1231 *SvEND(TARG) = '\0';
1234 (void)SvPOK_only_UTF8(TARG);
1236 (void)SvPOK_only(TARG);
1238 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1239 /* The parser saw this as a list repeat, and there
1240 are probably several items on the stack. But we're
1241 in scalar context, and there's no pp_list to save us
1242 now. So drop the rest of the items -- robin@kitsite.com
1255 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1256 useleft = USE_LEFT(TOPm1s);
1257 #ifdef PERL_PRESERVE_IVUV
1258 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1259 "bad things" happen if you rely on signed integers wrapping. */
1262 /* Unless the left argument is integer in range we are going to have to
1263 use NV maths. Hence only attempt to coerce the right argument if
1264 we know the left is integer. */
1271 a_valid = auvok = 1;
1272 /* left operand is undef, treat as zero. */
1274 /* Left operand is defined, so is it IV? */
1275 SvIV_please(TOPm1s);
1276 if (SvIOK(TOPm1s)) {
1277 if ((auvok = SvUOK(TOPm1s)))
1278 auv = SvUVX(TOPm1s);
1280 register IV aiv = SvIVX(TOPm1s);
1283 auvok = 1; /* Now acting as a sign flag. */
1284 } else { /* 2s complement assumption for IV_MIN */
1292 bool result_good = 0;
1295 bool buvok = SvUOK(TOPs);
1300 register IV biv = SvIVX(TOPs);
1307 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1308 else "IV" now, independant of how it came in.
1309 if a, b represents positive, A, B negative, a maps to -A etc
1314 all UV maths. negate result if A negative.
1315 subtract if signs same, add if signs differ. */
1317 if (auvok ^ buvok) {
1326 /* Must get smaller */
1331 if (result <= buv) {
1332 /* result really should be -(auv-buv). as its negation
1333 of true value, need to swap our result flag */
1345 if (result <= (UV)IV_MIN)
1346 SETi( -(IV)result );
1348 /* result valid, but out of range for IV. */
1349 SETn( -(NV)result );
1353 } /* Overflow, drop through to NVs. */
1357 useleft = USE_LEFT(TOPm1s);
1361 /* left operand is undef, treat as zero - value */
1365 SETn( TOPn - value );
1372 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1375 if (PL_op->op_private & HINT_INTEGER) {
1389 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1392 if (PL_op->op_private & HINT_INTEGER) {
1406 dSP; 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 dSP; 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 dSP; 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 dSP; 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 dSP; tryAMAGICbinSET(ne,0);
1719 #ifndef NV_PRESERVES_UV
1720 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1721 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1725 #ifdef PERL_PRESERVE_IVUV
1728 SvIV_please(TOPm1s);
1729 if (SvIOK(TOPm1s)) {
1730 bool auvok = SvUOK(TOPm1s);
1731 bool buvok = SvUOK(TOPs);
1733 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1734 IV aiv = SvIVX(TOPm1s);
1735 IV biv = SvIVX(TOPs);
1738 SETs(boolSV(aiv != biv));
1741 if (auvok && buvok) { /* ## UV != UV ## */
1742 UV auv = SvUVX(TOPm1s);
1743 UV buv = SvUVX(TOPs);
1746 SETs(boolSV(auv != buv));
1749 { /* ## Mixed IV,UV ## */
1753 /* != is commutative so swap if needed (save code) */
1755 /* swap. top of stack (b) is the iv */
1759 /* As (a) is a UV, it's >0, so it cannot be == */
1768 /* As (b) is a UV, it's >0, so it cannot be == */
1772 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1774 /* we know iv is >= 0 */
1775 if (uv > (UV) IV_MAX) {
1779 SETs(boolSV((UV)iv != uv));
1787 SETs(boolSV(TOPn != value));
1794 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1795 #ifndef NV_PRESERVES_UV
1796 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1797 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1801 #ifdef PERL_PRESERVE_IVUV
1802 /* Fortunately it seems NaN isn't IOK */
1805 SvIV_please(TOPm1s);
1806 if (SvIOK(TOPm1s)) {
1807 bool leftuvok = SvUOK(TOPm1s);
1808 bool rightuvok = SvUOK(TOPs);
1810 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1811 IV leftiv = SvIVX(TOPm1s);
1812 IV rightiv = SvIVX(TOPs);
1814 if (leftiv > rightiv)
1816 else if (leftiv < rightiv)
1820 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1821 UV leftuv = SvUVX(TOPm1s);
1822 UV rightuv = SvUVX(TOPs);
1824 if (leftuv > rightuv)
1826 else if (leftuv < rightuv)
1830 } else if (leftuvok) { /* ## UV <=> IV ## */
1834 rightiv = SvIVX(TOPs);
1836 /* As (a) is a UV, it's >=0, so it cannot be < */
1839 leftuv = SvUVX(TOPm1s);
1840 if (leftuv > (UV) IV_MAX) {
1841 /* As (b) is an IV, it cannot be > IV_MAX */
1843 } else if (leftuv > (UV)rightiv) {
1845 } else if (leftuv < (UV)rightiv) {
1851 } else { /* ## IV <=> UV ## */
1855 leftiv = SvIVX(TOPm1s);
1857 /* As (b) is a UV, it's >=0, so it must be < */
1860 rightuv = SvUVX(TOPs);
1861 if (rightuv > (UV) IV_MAX) {
1862 /* As (a) is an IV, it cannot be > IV_MAX */
1864 } else if (leftiv > (UV)rightuv) {
1866 } else if (leftiv < (UV)rightuv) {
1884 if (Perl_isnan(left) || Perl_isnan(right)) {
1888 value = (left > right) - (left < right);
1892 else if (left < right)
1894 else if (left > right)
1908 dSP; tryAMAGICbinSET(slt,0);
1911 int cmp = ((PL_op->op_private & OPpLOCALE)
1912 ? sv_cmp_locale(left, right)
1913 : sv_cmp(left, right));
1914 SETs(boolSV(cmp < 0));
1921 dSP; tryAMAGICbinSET(sgt,0);
1924 int cmp = ((PL_op->op_private & OPpLOCALE)
1925 ? sv_cmp_locale(left, right)
1926 : sv_cmp(left, right));
1927 SETs(boolSV(cmp > 0));
1934 dSP; tryAMAGICbinSET(sle,0);
1937 int cmp = ((PL_op->op_private & OPpLOCALE)
1938 ? sv_cmp_locale(left, right)
1939 : sv_cmp(left, right));
1940 SETs(boolSV(cmp <= 0));
1947 dSP; tryAMAGICbinSET(sge,0);
1950 int cmp = ((PL_op->op_private & OPpLOCALE)
1951 ? sv_cmp_locale(left, right)
1952 : sv_cmp(left, right));
1953 SETs(boolSV(cmp >= 0));
1960 dSP; tryAMAGICbinSET(seq,0);
1963 SETs(boolSV(sv_eq(left, right)));
1970 dSP; tryAMAGICbinSET(sne,0);
1973 SETs(boolSV(!sv_eq(left, right)));
1980 dSP; dTARGET; tryAMAGICbin(scmp,0);
1981 #ifndef NV_PRESERVES_UV
1982 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1983 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1989 int cmp = ((PL_op->op_private & OPpLOCALE)
1990 ? sv_cmp_locale(left, right)
1991 : sv_cmp(left, right));
1999 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2002 if (SvNIOKp(left) || SvNIOKp(right)) {
2003 if (PL_op->op_private & HINT_INTEGER) {
2004 IV i = SvIV(left) & SvIV(right);
2008 UV u = SvUV(left) & SvUV(right);
2013 do_vop(PL_op->op_type, TARG, left, right);
2022 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2025 if (SvNIOKp(left) || SvNIOKp(right)) {
2026 if (PL_op->op_private & HINT_INTEGER) {
2027 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2031 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2036 do_vop(PL_op->op_type, TARG, left, right);
2045 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2048 if (SvNIOKp(left) || SvNIOKp(right)) {
2049 if (PL_op->op_private & HINT_INTEGER) {
2050 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2054 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2059 do_vop(PL_op->op_type, TARG, left, right);
2068 dSP; dTARGET; tryAMAGICun(neg);
2071 int flags = SvFLAGS(sv);
2074 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2075 /* It's publicly an integer, or privately an integer-not-float */
2078 if (SvIVX(sv) == IV_MIN) {
2079 /* 2s complement assumption. */
2080 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2083 else if (SvUVX(sv) <= IV_MAX) {
2088 else if (SvIVX(sv) != IV_MIN) {
2092 #ifdef PERL_PRESERVE_IVUV
2101 else if (SvPOKp(sv)) {
2103 char *s = SvPV(sv, len);
2104 if (isIDFIRST(*s)) {
2105 sv_setpvn(TARG, "-", 1);
2108 else if (*s == '+' || *s == '-') {
2110 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2112 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2113 sv_setpvn(TARG, "-", 1);
2119 goto oops_its_an_int;
2120 sv_setnv(TARG, -SvNV(sv));
2132 dSP; tryAMAGICunSET(not);
2133 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2139 dSP; dTARGET; tryAMAGICun(compl);
2143 if (PL_op->op_private & HINT_INTEGER) {
2158 tmps = (U8*)SvPV_force(TARG, len);
2161 /* Calculate exact length, let's not estimate. */
2170 while (tmps < send) {
2171 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2172 tmps += UTF8SKIP(tmps);
2173 targlen += UNISKIP(~c);
2179 /* Now rewind strings and write them. */
2183 Newz(0, result, targlen + 1, U8);
2184 while (tmps < send) {
2185 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2186 tmps += UTF8SKIP(tmps);
2187 result = uvchr_to_utf8(result, ~c);
2191 sv_setpvn(TARG, (char*)result, targlen);
2195 Newz(0, result, nchar + 1, U8);
2196 while (tmps < send) {
2197 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2198 tmps += UTF8SKIP(tmps);
2203 sv_setpvn(TARG, (char*)result, nchar);
2211 register long *tmpl;
2212 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2215 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2220 for ( ; anum > 0; anum--, tmps++)
2229 /* integer versions of some of the above */
2233 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2236 SETi( left * right );
2243 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2247 DIE(aTHX_ "Illegal division by zero");
2248 value = POPi / value;
2256 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2260 DIE(aTHX_ "Illegal modulus zero");
2261 SETi( left % right );
2268 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2271 SETi( left + right );
2278 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2281 SETi( left - right );
2288 dSP; tryAMAGICbinSET(lt,0);
2291 SETs(boolSV(left < right));
2298 dSP; tryAMAGICbinSET(gt,0);
2301 SETs(boolSV(left > right));
2308 dSP; tryAMAGICbinSET(le,0);
2311 SETs(boolSV(left <= right));
2318 dSP; tryAMAGICbinSET(ge,0);
2321 SETs(boolSV(left >= right));
2328 dSP; tryAMAGICbinSET(eq,0);
2331 SETs(boolSV(left == right));
2338 dSP; tryAMAGICbinSET(ne,0);
2341 SETs(boolSV(left != right));
2348 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2355 else if (left < right)
2366 dSP; dTARGET; tryAMAGICun(neg);
2371 /* High falutin' math. */
2375 dSP; dTARGET; tryAMAGICbin(atan2,0);
2378 SETn(Perl_atan2(left, right));
2385 dSP; dTARGET; tryAMAGICun(sin);
2389 value = Perl_sin(value);
2397 dSP; dTARGET; tryAMAGICun(cos);
2401 value = Perl_cos(value);
2407 /* Support Configure command-line overrides for rand() functions.
2408 After 5.005, perhaps we should replace this by Configure support
2409 for drand48(), random(), or rand(). For 5.005, though, maintain
2410 compatibility by calling rand() but allow the user to override it.
2411 See INSTALL for details. --Andy Dougherty 15 July 1998
2413 /* Now it's after 5.005, and Configure supports drand48() and random(),
2414 in addition to rand(). So the overrides should not be needed any more.
2415 --Jarkko Hietaniemi 27 September 1998
2418 #ifndef HAS_DRAND48_PROTO
2419 extern double drand48 (void);
2432 if (!PL_srand_called) {
2433 (void)seedDrand01((Rand_seed_t)seed());
2434 PL_srand_called = TRUE;
2449 (void)seedDrand01((Rand_seed_t)anum);
2450 PL_srand_called = TRUE;
2459 * This is really just a quick hack which grabs various garbage
2460 * values. It really should be a real hash algorithm which
2461 * spreads the effect of every input bit onto every output bit,
2462 * if someone who knows about such things would bother to write it.
2463 * Might be a good idea to add that function to CORE as well.
2464 * No numbers below come from careful analysis or anything here,
2465 * except they are primes and SEED_C1 > 1E6 to get a full-width
2466 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2467 * probably be bigger too.
2470 # define SEED_C1 1000003
2471 #define SEED_C4 73819
2473 # define SEED_C1 25747
2474 #define SEED_C4 20639
2478 #define SEED_C5 26107
2480 #ifndef PERL_NO_DEV_RANDOM
2485 # include <starlet.h>
2486 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2487 * in 100-ns units, typically incremented ever 10 ms. */
2488 unsigned int when[2];
2490 # ifdef HAS_GETTIMEOFDAY
2491 struct timeval when;
2497 /* This test is an escape hatch, this symbol isn't set by Configure. */
2498 #ifndef PERL_NO_DEV_RANDOM
2499 #ifndef PERL_RANDOM_DEVICE
2500 /* /dev/random isn't used by default because reads from it will block
2501 * if there isn't enough entropy available. You can compile with
2502 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2503 * is enough real entropy to fill the seed. */
2504 # define PERL_RANDOM_DEVICE "/dev/urandom"
2506 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2508 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2517 _ckvmssts(sys$gettim(when));
2518 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2520 # ifdef HAS_GETTIMEOFDAY
2521 gettimeofday(&when,(struct timezone *) 0);
2522 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2525 u = (U32)SEED_C1 * when;
2528 u += SEED_C3 * (U32)PerlProc_getpid();
2529 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2530 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2531 u += SEED_C5 * (U32)PTR2UV(&when);
2538 dSP; dTARGET; tryAMAGICun(exp);
2542 value = Perl_exp(value);
2550 dSP; dTARGET; tryAMAGICun(log);
2555 SET_NUMERIC_STANDARD();
2556 DIE(aTHX_ "Can't take log of %g", value);
2558 value = Perl_log(value);
2566 dSP; dTARGET; tryAMAGICun(sqrt);
2571 SET_NUMERIC_STANDARD();
2572 DIE(aTHX_ "Can't take sqrt of %g", value);
2574 value = Perl_sqrt(value);
2582 dSP; dTARGET; tryAMAGICun(int);
2585 IV iv = TOPi; /* attempt to convert to IV if possible. */
2586 /* XXX it's arguable that compiler casting to IV might be subtly
2587 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2588 else preferring IV has introduced a subtle behaviour change bug. OTOH
2589 relying on floating point to be accurate is a bug. */
2600 if (value < (NV)UV_MAX + 0.5) {
2603 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2604 (void)Perl_modf(value, &value);
2606 double tmp = (double)value;
2607 (void)Perl_modf(tmp, &tmp);
2614 if (value > (NV)IV_MIN - 0.5) {
2617 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2618 (void)Perl_modf(-value, &value);
2621 double tmp = (double)value;
2622 (void)Perl_modf(-tmp, &tmp);
2635 dSP; dTARGET; tryAMAGICun(abs);
2637 /* This will cache the NV value if string isn't actually integer */
2641 /* IVX is precise */
2643 SETu(TOPu); /* force it to be numeric only */
2651 /* 2s complement assumption. Also, not really needed as
2652 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2674 tmps = (SvPVx(POPs, len));
2675 argtype = 1; /* allow underscores */
2676 XPUSHn(scan_hex(tmps, len, &argtype));
2688 tmps = (SvPVx(POPs, len));
2689 while (*tmps && len && isSPACE(*tmps))
2693 argtype = 1; /* allow underscores */
2695 value = scan_hex(++tmps, --len, &argtype);
2696 else if (*tmps == 'b')
2697 value = scan_bin(++tmps, --len, &argtype);
2699 value = scan_oct(tmps, len, &argtype);
2712 SETi(sv_len_utf8(sv));
2728 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2730 I32 arybase = PL_curcop->cop_arybase;
2734 int num_args = PL_op->op_private & 7;
2735 bool repl_need_utf8_upgrade = FALSE;
2736 bool repl_is_utf8 = FALSE;
2738 SvTAINTED_off(TARG); /* decontaminate */
2739 SvUTF8_off(TARG); /* decontaminate */
2743 repl = SvPV(repl_sv, repl_len);
2744 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2754 sv_utf8_upgrade(sv);
2756 else if (DO_UTF8(sv))
2757 repl_need_utf8_upgrade = TRUE;
2759 tmps = SvPV(sv, curlen);
2761 utf8_curlen = sv_len_utf8(sv);
2762 if (utf8_curlen == curlen)
2765 curlen = utf8_curlen;
2770 if (pos >= arybase) {
2788 else if (len >= 0) {
2790 if (rem > (I32)curlen)
2805 Perl_croak(aTHX_ "substr outside of string");
2806 if (ckWARN(WARN_SUBSTR))
2807 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2814 sv_pos_u2b(sv, &pos, &rem);
2816 sv_setpvn(TARG, tmps, rem);
2820 SV* repl_sv_copy = NULL;
2822 if (repl_need_utf8_upgrade) {
2823 repl_sv_copy = newSVsv(repl_sv);
2824 sv_utf8_upgrade(repl_sv_copy);
2825 repl = SvPV(repl_sv_copy, repl_len);
2826 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2828 sv_insert(sv, pos, rem, repl, repl_len);
2832 SvREFCNT_dec(repl_sv_copy);
2834 else if (lvalue) { /* it's an lvalue! */
2835 if (!SvGMAGICAL(sv)) {
2839 if (ckWARN(WARN_SUBSTR))
2840 Perl_warner(aTHX_ WARN_SUBSTR,
2841 "Attempt to use reference as lvalue in substr");
2843 if (SvOK(sv)) /* is it defined ? */
2844 (void)SvPOK_only_UTF8(sv);
2846 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2849 if (SvTYPE(TARG) < SVt_PVLV) {
2850 sv_upgrade(TARG, SVt_PVLV);
2851 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2855 if (LvTARG(TARG) != sv) {
2857 SvREFCNT_dec(LvTARG(TARG));
2858 LvTARG(TARG) = SvREFCNT_inc(sv);
2860 LvTARGOFF(TARG) = upos;
2861 LvTARGLEN(TARG) = urem;
2865 PUSHs(TARG); /* avoid SvSETMAGIC here */
2872 register IV size = POPi;
2873 register IV offset = POPi;
2874 register SV *src = POPs;
2875 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2877 SvTAINTED_off(TARG); /* decontaminate */
2878 if (lvalue) { /* it's an lvalue! */
2879 if (SvTYPE(TARG) < SVt_PVLV) {
2880 sv_upgrade(TARG, SVt_PVLV);
2881 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2884 if (LvTARG(TARG) != src) {
2886 SvREFCNT_dec(LvTARG(TARG));
2887 LvTARG(TARG) = SvREFCNT_inc(src);
2889 LvTARGOFF(TARG) = offset;
2890 LvTARGLEN(TARG) = size;
2893 sv_setuv(TARG, do_vecget(src, offset, size));
2908 I32 arybase = PL_curcop->cop_arybase;
2913 offset = POPi - arybase;
2916 tmps = SvPV(big, biglen);
2917 if (offset > 0 && DO_UTF8(big))
2918 sv_pos_u2b(big, &offset, 0);
2921 else if (offset > biglen)
2923 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2924 (unsigned char*)tmps + biglen, little, 0)))
2927 retval = tmps2 - tmps;
2928 if (retval > 0 && DO_UTF8(big))
2929 sv_pos_b2u(big, &retval);
2930 PUSHi(retval + arybase);
2945 I32 arybase = PL_curcop->cop_arybase;
2951 tmps2 = SvPV(little, llen);
2952 tmps = SvPV(big, blen);
2956 if (offset > 0 && DO_UTF8(big))
2957 sv_pos_u2b(big, &offset, 0);
2958 offset = offset - arybase + llen;
2962 else if (offset > blen)
2964 if (!(tmps2 = rninstr(tmps, tmps + offset,
2965 tmps2, tmps2 + llen)))
2968 retval = tmps2 - tmps;
2969 if (retval > 0 && DO_UTF8(big))
2970 sv_pos_b2u(big, &retval);
2971 PUSHi(retval + arybase);
2977 dSP; dMARK; dORIGMARK; dTARGET;
2978 do_sprintf(TARG, SP-MARK, MARK+1);
2979 TAINT_IF(SvTAINTED(TARG));
2990 U8 *s = (U8*)SvPVx(argsv, len);
2992 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3002 (void)SvUPGRADE(TARG,SVt_PV);
3004 if (value > 255 && !IN_BYTE) {
3005 SvGROW(TARG, UNISKIP(value)+1);
3006 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3007 SvCUR_set(TARG, tmps - SvPVX(TARG));
3009 (void)SvPOK_only(TARG);
3020 (void)SvPOK_only(TARG);
3027 dSP; dTARGET; dPOPTOPssrl;
3030 char *tmps = SvPV(left, n_a);
3032 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3034 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3038 "The crypt() function is unimplemented due to excessive paranoia.");
3051 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3053 U8 tmpbuf[UTF8_MAXLEN+1];
3057 if (PL_op->op_private & OPpLOCALE) {
3060 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3063 uv = toTITLE_utf8(s);
3065 tend = uvchr_to_utf8(tmpbuf, uv);
3067 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3069 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3070 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3075 s = (U8*)SvPV_force(sv, slen);
3076 Copy(tmpbuf, s, ulen, U8);
3080 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3082 SvUTF8_off(TARG); /* decontaminate */
3087 s = (U8*)SvPV_force(sv, slen);
3089 if (PL_op->op_private & OPpLOCALE) {
3092 *s = toUPPER_LC(*s);
3110 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3112 U8 tmpbuf[UTF8_MAXLEN+1];
3116 if (PL_op->op_private & OPpLOCALE) {
3119 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3122 uv = toLOWER_utf8(s);
3124 tend = uvchr_to_utf8(tmpbuf, uv);
3126 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3128 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3129 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3134 s = (U8*)SvPV_force(sv, slen);
3135 Copy(tmpbuf, s, ulen, U8);
3139 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3141 SvUTF8_off(TARG); /* decontaminate */
3146 s = (U8*)SvPV_force(sv, slen);
3148 if (PL_op->op_private & OPpLOCALE) {
3151 *s = toLOWER_LC(*s);
3175 s = (U8*)SvPV(sv,len);
3177 SvUTF8_off(TARG); /* decontaminate */
3178 sv_setpvn(TARG, "", 0);
3182 (void)SvUPGRADE(TARG, SVt_PV);
3183 SvGROW(TARG, (len * 2) + 1);
3184 (void)SvPOK_only(TARG);
3185 d = (U8*)SvPVX(TARG);
3187 if (PL_op->op_private & OPpLOCALE) {
3191 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3197 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3203 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3208 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3210 SvUTF8_off(TARG); /* decontaminate */
3215 s = (U8*)SvPV_force(sv, len);
3217 register U8 *send = s + len;
3219 if (PL_op->op_private & OPpLOCALE) {
3222 for (; s < send; s++)
3223 *s = toUPPER_LC(*s);
3226 for (; s < send; s++)
3249 s = (U8*)SvPV(sv,len);
3251 SvUTF8_off(TARG); /* decontaminate */
3252 sv_setpvn(TARG, "", 0);
3256 (void)SvUPGRADE(TARG, SVt_PV);
3257 SvGROW(TARG, (len * 2) + 1);
3258 (void)SvPOK_only(TARG);
3259 d = (U8*)SvPVX(TARG);
3261 if (PL_op->op_private & OPpLOCALE) {
3265 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3271 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3277 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3282 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3284 SvUTF8_off(TARG); /* decontaminate */
3290 s = (U8*)SvPV_force(sv, len);
3292 register U8 *send = s + len;
3294 if (PL_op->op_private & OPpLOCALE) {
3297 for (; s < send; s++)
3298 *s = toLOWER_LC(*s);
3301 for (; s < send; s++)
3316 register char *s = SvPV(sv,len);
3319 SvUTF8_off(TARG); /* decontaminate */
3321 (void)SvUPGRADE(TARG, SVt_PV);
3322 SvGROW(TARG, (len * 2) + 1);
3326 if (UTF8_IS_CONTINUED(*s)) {
3327 STRLEN ulen = UTF8SKIP(s);
3351 SvCUR_set(TARG, d - SvPVX(TARG));
3352 (void)SvPOK_only_UTF8(TARG);
3355 sv_setpvn(TARG, s, len);
3357 if (SvSMAGICAL(TARG))
3366 dSP; dMARK; dORIGMARK;
3368 register AV* av = (AV*)POPs;
3369 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3370 I32 arybase = PL_curcop->cop_arybase;
3373 if (SvTYPE(av) == SVt_PVAV) {
3374 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3376 for (svp = MARK + 1; svp <= SP; svp++) {
3381 if (max > AvMAX(av))
3384 while (++MARK <= SP) {
3385 elem = SvIVx(*MARK);
3389 svp = av_fetch(av, elem, lval);
3391 if (!svp || *svp == &PL_sv_undef)
3392 DIE(aTHX_ PL_no_aelem, elem);
3393 if (PL_op->op_private & OPpLVAL_INTRO)
3394 save_aelem(av, elem, svp);
3396 *MARK = svp ? *svp : &PL_sv_undef;
3399 if (GIMME != G_ARRAY) {
3407 /* Associative arrays. */
3412 HV *hash = (HV*)POPs;
3414 I32 gimme = GIMME_V;
3415 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3418 /* might clobber stack_sp */
3419 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3424 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3425 if (gimme == G_ARRAY) {
3428 /* might clobber stack_sp */
3430 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3435 else if (gimme == G_SCALAR)
3454 I32 gimme = GIMME_V;
3455 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3459 if (PL_op->op_private & OPpSLICE) {
3463 hvtype = SvTYPE(hv);
3464 if (hvtype == SVt_PVHV) { /* hash element */
3465 while (++MARK <= SP) {
3466 sv = hv_delete_ent(hv, *MARK, discard, 0);
3467 *MARK = sv ? sv : &PL_sv_undef;
3470 else if (hvtype == SVt_PVAV) {
3471 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3472 while (++MARK <= SP) {
3473 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3474 *MARK = sv ? sv : &PL_sv_undef;
3477 else { /* pseudo-hash element */
3478 while (++MARK <= SP) {
3479 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3480 *MARK = sv ? sv : &PL_sv_undef;
3485 DIE(aTHX_ "Not a HASH reference");
3488 else if (gimme == G_SCALAR) {
3497 if (SvTYPE(hv) == SVt_PVHV)
3498 sv = hv_delete_ent(hv, keysv, discard, 0);
3499 else if (SvTYPE(hv) == SVt_PVAV) {
3500 if (PL_op->op_flags & OPf_SPECIAL)
3501 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3503 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3506 DIE(aTHX_ "Not a HASH reference");
3521 if (PL_op->op_private & OPpEXISTS_SUB) {
3525 cv = sv_2cv(sv, &hv, &gv, FALSE);
3528 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3534 if (SvTYPE(hv) == SVt_PVHV) {
3535 if (hv_exists_ent(hv, tmpsv, 0))
3538 else if (SvTYPE(hv) == SVt_PVAV) {
3539 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3540 if (av_exists((AV*)hv, SvIV(tmpsv)))
3543 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3547 DIE(aTHX_ "Not a HASH reference");
3554 dSP; dMARK; dORIGMARK;
3555 register HV *hv = (HV*)POPs;
3556 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3557 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3559 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3560 DIE(aTHX_ "Can't localize pseudo-hash element");
3562 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3563 while (++MARK <= SP) {
3566 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3568 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3569 svp = he ? &HeVAL(he) : 0;
3572 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3575 if (!svp || *svp == &PL_sv_undef) {
3577 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3579 if (PL_op->op_private & OPpLVAL_INTRO) {
3581 save_helem(hv, keysv, svp);
3584 char *key = SvPV(keysv, keylen);
3585 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3589 *MARK = svp ? *svp : &PL_sv_undef;
3592 if (GIMME != G_ARRAY) {
3600 /* List operators. */
3605 if (GIMME != G_ARRAY) {
3607 *MARK = *SP; /* unwanted list, return last item */
3609 *MARK = &PL_sv_undef;
3618 SV **lastrelem = PL_stack_sp;
3619 SV **lastlelem = PL_stack_base + POPMARK;
3620 SV **firstlelem = PL_stack_base + POPMARK + 1;
3621 register SV **firstrelem = lastlelem + 1;
3622 I32 arybase = PL_curcop->cop_arybase;
3623 I32 lval = PL_op->op_flags & OPf_MOD;
3624 I32 is_something_there = lval;
3626 register I32 max = lastrelem - lastlelem;
3627 register SV **lelem;
3630 if (GIMME != G_ARRAY) {
3631 ix = SvIVx(*lastlelem);
3636 if (ix < 0 || ix >= max)
3637 *firstlelem = &PL_sv_undef;
3639 *firstlelem = firstrelem[ix];
3645 SP = firstlelem - 1;
3649 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3655 if (ix < 0 || ix >= max)
3656 *lelem = &PL_sv_undef;
3658 is_something_there = TRUE;
3659 if (!(*lelem = firstrelem[ix]))
3660 *lelem = &PL_sv_undef;
3663 if (is_something_there)
3666 SP = firstlelem - 1;
3672 dSP; dMARK; dORIGMARK;
3673 I32 items = SP - MARK;
3674 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3675 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3682 dSP; dMARK; dORIGMARK;
3683 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3687 SV *val = NEWSV(46, 0);
3689 sv_setsv(val, *++MARK);
3690 else if (ckWARN(WARN_MISC))
3691 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3692 (void)hv_store_ent(hv,key,val,0);
3701 dSP; dMARK; dORIGMARK;
3702 register AV *ary = (AV*)*++MARK;
3706 register I32 offset;
3707 register I32 length;
3714 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3715 *MARK-- = SvTIED_obj((SV*)ary, mg);
3719 call_method("SPLICE",GIMME_V);
3728 offset = i = SvIVx(*MARK);
3730 offset += AvFILLp(ary) + 1;
3732 offset -= PL_curcop->cop_arybase;
3734 DIE(aTHX_ PL_no_aelem, i);
3736 length = SvIVx(*MARK++);
3738 length += AvFILLp(ary) - offset + 1;
3744 length = AvMAX(ary) + 1; /* close enough to infinity */
3748 length = AvMAX(ary) + 1;
3750 if (offset > AvFILLp(ary) + 1)
3751 offset = AvFILLp(ary) + 1;
3752 after = AvFILLp(ary) + 1 - (offset + length);
3753 if (after < 0) { /* not that much array */
3754 length += after; /* offset+length now in array */
3760 /* At this point, MARK .. SP-1 is our new LIST */
3763 diff = newlen - length;
3764 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3767 if (diff < 0) { /* shrinking the area */
3769 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3770 Copy(MARK, tmparyval, newlen, SV*);
3773 MARK = ORIGMARK + 1;
3774 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3775 MEXTEND(MARK, length);
3776 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3778 EXTEND_MORTAL(length);
3779 for (i = length, dst = MARK; i; i--) {
3780 sv_2mortal(*dst); /* free them eventualy */
3787 *MARK = AvARRAY(ary)[offset+length-1];
3790 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3791 SvREFCNT_dec(*dst++); /* free them now */
3794 AvFILLp(ary) += diff;
3796 /* pull up or down? */
3798 if (offset < after) { /* easier to pull up */
3799 if (offset) { /* esp. if nothing to pull */
3800 src = &AvARRAY(ary)[offset-1];
3801 dst = src - diff; /* diff is negative */
3802 for (i = offset; i > 0; i--) /* can't trust Copy */
3806 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3810 if (after) { /* anything to pull down? */
3811 src = AvARRAY(ary) + offset + length;
3812 dst = src + diff; /* diff is negative */
3813 Move(src, dst, after, SV*);
3815 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3816 /* avoid later double free */
3820 dst[--i] = &PL_sv_undef;
3823 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3825 *dst = NEWSV(46, 0);
3826 sv_setsv(*dst++, *src++);
3828 Safefree(tmparyval);
3831 else { /* no, expanding (or same) */
3833 New(452, tmparyval, length, SV*); /* so remember deletion */
3834 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3837 if (diff > 0) { /* expanding */
3839 /* push up or down? */
3841 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3845 Move(src, dst, offset, SV*);
3847 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3849 AvFILLp(ary) += diff;
3852 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3853 av_extend(ary, AvFILLp(ary) + diff);
3854 AvFILLp(ary) += diff;
3857 dst = AvARRAY(ary) + AvFILLp(ary);
3859 for (i = after; i; i--) {
3866 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3867 *dst = NEWSV(46, 0);
3868 sv_setsv(*dst++, *src++);
3870 MARK = ORIGMARK + 1;
3871 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3873 Copy(tmparyval, MARK, length, SV*);
3875 EXTEND_MORTAL(length);
3876 for (i = length, dst = MARK; i; i--) {
3877 sv_2mortal(*dst); /* free them eventualy */
3881 Safefree(tmparyval);
3885 else if (length--) {
3886 *MARK = tmparyval[length];
3889 while (length-- > 0)
3890 SvREFCNT_dec(tmparyval[length]);
3892 Safefree(tmparyval);
3895 *MARK = &PL_sv_undef;
3903 dSP; dMARK; dORIGMARK; dTARGET;
3904 register AV *ary = (AV*)*++MARK;
3905 register SV *sv = &PL_sv_undef;
3908 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3909 *MARK-- = SvTIED_obj((SV*)ary, mg);
3913 call_method("PUSH",G_SCALAR|G_DISCARD);
3918 /* Why no pre-extend of ary here ? */
3919 for (++MARK; MARK <= SP; MARK++) {
3922 sv_setsv(sv, *MARK);
3927 PUSHi( AvFILL(ary) + 1 );
3935 SV *sv = av_pop(av);
3937 (void)sv_2mortal(sv);
3946 SV *sv = av_shift(av);
3951 (void)sv_2mortal(sv);
3958 dSP; dMARK; dORIGMARK; dTARGET;
3959 register AV *ary = (AV*)*++MARK;
3964 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3965 *MARK-- = SvTIED_obj((SV*)ary, mg);
3969 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3974 av_unshift(ary, SP - MARK);
3977 sv_setsv(sv, *++MARK);
3978 (void)av_store(ary, i++, sv);
3982 PUSHi( AvFILL(ary) + 1 );
3992 if (GIMME == G_ARRAY) {
3999 /* safe as long as stack cannot get extended in the above */
4004 register char *down;
4009 SvUTF8_off(TARG); /* decontaminate */
4011 do_join(TARG, &PL_sv_no, MARK, SP);
4013 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4014 up = SvPV_force(TARG, len);
4016 if (DO_UTF8(TARG)) { /* first reverse each character */
4017 U8* s = (U8*)SvPVX(TARG);
4018 U8* send = (U8*)(s + len);
4020 if (UTF8_IS_INVARIANT(*s)) {
4025 if (!utf8_to_uvchr(s, 0))
4029 down = (char*)(s - 1);
4030 /* reverse this character */
4040 down = SvPVX(TARG) + len - 1;
4046 (void)SvPOK_only_UTF8(TARG);
4055 S_mul128(pTHX_ SV *sv, U8 m)
4058 char *s = SvPV(sv, len);
4062 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4063 SV *tmpNew = newSVpvn("0000000000", 10);
4065 sv_catsv(tmpNew, sv);
4066 SvREFCNT_dec(sv); /* free old sv */
4071 while (!*t) /* trailing '\0'? */
4074 i = ((*t - '0') << 7) + m;
4075 *(t--) = '0' + (i % 10);
4081 /* Explosives and implosives. */
4083 #if 'I' == 73 && 'J' == 74
4084 /* On an ASCII/ISO kind of system */
4085 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4088 Some other sort of character set - use memchr() so we don't match
4091 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4099 I32 start_sp_offset = SP - PL_stack_base;
4100 I32 gimme = GIMME_V;
4104 register char *pat = SvPV(left, llen);
4105 #ifdef PACKED_IS_OCTETS
4106 /* Packed side is assumed to be octets - so force downgrade if it
4107 has been UTF-8 encoded by accident
4109 register char *s = SvPVbyte(right, rlen);
4111 register char *s = SvPV(right, rlen);
4113 char *strend = s + rlen;
4115 register char *patend = pat + llen;
4121 /* These must not be in registers: */
4138 register U32 culong;
4142 #ifdef PERL_NATINT_PACK
4143 int natint; /* native integer */
4144 int unatint; /* unsigned native integer */
4147 if (gimme != G_ARRAY) { /* arrange to do first one only */
4149 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4150 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4152 while (isDIGIT(*patend) || *patend == '*')
4158 while (pat < patend) {
4160 datumtype = *pat++ & 0xFF;
4161 #ifdef PERL_NATINT_PACK
4164 if (isSPACE(datumtype))
4166 if (datumtype == '#') {
4167 while (pat < patend && *pat != '\n')
4172 char *natstr = "sSiIlL";
4174 if (strchr(natstr, datumtype)) {
4175 #ifdef PERL_NATINT_PACK
4181 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4186 else if (*pat == '*') {
4187 len = strend - strbeg; /* long enough */
4191 else if (isDIGIT(*pat)) {
4193 while (isDIGIT(*pat)) {
4194 len = (len * 10) + (*pat++ - '0');
4196 DIE(aTHX_ "Repeat count in unpack overflows");
4200 len = (datumtype != '@');
4204 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4205 case ',': /* grandfather in commas but with a warning */
4206 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4207 Perl_warner(aTHX_ WARN_UNPACK,
4208 "Invalid type in unpack: '%c'", (int)datumtype);
4211 if (len == 1 && pat[-1] != '1')
4220 if (len > strend - strbeg)
4221 DIE(aTHX_ "@ outside of string");
4225 if (len > s - strbeg)
4226 DIE(aTHX_ "X outside of string");
4230 if (len > strend - s)
4231 DIE(aTHX_ "x outside of string");
4235 if (start_sp_offset >= SP - PL_stack_base)
4236 DIE(aTHX_ "/ must follow a numeric type");
4239 pat++; /* ignore '*' for compatibility with pack */
4241 DIE(aTHX_ "/ cannot take a count" );
4248 if (len > strend - s)
4251 goto uchar_checksum;
4252 sv = NEWSV(35, len);
4253 sv_setpvn(sv, s, len);
4255 if (datumtype == 'A' || datumtype == 'Z') {
4256 aptr = s; /* borrow register */
4257 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4262 else { /* 'A' strips both nulls and spaces */
4263 s = SvPVX(sv) + len - 1;
4264 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4268 SvCUR_set(sv, s - SvPVX(sv));
4269 s = aptr; /* unborrow register */
4271 XPUSHs(sv_2mortal(sv));
4275 if (star || len > (strend - s) * 8)
4276 len = (strend - s) * 8;
4279 Newz(601, PL_bitcount, 256, char);
4280 for (bits = 1; bits < 256; bits++) {
4281 if (bits & 1) PL_bitcount[bits]++;
4282 if (bits & 2) PL_bitcount[bits]++;
4283 if (bits & 4) PL_bitcount[bits]++;
4284 if (bits & 8) PL_bitcount[bits]++;
4285 if (bits & 16) PL_bitcount[bits]++;
4286 if (bits & 32) PL_bitcount[bits]++;
4287 if (bits & 64) PL_bitcount[bits]++;
4288 if (bits & 128) PL_bitcount[bits]++;
4292 culong += PL_bitcount[*(unsigned char*)s++];
4297 if (datumtype == 'b') {
4299 if (bits & 1) culong++;
4305 if (bits & 128) culong++;
4312 sv = NEWSV(35, len + 1);
4316 if (datumtype == 'b') {
4318 for (len = 0; len < aint; len++) {
4319 if (len & 7) /*SUPPRESS 595*/
4323 *str++ = '0' + (bits & 1);
4328 for (len = 0; len < aint; len++) {
4333 *str++ = '0' + ((bits & 128) != 0);
4337 XPUSHs(sv_2mortal(sv));
4341 if (star || len > (strend - s) * 2)
4342 len = (strend - s) * 2;
4343 sv = NEWSV(35, len + 1);
4347 if (datumtype == 'h') {
4349 for (len = 0; len < aint; len++) {
4354 *str++ = PL_hexdigit[bits & 15];
4359 for (len = 0; len < aint; len++) {
4364 *str++ = PL_hexdigit[(bits >> 4) & 15];
4368 XPUSHs(sv_2mortal(sv));
4371 if (len > strend - s)
4376 if (aint >= 128) /* fake up signed chars */
4386 if (aint >= 128) /* fake up signed chars */
4389 sv_setiv(sv, (IV)aint);
4390 PUSHs(sv_2mortal(sv));
4395 if (len > strend - s)
4410 sv_setiv(sv, (IV)auint);
4411 PUSHs(sv_2mortal(sv));
4416 if (len > strend - s)
4419 while (len-- > 0 && s < strend) {
4421 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4425 cdouble += (NV)auint;
4433 while (len-- > 0 && s < strend) {
4435 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4439 sv_setuv(sv, (UV)auint);
4440 PUSHs(sv_2mortal(sv));
4445 #if SHORTSIZE == SIZE16
4446 along = (strend - s) / SIZE16;
4448 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4453 #if SHORTSIZE != SIZE16
4457 COPYNN(s, &ashort, sizeof(short));
4468 #if SHORTSIZE > SIZE16
4480 #if SHORTSIZE != SIZE16
4484 COPYNN(s, &ashort, sizeof(short));
4487 sv_setiv(sv, (IV)ashort);
4488 PUSHs(sv_2mortal(sv));
4496 #if SHORTSIZE > SIZE16
4502 sv_setiv(sv, (IV)ashort);
4503 PUSHs(sv_2mortal(sv));
4511 #if SHORTSIZE == SIZE16
4512 along = (strend - s) / SIZE16;
4514 unatint = natint && datumtype == 'S';
4515 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4520 #if SHORTSIZE != SIZE16
4522 unsigned short aushort;
4524 COPYNN(s, &aushort, sizeof(unsigned short));
4525 s += sizeof(unsigned short);
4533 COPY16(s, &aushort);
4536 if (datumtype == 'n')
4537 aushort = PerlSock_ntohs(aushort);
4540 if (datumtype == 'v')
4541 aushort = vtohs(aushort);
4550 #if SHORTSIZE != SIZE16
4552 unsigned short aushort;
4554 COPYNN(s, &aushort, sizeof(unsigned short));
4555 s += sizeof(unsigned short);
4557 sv_setiv(sv, (UV)aushort);
4558 PUSHs(sv_2mortal(sv));
4565 COPY16(s, &aushort);
4569 if (datumtype == 'n')
4570 aushort = PerlSock_ntohs(aushort);
4573 if (datumtype == 'v')
4574 aushort = vtohs(aushort);
4576 sv_setiv(sv, (UV)aushort);
4577 PUSHs(sv_2mortal(sv));
4583 along = (strend - s) / sizeof(int);
4588 Copy(s, &aint, 1, int);
4591 cdouble += (NV)aint;
4600 Copy(s, &aint, 1, int);
4604 /* Without the dummy below unpack("i", pack("i",-1))
4605 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4606 * cc with optimization turned on.
4608 * The bug was detected in
4609 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4610 * with optimization (-O4) turned on.
4611 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4612 * does not have this problem even with -O4.
4614 * This bug was reported as DECC_BUGS 1431
4615 * and tracked internally as GEM_BUGS 7775.
4617 * The bug is fixed in
4618 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4619 * UNIX V4.0F support: DEC C V5.9-006 or later
4620 * UNIX V4.0E support: DEC C V5.8-011 or later
4623 * See also few lines later for the same bug.
4626 sv_setiv(sv, (IV)aint) :
4628 sv_setiv(sv, (IV)aint);
4629 PUSHs(sv_2mortal(sv));
4634 along = (strend - s) / sizeof(unsigned int);
4639 Copy(s, &auint, 1, unsigned int);
4640 s += sizeof(unsigned int);
4642 cdouble += (NV)auint;
4651 Copy(s, &auint, 1, unsigned int);
4652 s += sizeof(unsigned int);
4655 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4656 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4657 * See details few lines earlier. */
4659 sv_setuv(sv, (UV)auint) :
4661 sv_setuv(sv, (UV)auint);
4662 PUSHs(sv_2mortal(sv));
4667 #if LONGSIZE == SIZE32
4668 along = (strend - s) / SIZE32;
4670 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4675 #if LONGSIZE != SIZE32
4678 COPYNN(s, &along, sizeof(long));
4681 cdouble += (NV)along;
4690 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4694 #if LONGSIZE > SIZE32
4695 if (along > 2147483647)
4696 along -= 4294967296;
4700 cdouble += (NV)along;
4709 #if LONGSIZE != SIZE32
4712 COPYNN(s, &along, sizeof(long));
4715 sv_setiv(sv, (IV)along);
4716 PUSHs(sv_2mortal(sv));
4723 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4727 #if LONGSIZE > SIZE32
4728 if (along > 2147483647)
4729 along -= 4294967296;
4733 sv_setiv(sv, (IV)along);
4734 PUSHs(sv_2mortal(sv));
4742 #if LONGSIZE == SIZE32
4743 along = (strend - s) / SIZE32;
4745 unatint = natint && datumtype == 'L';
4746 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4751 #if LONGSIZE != SIZE32
4753 unsigned long aulong;
4755 COPYNN(s, &aulong, sizeof(unsigned long));
4756 s += sizeof(unsigned long);
4758 cdouble += (NV)aulong;
4770 if (datumtype == 'N')
4771 aulong = PerlSock_ntohl(aulong);
4774 if (datumtype == 'V')
4775 aulong = vtohl(aulong);
4778 cdouble += (NV)aulong;
4787 #if LONGSIZE != SIZE32
4789 unsigned long aulong;
4791 COPYNN(s, &aulong, sizeof(unsigned long));
4792 s += sizeof(unsigned long);
4794 sv_setuv(sv, (UV)aulong);
4795 PUSHs(sv_2mortal(sv));
4805 if (datumtype == 'N')
4806 aulong = PerlSock_ntohl(aulong);
4809 if (datumtype == 'V')
4810 aulong = vtohl(aulong);
4813 sv_setuv(sv, (UV)aulong);
4814 PUSHs(sv_2mortal(sv));
4820 along = (strend - s) / sizeof(char*);
4826 if (sizeof(char*) > strend - s)
4829 Copy(s, &aptr, 1, char*);
4835 PUSHs(sv_2mortal(sv));
4845 while ((len > 0) && (s < strend)) {
4846 auv = (auv << 7) | (*s & 0x7f);
4847 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4848 if ((U8)(*s++) < 0x80) {
4852 PUSHs(sv_2mortal(sv));
4856 else if (++bytes >= sizeof(UV)) { /* promote to string */
4860 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4861 while (s < strend) {
4862 sv = mul128(sv, *s & 0x7f);
4863 if (!(*s++ & 0x80)) {
4872 PUSHs(sv_2mortal(sv));
4877 if ((s >= strend) && bytes)
4878 DIE(aTHX_ "Unterminated compressed integer");
4883 if (sizeof(char*) > strend - s)
4886 Copy(s, &aptr, 1, char*);
4891 sv_setpvn(sv, aptr, len);
4892 PUSHs(sv_2mortal(sv));
4896 along = (strend - s) / sizeof(Quad_t);
4902 if (s + sizeof(Quad_t) > strend)
4905 Copy(s, &aquad, 1, Quad_t);
4906 s += sizeof(Quad_t);
4909 if (aquad >= IV_MIN && aquad <= IV_MAX)
4910 sv_setiv(sv, (IV)aquad);
4912 sv_setnv(sv, (NV)aquad);
4913 PUSHs(sv_2mortal(sv));
4917 along = (strend - s) / sizeof(Quad_t);
4923 if (s + sizeof(Uquad_t) > strend)
4926 Copy(s, &auquad, 1, Uquad_t);
4927 s += sizeof(Uquad_t);
4930 if (auquad <= UV_MAX)
4931 sv_setuv(sv, (UV)auquad);
4933 sv_setnv(sv, (NV)auquad);
4934 PUSHs(sv_2mortal(sv));
4938 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4941 along = (strend - s) / sizeof(float);
4946 Copy(s, &afloat, 1, float);
4955 Copy(s, &afloat, 1, float);
4958 sv_setnv(sv, (NV)afloat);
4959 PUSHs(sv_2mortal(sv));
4965 along = (strend - s) / sizeof(double);
4970 Copy(s, &adouble, 1, double);
4971 s += sizeof(double);
4979 Copy(s, &adouble, 1, double);
4980 s += sizeof(double);
4982 sv_setnv(sv, (NV)adouble);
4983 PUSHs(sv_2mortal(sv));
4989 * Initialise the decode mapping. By using a table driven
4990 * algorithm, the code will be character-set independent
4991 * (and just as fast as doing character arithmetic)
4993 if (PL_uudmap['M'] == 0) {
4996 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4997 PL_uudmap[(U8)PL_uuemap[i]] = i;
4999 * Because ' ' and '`' map to the same value,
5000 * we need to decode them both the same.
5005 along = (strend - s) * 3 / 4;
5006 sv = NEWSV(42, along);
5009 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
5014 len = PL_uudmap[*(U8*)s++] & 077;
5016 if (s < strend && ISUUCHAR(*s))
5017 a = PL_uudmap[*(U8*)s++] & 077;
5020 if (s < strend && ISUUCHAR(*s))
5021 b = PL_uudmap[*(U8*)s++] & 077;
5024 if (s < strend && ISUUCHAR(*s))
5025 c = PL_uudmap[*(U8*)s++] & 077;
5028 if (s < strend && ISUUCHAR(*s))
5029 d = PL_uudmap[*(U8*)s++] & 077;
5032 hunk[0] = (a << 2) | (b >> 4);
5033 hunk[1] = (b << 4) | (c >> 2);
5034 hunk[2] = (c << 6) | d;
5035 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5040 else if (s[1] == '\n') /* possible checksum byte */
5043 XPUSHs(sv_2mortal(sv));
5048 if (strchr("fFdD", datumtype) ||
5049 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5053 while (checksum >= 16) {
5057 while (checksum >= 4) {
5063 along = (1 << checksum) - 1;
5064 while (cdouble < 0.0)
5066 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5067 sv_setnv(sv, cdouble);
5070 if (checksum < 32) {
5071 aulong = (1 << checksum) - 1;
5074 sv_setuv(sv, (UV)culong);
5076 XPUSHs(sv_2mortal(sv));
5080 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5081 PUSHs(&PL_sv_undef);
5086 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5090 *hunk = PL_uuemap[len];
5091 sv_catpvn(sv, hunk, 1);
5094 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5095 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5096 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5097 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5098 sv_catpvn(sv, hunk, 4);
5103 char r = (len > 1 ? s[1] : '\0');
5104 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5105 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5106 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5107 hunk[3] = PL_uuemap[0];
5108 sv_catpvn(sv, hunk, 4);
5110 sv_catpvn(sv, "\n", 1);
5114 S_is_an_int(pTHX_ char *s, STRLEN l)
5117 SV *result = newSVpvn(s, l);
5118 char *result_c = SvPV(result, n_a); /* convenience */
5119 char *out = result_c;
5129 SvREFCNT_dec(result);
5152 SvREFCNT_dec(result);
5158 SvCUR_set(result, out - result_c);
5162 /* pnum must be '\0' terminated */
5164 S_div128(pTHX_ SV *pnum, bool *done)
5167 char *s = SvPV(pnum, len);
5176 i = m * 10 + (*t - '0');
5178 r = (i >> 7); /* r < 10 */
5185 SvCUR_set(pnum, (STRLEN) (t - s));
5192 dSP; dMARK; dORIGMARK; dTARGET;
5193 register SV *cat = TARG;
5196 register char *pat = SvPVx(*++MARK, fromlen);
5198 register char *patend = pat + fromlen;
5203 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5204 static char *space10 = " ";
5206 /* These must not be in registers: */
5221 #ifdef PERL_NATINT_PACK
5222 int natint; /* native integer */
5227 sv_setpvn(cat, "", 0);
5229 while (pat < patend) {
5230 SV *lengthcode = Nullsv;
5231 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5232 datumtype = *pat++ & 0xFF;
5233 #ifdef PERL_NATINT_PACK
5236 if (isSPACE(datumtype)) {
5240 #ifndef PACKED_IS_OCTETS
5241 if (datumtype == 'U' && pat == patcopy+1)
5244 if (datumtype == '#') {
5245 while (pat < patend && *pat != '\n')
5250 char *natstr = "sSiIlL";
5252 if (strchr(natstr, datumtype)) {
5253 #ifdef PERL_NATINT_PACK
5259 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5262 len = strchr("@Xxu", datumtype) ? 0 : items;
5265 else if (isDIGIT(*pat)) {
5267 while (isDIGIT(*pat)) {
5268 len = (len * 10) + (*pat++ - '0');
5270 DIE(aTHX_ "Repeat count in pack overflows");
5277 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5278 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5279 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5280 ? *MARK : &PL_sv_no)
5281 + (*pat == 'Z' ? 1 : 0)));
5285 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5286 case ',': /* grandfather in commas but with a warning */
5287 if (commas++ == 0 && ckWARN(WARN_PACK))
5288 Perl_warner(aTHX_ WARN_PACK,
5289 "Invalid type in pack: '%c'", (int)datumtype);
5292 DIE(aTHX_ "%% may only be used in unpack");
5303 if (SvCUR(cat) < len)
5304 DIE(aTHX_ "X outside of string");
5311 sv_catpvn(cat, null10, 10);
5314 sv_catpvn(cat, null10, len);
5320 aptr = SvPV(fromstr, fromlen);
5321 if (pat[-1] == '*') {
5323 if (datumtype == 'Z')
5326 if (fromlen >= len) {
5327 sv_catpvn(cat, aptr, len);
5328 if (datumtype == 'Z')
5329 *(SvEND(cat)-1) = '\0';
5332 sv_catpvn(cat, aptr, fromlen);
5334 if (datumtype == 'A') {
5336 sv_catpvn(cat, space10, 10);
5339 sv_catpvn(cat, space10, len);
5343 sv_catpvn(cat, null10, 10);
5346 sv_catpvn(cat, null10, len);
5358 str = SvPV(fromstr, fromlen);
5362 SvCUR(cat) += (len+7)/8;
5363 SvGROW(cat, SvCUR(cat) + 1);
5364 aptr = SvPVX(cat) + aint;
5369 if (datumtype == 'B') {
5370 for (len = 0; len++ < aint;) {
5371 items |= *str++ & 1;
5375 *aptr++ = items & 0xff;
5381 for (len = 0; len++ < aint;) {
5387 *aptr++ = items & 0xff;
5393 if (datumtype == 'B')
5394 items <<= 7 - (aint & 7);
5396 items >>= 7 - (aint & 7);
5397 *aptr++ = items & 0xff;
5399 str = SvPVX(cat) + SvCUR(cat);
5414 str = SvPV(fromstr, fromlen);
5418 SvCUR(cat) += (len+1)/2;
5419 SvGROW(cat, SvCUR(cat) + 1);
5420 aptr = SvPVX(cat) + aint;
5425 if (datumtype == 'H') {
5426 for (len = 0; len++ < aint;) {
5428 items |= ((*str++ & 15) + 9) & 15;
5430 items |= *str++ & 15;
5434 *aptr++ = items & 0xff;
5440 for (len = 0; len++ < aint;) {
5442 items |= (((*str++ & 15) + 9) & 15) << 4;
5444 items |= (*str++ & 15) << 4;
5448 *aptr++ = items & 0xff;
5454 *aptr++ = items & 0xff;
5455 str = SvPVX(cat) + SvCUR(cat);
5466 aint = SvIV(fromstr);
5468 sv_catpvn(cat, &achar, sizeof(char));
5474 auint = SvUV(fromstr);
5475 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5476 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5481 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5486 afloat = (float)SvNV(fromstr);
5487 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5494 adouble = (double)SvNV(fromstr);
5495 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5501 ashort = (I16)SvIV(fromstr);
5503 ashort = PerlSock_htons(ashort);
5505 CAT16(cat, &ashort);
5511 ashort = (I16)SvIV(fromstr);
5513 ashort = htovs(ashort);
5515 CAT16(cat, &ashort);
5519 #if SHORTSIZE != SIZE16
5521 unsigned short aushort;
5525 aushort = SvUV(fromstr);
5526 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5536 aushort = (U16)SvUV(fromstr);
5537 CAT16(cat, &aushort);
5543 #if SHORTSIZE != SIZE16
5549 ashort = SvIV(fromstr);
5550 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5558 ashort = (I16)SvIV(fromstr);
5559 CAT16(cat, &ashort);
5566 auint = SvUV(fromstr);
5567 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5573 adouble = Perl_floor(SvNV(fromstr));
5576 DIE(aTHX_ "Cannot compress negative numbers");
5579 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5580 adouble <= 0xffffffff
5582 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5583 adouble <= UV_MAX_cxux
5590 char buf[1 + sizeof(UV)];
5591 char *in = buf + sizeof(buf);
5592 UV auv = U_V(adouble);
5595 *--in = (auv & 0x7f) | 0x80;
5598 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5599 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5601 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5602 char *from, *result, *in;
5607 /* Copy string and check for compliance */
5608 from = SvPV(fromstr, len);
5609 if ((norm = is_an_int(from, len)) == NULL)
5610 DIE(aTHX_ "can compress only unsigned integer");
5612 New('w', result, len, char);
5616 *--in = div128(norm, &done) | 0x80;
5617 result[len - 1] &= 0x7F; /* clear continue bit */
5618 sv_catpvn(cat, in, (result + len) - in);
5620 SvREFCNT_dec(norm); /* free norm */
5622 else if (SvNOKp(fromstr)) {
5623 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5624 char *in = buf + sizeof(buf);
5627 double next = floor(adouble / 128);
5628 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5629 if (in <= buf) /* this cannot happen ;-) */
5630 DIE(aTHX_ "Cannot compress integer");
5633 } while (adouble > 0);
5634 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5635 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5638 DIE(aTHX_ "Cannot compress non integer");
5644 aint = SvIV(fromstr);
5645 sv_catpvn(cat, (char*)&aint, sizeof(int));
5651 aulong = SvUV(fromstr);
5653 aulong = PerlSock_htonl(aulong);
5655 CAT32(cat, &aulong);
5661 aulong = SvUV(fromstr);
5663 aulong = htovl(aulong);
5665 CAT32(cat, &aulong);
5669 #if LONGSIZE != SIZE32
5671 unsigned long aulong;
5675 aulong = SvUV(fromstr);
5676 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5684 aulong = SvUV(fromstr);
5685 CAT32(cat, &aulong);
5690 #if LONGSIZE != SIZE32
5696 along = SvIV(fromstr);
5697 sv_catpvn(cat, (char *)&along, sizeof(long));
5705 along = SvIV(fromstr);
5714 auquad = (Uquad_t)SvUV(fromstr);
5715 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5721 aquad = (Quad_t)SvIV(fromstr);
5722 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5727 len = 1; /* assume SV is correct length */
5732 if (fromstr == &PL_sv_undef)
5736 /* XXX better yet, could spirit away the string to
5737 * a safe spot and hang on to it until the result
5738 * of pack() (and all copies of the result) are
5741 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5742 || (SvPADTMP(fromstr)
5743 && !SvREADONLY(fromstr))))
5745 Perl_warner(aTHX_ WARN_PACK,
5746 "Attempt to pack pointer to temporary value");
5748 if (SvPOK(fromstr) || SvNIOK(fromstr))
5749 aptr = SvPV(fromstr,n_a);
5751 aptr = SvPV_force(fromstr,n_a);
5753 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5758 aptr = SvPV(fromstr, fromlen);
5759 SvGROW(cat, fromlen * 4 / 3);
5764 while (fromlen > 0) {
5771 doencodes(cat, aptr, todo);
5790 register IV limit = POPi; /* note, negative is forever */
5793 register char *s = SvPV(sv, len);
5794 bool do_utf8 = DO_UTF8(sv);
5795 char *strend = s + len;
5797 register REGEXP *rx;
5801 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5802 I32 maxiters = slen + 10;
5805 I32 origlimit = limit;
5808 AV *oldstack = PL_curstack;
5809 I32 gimme = GIMME_V;
5810 I32 oldsave = PL_savestack_ix;
5811 I32 make_mortal = 1;
5812 MAGIC *mg = (MAGIC *) NULL;
5815 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5820 DIE(aTHX_ "panic: pp_split");
5821 rx = pm->op_pmregexp;
5823 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5824 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5826 if (pm->op_pmreplroot) {
5828 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5830 ary = GvAVn((GV*)pm->op_pmreplroot);
5833 else if (gimme != G_ARRAY)
5835 ary = (AV*)PL_curpad[0];
5837 ary = GvAVn(PL_defgv);
5838 #endif /* USE_THREADS */
5841 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5847 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5849 XPUSHs(SvTIED_obj((SV*)ary, mg));
5855 for (i = AvFILLp(ary); i >= 0; i--)
5856 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5858 /* temporarily switch stacks */
5859 SWITCHSTACK(PL_curstack, ary);
5863 base = SP - PL_stack_base;
5865 if (pm->op_pmflags & PMf_SKIPWHITE) {
5866 if (pm->op_pmflags & PMf_LOCALE) {
5867 while (isSPACE_LC(*s))
5875 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5876 SAVEINT(PL_multiline);
5877 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5881 limit = maxiters + 2;
5882 if (pm->op_pmflags & PMf_WHITE) {
5885 while (m < strend &&
5886 !((pm->op_pmflags & PMf_LOCALE)
5887 ? isSPACE_LC(*m) : isSPACE(*m)))
5892 dstr = NEWSV(30, m-s);
5893 sv_setpvn(dstr, s, m-s);
5897 (void)SvUTF8_on(dstr);
5901 while (s < strend &&
5902 ((pm->op_pmflags & PMf_LOCALE)
5903 ? isSPACE_LC(*s) : isSPACE(*s)))
5907 else if (strEQ("^", rx->precomp)) {
5910 for (m = s; m < strend && *m != '\n'; m++) ;
5914 dstr = NEWSV(30, m-s);
5915 sv_setpvn(dstr, s, m-s);
5919 (void)SvUTF8_on(dstr);
5924 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5925 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5926 && (rx->reganch & ROPT_CHECK_ALL)
5927 && !(rx->reganch & ROPT_ANCH)) {
5928 int tail = (rx->reganch & RE_INTUIT_TAIL);
5929 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5932 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5934 char c = *SvPV(csv, n_a);
5937 for (m = s; m < strend && *m != c; m++) ;
5940 dstr = NEWSV(30, m-s);
5941 sv_setpvn(dstr, s, m-s);
5945 (void)SvUTF8_on(dstr);
5947 /* The rx->minlen is in characters but we want to step
5948 * s ahead by bytes. */
5950 s = (char*)utf8_hop((U8*)m, len);
5952 s = m + len; /* Fake \n at the end */
5957 while (s < strend && --limit &&
5958 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5959 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5962 dstr = NEWSV(31, m-s);
5963 sv_setpvn(dstr, s, m-s);
5967 (void)SvUTF8_on(dstr);
5969 /* The rx->minlen is in characters but we want to step
5970 * s ahead by bytes. */
5972 s = (char*)utf8_hop((U8*)m, len);
5974 s = m + len; /* Fake \n at the end */
5979 maxiters += slen * rx->nparens;
5980 while (s < strend && --limit
5981 /* && (!rx->check_substr
5982 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5984 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5985 1 /* minend */, sv, NULL, 0))
5987 TAINT_IF(RX_MATCH_TAINTED(rx));
5988 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5993 strend = s + (strend - m);
5995 m = rx->startp[0] + orig;
5996 dstr = NEWSV(32, m-s);
5997 sv_setpvn(dstr, s, m-s);
6001 (void)SvUTF8_on(dstr);
6004 for (i = 1; i <= rx->nparens; i++) {
6005 s = rx->startp[i] + orig;
6006 m = rx->endp[i] + orig;
6008 dstr = NEWSV(33, m-s);
6009 sv_setpvn(dstr, s, m-s);
6012 dstr = NEWSV(33, 0);
6016 (void)SvUTF8_on(dstr);
6020 s = rx->endp[0] + orig;
6024 LEAVE_SCOPE(oldsave);
6025 iters = (SP - PL_stack_base) - base;
6026 if (iters > maxiters)
6027 DIE(aTHX_ "Split loop");
6029 /* keep field after final delim? */
6030 if (s < strend || (iters && origlimit)) {
6031 STRLEN l = strend - s;
6032 dstr = NEWSV(34, l);
6033 sv_setpvn(dstr, s, l);
6037 (void)SvUTF8_on(dstr);
6041 else if (!origlimit) {
6042 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6048 SWITCHSTACK(ary, oldstack);
6049 if (SvSMAGICAL(ary)) {
6054 if (gimme == G_ARRAY) {
6056 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6064 call_method("PUSH",G_SCALAR|G_DISCARD);
6067 if (gimme == G_ARRAY) {
6068 /* EXTEND should not be needed - we just popped them */
6070 for (i=0; i < iters; i++) {
6071 SV **svp = av_fetch(ary, i, FALSE);
6072 PUSHs((svp) ? *svp : &PL_sv_undef);
6079 if (gimme == G_ARRAY)
6082 if (iters || !pm->op_pmreplroot) {
6092 Perl_unlock_condpair(pTHX_ void *svv)
6094 MAGIC *mg = mg_find((SV*)svv, 'm');
6097 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6098 MUTEX_LOCK(MgMUTEXP(mg));
6099 if (MgOWNER(mg) != thr)
6100 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6102 COND_SIGNAL(MgOWNERCONDP(mg));
6103 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6104 PTR2UV(thr), PTR2UV(svv));)
6105 MUTEX_UNLOCK(MgMUTEXP(mg));
6107 #endif /* USE_THREADS */
6116 #endif /* USE_THREADS */
6117 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6118 || SvTYPE(retsv) == SVt_PVCV) {
6119 retsv = refto(retsv);
6130 if (PL_op->op_private & OPpLVAL_INTRO)
6131 PUSHs(*save_threadsv(PL_op->op_targ));
6133 PUSHs(THREADSV(PL_op->op_targ));
6136 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6137 #endif /* USE_THREADS */