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 :
3567 realhv ? hv_exists_ent(hv, keysv, 0)
3568 : avhv_exists_ent((AV*)hv, keysv, 0);
3570 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3571 svp = he ? &HeVAL(he) : 0;
3574 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3577 if (!svp || *svp == &PL_sv_undef) {
3579 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3581 if (PL_op->op_private & OPpLVAL_INTRO) {
3583 save_helem(hv, keysv, svp);
3586 char *key = SvPV(keysv, keylen);
3587 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3591 *MARK = svp ? *svp : &PL_sv_undef;
3594 if (GIMME != G_ARRAY) {
3602 /* List operators. */
3607 if (GIMME != G_ARRAY) {
3609 *MARK = *SP; /* unwanted list, return last item */
3611 *MARK = &PL_sv_undef;
3620 SV **lastrelem = PL_stack_sp;
3621 SV **lastlelem = PL_stack_base + POPMARK;
3622 SV **firstlelem = PL_stack_base + POPMARK + 1;
3623 register SV **firstrelem = lastlelem + 1;
3624 I32 arybase = PL_curcop->cop_arybase;
3625 I32 lval = PL_op->op_flags & OPf_MOD;
3626 I32 is_something_there = lval;
3628 register I32 max = lastrelem - lastlelem;
3629 register SV **lelem;
3632 if (GIMME != G_ARRAY) {
3633 ix = SvIVx(*lastlelem);
3638 if (ix < 0 || ix >= max)
3639 *firstlelem = &PL_sv_undef;
3641 *firstlelem = firstrelem[ix];
3647 SP = firstlelem - 1;
3651 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3657 if (ix < 0 || ix >= max)
3658 *lelem = &PL_sv_undef;
3660 is_something_there = TRUE;
3661 if (!(*lelem = firstrelem[ix]))
3662 *lelem = &PL_sv_undef;
3665 if (is_something_there)
3668 SP = firstlelem - 1;
3674 dSP; dMARK; dORIGMARK;
3675 I32 items = SP - MARK;
3676 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3677 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3684 dSP; dMARK; dORIGMARK;
3685 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3689 SV *val = NEWSV(46, 0);
3691 sv_setsv(val, *++MARK);
3692 else if (ckWARN(WARN_MISC))
3693 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3694 (void)hv_store_ent(hv,key,val,0);
3703 dSP; dMARK; dORIGMARK;
3704 register AV *ary = (AV*)*++MARK;
3708 register I32 offset;
3709 register I32 length;
3716 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3717 *MARK-- = SvTIED_obj((SV*)ary, mg);
3721 call_method("SPLICE",GIMME_V);
3730 offset = i = SvIVx(*MARK);
3732 offset += AvFILLp(ary) + 1;
3734 offset -= PL_curcop->cop_arybase;
3736 DIE(aTHX_ PL_no_aelem, i);
3738 length = SvIVx(*MARK++);
3740 length += AvFILLp(ary) - offset + 1;
3746 length = AvMAX(ary) + 1; /* close enough to infinity */
3750 length = AvMAX(ary) + 1;
3752 if (offset > AvFILLp(ary) + 1)
3753 offset = AvFILLp(ary) + 1;
3754 after = AvFILLp(ary) + 1 - (offset + length);
3755 if (after < 0) { /* not that much array */
3756 length += after; /* offset+length now in array */
3762 /* At this point, MARK .. SP-1 is our new LIST */
3765 diff = newlen - length;
3766 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3769 if (diff < 0) { /* shrinking the area */
3771 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3772 Copy(MARK, tmparyval, newlen, SV*);
3775 MARK = ORIGMARK + 1;
3776 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3777 MEXTEND(MARK, length);
3778 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3780 EXTEND_MORTAL(length);
3781 for (i = length, dst = MARK; i; i--) {
3782 sv_2mortal(*dst); /* free them eventualy */
3789 *MARK = AvARRAY(ary)[offset+length-1];
3792 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3793 SvREFCNT_dec(*dst++); /* free them now */
3796 AvFILLp(ary) += diff;
3798 /* pull up or down? */
3800 if (offset < after) { /* easier to pull up */
3801 if (offset) { /* esp. if nothing to pull */
3802 src = &AvARRAY(ary)[offset-1];
3803 dst = src - diff; /* diff is negative */
3804 for (i = offset; i > 0; i--) /* can't trust Copy */
3808 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3812 if (after) { /* anything to pull down? */
3813 src = AvARRAY(ary) + offset + length;
3814 dst = src + diff; /* diff is negative */
3815 Move(src, dst, after, SV*);
3817 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3818 /* avoid later double free */
3822 dst[--i] = &PL_sv_undef;
3825 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3827 *dst = NEWSV(46, 0);
3828 sv_setsv(*dst++, *src++);
3830 Safefree(tmparyval);
3833 else { /* no, expanding (or same) */
3835 New(452, tmparyval, length, SV*); /* so remember deletion */
3836 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3839 if (diff > 0) { /* expanding */
3841 /* push up or down? */
3843 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3847 Move(src, dst, offset, SV*);
3849 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3851 AvFILLp(ary) += diff;
3854 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3855 av_extend(ary, AvFILLp(ary) + diff);
3856 AvFILLp(ary) += diff;
3859 dst = AvARRAY(ary) + AvFILLp(ary);
3861 for (i = after; i; i--) {
3868 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3869 *dst = NEWSV(46, 0);
3870 sv_setsv(*dst++, *src++);
3872 MARK = ORIGMARK + 1;
3873 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3875 Copy(tmparyval, MARK, length, SV*);
3877 EXTEND_MORTAL(length);
3878 for (i = length, dst = MARK; i; i--) {
3879 sv_2mortal(*dst); /* free them eventualy */
3883 Safefree(tmparyval);
3887 else if (length--) {
3888 *MARK = tmparyval[length];
3891 while (length-- > 0)
3892 SvREFCNT_dec(tmparyval[length]);
3894 Safefree(tmparyval);
3897 *MARK = &PL_sv_undef;
3905 dSP; dMARK; dORIGMARK; dTARGET;
3906 register AV *ary = (AV*)*++MARK;
3907 register SV *sv = &PL_sv_undef;
3910 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3911 *MARK-- = SvTIED_obj((SV*)ary, mg);
3915 call_method("PUSH",G_SCALAR|G_DISCARD);
3920 /* Why no pre-extend of ary here ? */
3921 for (++MARK; MARK <= SP; MARK++) {
3924 sv_setsv(sv, *MARK);
3929 PUSHi( AvFILL(ary) + 1 );
3937 SV *sv = av_pop(av);
3939 (void)sv_2mortal(sv);
3948 SV *sv = av_shift(av);
3953 (void)sv_2mortal(sv);
3960 dSP; dMARK; dORIGMARK; dTARGET;
3961 register AV *ary = (AV*)*++MARK;
3966 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3967 *MARK-- = SvTIED_obj((SV*)ary, mg);
3971 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3976 av_unshift(ary, SP - MARK);
3979 sv_setsv(sv, *++MARK);
3980 (void)av_store(ary, i++, sv);
3984 PUSHi( AvFILL(ary) + 1 );
3994 if (GIMME == G_ARRAY) {
4001 /* safe as long as stack cannot get extended in the above */
4006 register char *down;
4011 SvUTF8_off(TARG); /* decontaminate */
4013 do_join(TARG, &PL_sv_no, MARK, SP);
4015 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4016 up = SvPV_force(TARG, len);
4018 if (DO_UTF8(TARG)) { /* first reverse each character */
4019 U8* s = (U8*)SvPVX(TARG);
4020 U8* send = (U8*)(s + len);
4022 if (UTF8_IS_INVARIANT(*s)) {
4027 if (!utf8_to_uvchr(s, 0))
4031 down = (char*)(s - 1);
4032 /* reverse this character */
4042 down = SvPVX(TARG) + len - 1;
4048 (void)SvPOK_only_UTF8(TARG);
4057 S_mul128(pTHX_ SV *sv, U8 m)
4060 char *s = SvPV(sv, len);
4064 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4065 SV *tmpNew = newSVpvn("0000000000", 10);
4067 sv_catsv(tmpNew, sv);
4068 SvREFCNT_dec(sv); /* free old sv */
4073 while (!*t) /* trailing '\0'? */
4076 i = ((*t - '0') << 7) + m;
4077 *(t--) = '0' + (i % 10);
4083 /* Explosives and implosives. */
4085 #if 'I' == 73 && 'J' == 74
4086 /* On an ASCII/ISO kind of system */
4087 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4090 Some other sort of character set - use memchr() so we don't match
4093 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4101 I32 start_sp_offset = SP - PL_stack_base;
4102 I32 gimme = GIMME_V;
4106 register char *pat = SvPV(left, llen);
4107 #ifdef PACKED_IS_OCTETS
4108 /* Packed side is assumed to be octets - so force downgrade if it
4109 has been UTF-8 encoded by accident
4111 register char *s = SvPVbyte(right, rlen);
4113 register char *s = SvPV(right, rlen);
4115 char *strend = s + rlen;
4117 register char *patend = pat + llen;
4123 /* These must not be in registers: */
4140 register U32 culong;
4144 #ifdef PERL_NATINT_PACK
4145 int natint; /* native integer */
4146 int unatint; /* unsigned native integer */
4149 if (gimme != G_ARRAY) { /* arrange to do first one only */
4151 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4152 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4154 while (isDIGIT(*patend) || *patend == '*')
4160 while (pat < patend) {
4162 datumtype = *pat++ & 0xFF;
4163 #ifdef PERL_NATINT_PACK
4166 if (isSPACE(datumtype))
4168 if (datumtype == '#') {
4169 while (pat < patend && *pat != '\n')
4174 char *natstr = "sSiIlL";
4176 if (strchr(natstr, datumtype)) {
4177 #ifdef PERL_NATINT_PACK
4183 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4188 else if (*pat == '*') {
4189 len = strend - strbeg; /* long enough */
4193 else if (isDIGIT(*pat)) {
4195 while (isDIGIT(*pat)) {
4196 len = (len * 10) + (*pat++ - '0');
4198 DIE(aTHX_ "Repeat count in unpack overflows");
4202 len = (datumtype != '@');
4206 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4207 case ',': /* grandfather in commas but with a warning */
4208 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4209 Perl_warner(aTHX_ WARN_UNPACK,
4210 "Invalid type in unpack: '%c'", (int)datumtype);
4213 if (len == 1 && pat[-1] != '1')
4222 if (len > strend - strbeg)
4223 DIE(aTHX_ "@ outside of string");
4227 if (len > s - strbeg)
4228 DIE(aTHX_ "X outside of string");
4232 if (len > strend - s)
4233 DIE(aTHX_ "x outside of string");
4237 if (start_sp_offset >= SP - PL_stack_base)
4238 DIE(aTHX_ "/ must follow a numeric type");
4241 pat++; /* ignore '*' for compatibility with pack */
4243 DIE(aTHX_ "/ cannot take a count" );
4250 if (len > strend - s)
4253 goto uchar_checksum;
4254 sv = NEWSV(35, len);
4255 sv_setpvn(sv, s, len);
4257 if (datumtype == 'A' || datumtype == 'Z') {
4258 aptr = s; /* borrow register */
4259 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4264 else { /* 'A' strips both nulls and spaces */
4265 s = SvPVX(sv) + len - 1;
4266 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4270 SvCUR_set(sv, s - SvPVX(sv));
4271 s = aptr; /* unborrow register */
4273 XPUSHs(sv_2mortal(sv));
4277 if (star || len > (strend - s) * 8)
4278 len = (strend - s) * 8;
4281 Newz(601, PL_bitcount, 256, char);
4282 for (bits = 1; bits < 256; bits++) {
4283 if (bits & 1) PL_bitcount[bits]++;
4284 if (bits & 2) PL_bitcount[bits]++;
4285 if (bits & 4) PL_bitcount[bits]++;
4286 if (bits & 8) PL_bitcount[bits]++;
4287 if (bits & 16) PL_bitcount[bits]++;
4288 if (bits & 32) PL_bitcount[bits]++;
4289 if (bits & 64) PL_bitcount[bits]++;
4290 if (bits & 128) PL_bitcount[bits]++;
4294 culong += PL_bitcount[*(unsigned char*)s++];
4299 if (datumtype == 'b') {
4301 if (bits & 1) culong++;
4307 if (bits & 128) culong++;
4314 sv = NEWSV(35, len + 1);
4318 if (datumtype == 'b') {
4320 for (len = 0; len < aint; len++) {
4321 if (len & 7) /*SUPPRESS 595*/
4325 *str++ = '0' + (bits & 1);
4330 for (len = 0; len < aint; len++) {
4335 *str++ = '0' + ((bits & 128) != 0);
4339 XPUSHs(sv_2mortal(sv));
4343 if (star || len > (strend - s) * 2)
4344 len = (strend - s) * 2;
4345 sv = NEWSV(35, len + 1);
4349 if (datumtype == 'h') {
4351 for (len = 0; len < aint; len++) {
4356 *str++ = PL_hexdigit[bits & 15];
4361 for (len = 0; len < aint; len++) {
4366 *str++ = PL_hexdigit[(bits >> 4) & 15];
4370 XPUSHs(sv_2mortal(sv));
4373 if (len > strend - s)
4378 if (aint >= 128) /* fake up signed chars */
4388 if (aint >= 128) /* fake up signed chars */
4391 sv_setiv(sv, (IV)aint);
4392 PUSHs(sv_2mortal(sv));
4397 if (len > strend - s)
4412 sv_setiv(sv, (IV)auint);
4413 PUSHs(sv_2mortal(sv));
4418 if (len > strend - s)
4421 while (len-- > 0 && s < strend) {
4423 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4427 cdouble += (NV)auint;
4435 while (len-- > 0 && s < strend) {
4437 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4441 sv_setuv(sv, (UV)auint);
4442 PUSHs(sv_2mortal(sv));
4447 #if SHORTSIZE == SIZE16
4448 along = (strend - s) / SIZE16;
4450 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4455 #if SHORTSIZE != SIZE16
4459 COPYNN(s, &ashort, sizeof(short));
4470 #if SHORTSIZE > SIZE16
4482 #if SHORTSIZE != SIZE16
4486 COPYNN(s, &ashort, sizeof(short));
4489 sv_setiv(sv, (IV)ashort);
4490 PUSHs(sv_2mortal(sv));
4498 #if SHORTSIZE > SIZE16
4504 sv_setiv(sv, (IV)ashort);
4505 PUSHs(sv_2mortal(sv));
4513 #if SHORTSIZE == SIZE16
4514 along = (strend - s) / SIZE16;
4516 unatint = natint && datumtype == 'S';
4517 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4522 #if SHORTSIZE != SIZE16
4524 unsigned short aushort;
4526 COPYNN(s, &aushort, sizeof(unsigned short));
4527 s += sizeof(unsigned short);
4535 COPY16(s, &aushort);
4538 if (datumtype == 'n')
4539 aushort = PerlSock_ntohs(aushort);
4542 if (datumtype == 'v')
4543 aushort = vtohs(aushort);
4552 #if SHORTSIZE != SIZE16
4554 unsigned short aushort;
4556 COPYNN(s, &aushort, sizeof(unsigned short));
4557 s += sizeof(unsigned short);
4559 sv_setiv(sv, (UV)aushort);
4560 PUSHs(sv_2mortal(sv));
4567 COPY16(s, &aushort);
4571 if (datumtype == 'n')
4572 aushort = PerlSock_ntohs(aushort);
4575 if (datumtype == 'v')
4576 aushort = vtohs(aushort);
4578 sv_setiv(sv, (UV)aushort);
4579 PUSHs(sv_2mortal(sv));
4585 along = (strend - s) / sizeof(int);
4590 Copy(s, &aint, 1, int);
4593 cdouble += (NV)aint;
4602 Copy(s, &aint, 1, int);
4606 /* Without the dummy below unpack("i", pack("i",-1))
4607 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4608 * cc with optimization turned on.
4610 * The bug was detected in
4611 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4612 * with optimization (-O4) turned on.
4613 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4614 * does not have this problem even with -O4.
4616 * This bug was reported as DECC_BUGS 1431
4617 * and tracked internally as GEM_BUGS 7775.
4619 * The bug is fixed in
4620 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4621 * UNIX V4.0F support: DEC C V5.9-006 or later
4622 * UNIX V4.0E support: DEC C V5.8-011 or later
4625 * See also few lines later for the same bug.
4628 sv_setiv(sv, (IV)aint) :
4630 sv_setiv(sv, (IV)aint);
4631 PUSHs(sv_2mortal(sv));
4636 along = (strend - s) / sizeof(unsigned int);
4641 Copy(s, &auint, 1, unsigned int);
4642 s += sizeof(unsigned int);
4644 cdouble += (NV)auint;
4653 Copy(s, &auint, 1, unsigned int);
4654 s += sizeof(unsigned int);
4657 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4658 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4659 * See details few lines earlier. */
4661 sv_setuv(sv, (UV)auint) :
4663 sv_setuv(sv, (UV)auint);
4664 PUSHs(sv_2mortal(sv));
4669 #if LONGSIZE == SIZE32
4670 along = (strend - s) / SIZE32;
4672 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4677 #if LONGSIZE != SIZE32
4680 COPYNN(s, &along, sizeof(long));
4683 cdouble += (NV)along;
4692 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4696 #if LONGSIZE > SIZE32
4697 if (along > 2147483647)
4698 along -= 4294967296;
4702 cdouble += (NV)along;
4711 #if LONGSIZE != SIZE32
4714 COPYNN(s, &along, sizeof(long));
4717 sv_setiv(sv, (IV)along);
4718 PUSHs(sv_2mortal(sv));
4725 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4729 #if LONGSIZE > SIZE32
4730 if (along > 2147483647)
4731 along -= 4294967296;
4735 sv_setiv(sv, (IV)along);
4736 PUSHs(sv_2mortal(sv));
4744 #if LONGSIZE == SIZE32
4745 along = (strend - s) / SIZE32;
4747 unatint = natint && datumtype == 'L';
4748 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4753 #if LONGSIZE != SIZE32
4755 unsigned long aulong;
4757 COPYNN(s, &aulong, sizeof(unsigned long));
4758 s += sizeof(unsigned long);
4760 cdouble += (NV)aulong;
4772 if (datumtype == 'N')
4773 aulong = PerlSock_ntohl(aulong);
4776 if (datumtype == 'V')
4777 aulong = vtohl(aulong);
4780 cdouble += (NV)aulong;
4789 #if LONGSIZE != SIZE32
4791 unsigned long aulong;
4793 COPYNN(s, &aulong, sizeof(unsigned long));
4794 s += sizeof(unsigned long);
4796 sv_setuv(sv, (UV)aulong);
4797 PUSHs(sv_2mortal(sv));
4807 if (datumtype == 'N')
4808 aulong = PerlSock_ntohl(aulong);
4811 if (datumtype == 'V')
4812 aulong = vtohl(aulong);
4815 sv_setuv(sv, (UV)aulong);
4816 PUSHs(sv_2mortal(sv));
4822 along = (strend - s) / sizeof(char*);
4828 if (sizeof(char*) > strend - s)
4831 Copy(s, &aptr, 1, char*);
4837 PUSHs(sv_2mortal(sv));
4847 while ((len > 0) && (s < strend)) {
4848 auv = (auv << 7) | (*s & 0x7f);
4849 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4850 if ((U8)(*s++) < 0x80) {
4854 PUSHs(sv_2mortal(sv));
4858 else if (++bytes >= sizeof(UV)) { /* promote to string */
4862 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4863 while (s < strend) {
4864 sv = mul128(sv, *s & 0x7f);
4865 if (!(*s++ & 0x80)) {
4874 PUSHs(sv_2mortal(sv));
4879 if ((s >= strend) && bytes)
4880 DIE(aTHX_ "Unterminated compressed integer");
4885 if (sizeof(char*) > strend - s)
4888 Copy(s, &aptr, 1, char*);
4893 sv_setpvn(sv, aptr, len);
4894 PUSHs(sv_2mortal(sv));
4898 along = (strend - s) / sizeof(Quad_t);
4904 if (s + sizeof(Quad_t) > strend)
4907 Copy(s, &aquad, 1, Quad_t);
4908 s += sizeof(Quad_t);
4911 if (aquad >= IV_MIN && aquad <= IV_MAX)
4912 sv_setiv(sv, (IV)aquad);
4914 sv_setnv(sv, (NV)aquad);
4915 PUSHs(sv_2mortal(sv));
4919 along = (strend - s) / sizeof(Quad_t);
4925 if (s + sizeof(Uquad_t) > strend)
4928 Copy(s, &auquad, 1, Uquad_t);
4929 s += sizeof(Uquad_t);
4932 if (auquad <= UV_MAX)
4933 sv_setuv(sv, (UV)auquad);
4935 sv_setnv(sv, (NV)auquad);
4936 PUSHs(sv_2mortal(sv));
4940 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4943 along = (strend - s) / sizeof(float);
4948 Copy(s, &afloat, 1, float);
4957 Copy(s, &afloat, 1, float);
4960 sv_setnv(sv, (NV)afloat);
4961 PUSHs(sv_2mortal(sv));
4967 along = (strend - s) / sizeof(double);
4972 Copy(s, &adouble, 1, double);
4973 s += sizeof(double);
4981 Copy(s, &adouble, 1, double);
4982 s += sizeof(double);
4984 sv_setnv(sv, (NV)adouble);
4985 PUSHs(sv_2mortal(sv));
4991 * Initialise the decode mapping. By using a table driven
4992 * algorithm, the code will be character-set independent
4993 * (and just as fast as doing character arithmetic)
4995 if (PL_uudmap['M'] == 0) {
4998 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4999 PL_uudmap[(U8)PL_uuemap[i]] = i;
5001 * Because ' ' and '`' map to the same value,
5002 * we need to decode them both the same.
5007 along = (strend - s) * 3 / 4;
5008 sv = NEWSV(42, along);
5011 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
5016 len = PL_uudmap[*(U8*)s++] & 077;
5018 if (s < strend && ISUUCHAR(*s))
5019 a = PL_uudmap[*(U8*)s++] & 077;
5022 if (s < strend && ISUUCHAR(*s))
5023 b = PL_uudmap[*(U8*)s++] & 077;
5026 if (s < strend && ISUUCHAR(*s))
5027 c = PL_uudmap[*(U8*)s++] & 077;
5030 if (s < strend && ISUUCHAR(*s))
5031 d = PL_uudmap[*(U8*)s++] & 077;
5034 hunk[0] = (a << 2) | (b >> 4);
5035 hunk[1] = (b << 4) | (c >> 2);
5036 hunk[2] = (c << 6) | d;
5037 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5042 else if (s[1] == '\n') /* possible checksum byte */
5045 XPUSHs(sv_2mortal(sv));
5050 if (strchr("fFdD", datumtype) ||
5051 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5055 while (checksum >= 16) {
5059 while (checksum >= 4) {
5065 along = (1 << checksum) - 1;
5066 while (cdouble < 0.0)
5068 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5069 sv_setnv(sv, cdouble);
5072 if (checksum < 32) {
5073 aulong = (1 << checksum) - 1;
5076 sv_setuv(sv, (UV)culong);
5078 XPUSHs(sv_2mortal(sv));
5082 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5083 PUSHs(&PL_sv_undef);
5088 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5092 *hunk = PL_uuemap[len];
5093 sv_catpvn(sv, hunk, 1);
5096 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5097 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5098 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5099 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5100 sv_catpvn(sv, hunk, 4);
5105 char r = (len > 1 ? s[1] : '\0');
5106 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5107 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5108 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5109 hunk[3] = PL_uuemap[0];
5110 sv_catpvn(sv, hunk, 4);
5112 sv_catpvn(sv, "\n", 1);
5116 S_is_an_int(pTHX_ char *s, STRLEN l)
5119 SV *result = newSVpvn(s, l);
5120 char *result_c = SvPV(result, n_a); /* convenience */
5121 char *out = result_c;
5131 SvREFCNT_dec(result);
5154 SvREFCNT_dec(result);
5160 SvCUR_set(result, out - result_c);
5164 /* pnum must be '\0' terminated */
5166 S_div128(pTHX_ SV *pnum, bool *done)
5169 char *s = SvPV(pnum, len);
5178 i = m * 10 + (*t - '0');
5180 r = (i >> 7); /* r < 10 */
5187 SvCUR_set(pnum, (STRLEN) (t - s));
5194 dSP; dMARK; dORIGMARK; dTARGET;
5195 register SV *cat = TARG;
5198 register char *pat = SvPVx(*++MARK, fromlen);
5200 register char *patend = pat + fromlen;
5205 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5206 static char *space10 = " ";
5208 /* These must not be in registers: */
5223 #ifdef PERL_NATINT_PACK
5224 int natint; /* native integer */
5229 sv_setpvn(cat, "", 0);
5231 while (pat < patend) {
5232 SV *lengthcode = Nullsv;
5233 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5234 datumtype = *pat++ & 0xFF;
5235 #ifdef PERL_NATINT_PACK
5238 if (isSPACE(datumtype)) {
5242 #ifndef PACKED_IS_OCTETS
5243 if (datumtype == 'U' && pat == patcopy+1)
5246 if (datumtype == '#') {
5247 while (pat < patend && *pat != '\n')
5252 char *natstr = "sSiIlL";
5254 if (strchr(natstr, datumtype)) {
5255 #ifdef PERL_NATINT_PACK
5261 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5264 len = strchr("@Xxu", datumtype) ? 0 : items;
5267 else if (isDIGIT(*pat)) {
5269 while (isDIGIT(*pat)) {
5270 len = (len * 10) + (*pat++ - '0');
5272 DIE(aTHX_ "Repeat count in pack overflows");
5279 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5280 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5281 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5282 ? *MARK : &PL_sv_no)
5283 + (*pat == 'Z' ? 1 : 0)));
5287 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5288 case ',': /* grandfather in commas but with a warning */
5289 if (commas++ == 0 && ckWARN(WARN_PACK))
5290 Perl_warner(aTHX_ WARN_PACK,
5291 "Invalid type in pack: '%c'", (int)datumtype);
5294 DIE(aTHX_ "%% may only be used in unpack");
5305 if (SvCUR(cat) < len)
5306 DIE(aTHX_ "X outside of string");
5313 sv_catpvn(cat, null10, 10);
5316 sv_catpvn(cat, null10, len);
5322 aptr = SvPV(fromstr, fromlen);
5323 if (pat[-1] == '*') {
5325 if (datumtype == 'Z')
5328 if (fromlen >= len) {
5329 sv_catpvn(cat, aptr, len);
5330 if (datumtype == 'Z')
5331 *(SvEND(cat)-1) = '\0';
5334 sv_catpvn(cat, aptr, fromlen);
5336 if (datumtype == 'A') {
5338 sv_catpvn(cat, space10, 10);
5341 sv_catpvn(cat, space10, len);
5345 sv_catpvn(cat, null10, 10);
5348 sv_catpvn(cat, null10, len);
5360 str = SvPV(fromstr, fromlen);
5364 SvCUR(cat) += (len+7)/8;
5365 SvGROW(cat, SvCUR(cat) + 1);
5366 aptr = SvPVX(cat) + aint;
5371 if (datumtype == 'B') {
5372 for (len = 0; len++ < aint;) {
5373 items |= *str++ & 1;
5377 *aptr++ = items & 0xff;
5383 for (len = 0; len++ < aint;) {
5389 *aptr++ = items & 0xff;
5395 if (datumtype == 'B')
5396 items <<= 7 - (aint & 7);
5398 items >>= 7 - (aint & 7);
5399 *aptr++ = items & 0xff;
5401 str = SvPVX(cat) + SvCUR(cat);
5416 str = SvPV(fromstr, fromlen);
5420 SvCUR(cat) += (len+1)/2;
5421 SvGROW(cat, SvCUR(cat) + 1);
5422 aptr = SvPVX(cat) + aint;
5427 if (datumtype == 'H') {
5428 for (len = 0; len++ < aint;) {
5430 items |= ((*str++ & 15) + 9) & 15;
5432 items |= *str++ & 15;
5436 *aptr++ = items & 0xff;
5442 for (len = 0; len++ < aint;) {
5444 items |= (((*str++ & 15) + 9) & 15) << 4;
5446 items |= (*str++ & 15) << 4;
5450 *aptr++ = items & 0xff;
5456 *aptr++ = items & 0xff;
5457 str = SvPVX(cat) + SvCUR(cat);
5468 aint = SvIV(fromstr);
5470 sv_catpvn(cat, &achar, sizeof(char));
5476 auint = SvUV(fromstr);
5477 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5478 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5483 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5488 afloat = (float)SvNV(fromstr);
5489 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5496 adouble = (double)SvNV(fromstr);
5497 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5503 ashort = (I16)SvIV(fromstr);
5505 ashort = PerlSock_htons(ashort);
5507 CAT16(cat, &ashort);
5513 ashort = (I16)SvIV(fromstr);
5515 ashort = htovs(ashort);
5517 CAT16(cat, &ashort);
5521 #if SHORTSIZE != SIZE16
5523 unsigned short aushort;
5527 aushort = SvUV(fromstr);
5528 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5538 aushort = (U16)SvUV(fromstr);
5539 CAT16(cat, &aushort);
5545 #if SHORTSIZE != SIZE16
5551 ashort = SvIV(fromstr);
5552 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5560 ashort = (I16)SvIV(fromstr);
5561 CAT16(cat, &ashort);
5568 auint = SvUV(fromstr);
5569 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5575 adouble = Perl_floor(SvNV(fromstr));
5578 DIE(aTHX_ "Cannot compress negative numbers");
5581 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5582 adouble <= 0xffffffff
5584 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5585 adouble <= UV_MAX_cxux
5592 char buf[1 + sizeof(UV)];
5593 char *in = buf + sizeof(buf);
5594 UV auv = U_V(adouble);
5597 *--in = (auv & 0x7f) | 0x80;
5600 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5601 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5603 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5604 char *from, *result, *in;
5609 /* Copy string and check for compliance */
5610 from = SvPV(fromstr, len);
5611 if ((norm = is_an_int(from, len)) == NULL)
5612 DIE(aTHX_ "can compress only unsigned integer");
5614 New('w', result, len, char);
5618 *--in = div128(norm, &done) | 0x80;
5619 result[len - 1] &= 0x7F; /* clear continue bit */
5620 sv_catpvn(cat, in, (result + len) - in);
5622 SvREFCNT_dec(norm); /* free norm */
5624 else if (SvNOKp(fromstr)) {
5625 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5626 char *in = buf + sizeof(buf);
5629 double next = floor(adouble / 128);
5630 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5631 if (in <= buf) /* this cannot happen ;-) */
5632 DIE(aTHX_ "Cannot compress integer");
5635 } while (adouble > 0);
5636 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5637 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5640 DIE(aTHX_ "Cannot compress non integer");
5646 aint = SvIV(fromstr);
5647 sv_catpvn(cat, (char*)&aint, sizeof(int));
5653 aulong = SvUV(fromstr);
5655 aulong = PerlSock_htonl(aulong);
5657 CAT32(cat, &aulong);
5663 aulong = SvUV(fromstr);
5665 aulong = htovl(aulong);
5667 CAT32(cat, &aulong);
5671 #if LONGSIZE != SIZE32
5673 unsigned long aulong;
5677 aulong = SvUV(fromstr);
5678 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5686 aulong = SvUV(fromstr);
5687 CAT32(cat, &aulong);
5692 #if LONGSIZE != SIZE32
5698 along = SvIV(fromstr);
5699 sv_catpvn(cat, (char *)&along, sizeof(long));
5707 along = SvIV(fromstr);
5716 auquad = (Uquad_t)SvUV(fromstr);
5717 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5723 aquad = (Quad_t)SvIV(fromstr);
5724 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5729 len = 1; /* assume SV is correct length */
5734 if (fromstr == &PL_sv_undef)
5738 /* XXX better yet, could spirit away the string to
5739 * a safe spot and hang on to it until the result
5740 * of pack() (and all copies of the result) are
5743 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5744 || (SvPADTMP(fromstr)
5745 && !SvREADONLY(fromstr))))
5747 Perl_warner(aTHX_ WARN_PACK,
5748 "Attempt to pack pointer to temporary value");
5750 if (SvPOK(fromstr) || SvNIOK(fromstr))
5751 aptr = SvPV(fromstr,n_a);
5753 aptr = SvPV_force(fromstr,n_a);
5755 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5760 aptr = SvPV(fromstr, fromlen);
5761 SvGROW(cat, fromlen * 4 / 3);
5766 while (fromlen > 0) {
5773 doencodes(cat, aptr, todo);
5792 register IV limit = POPi; /* note, negative is forever */
5795 register char *s = SvPV(sv, len);
5796 bool do_utf8 = DO_UTF8(sv);
5797 char *strend = s + len;
5799 register REGEXP *rx;
5803 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5804 I32 maxiters = slen + 10;
5807 I32 origlimit = limit;
5810 AV *oldstack = PL_curstack;
5811 I32 gimme = GIMME_V;
5812 I32 oldsave = PL_savestack_ix;
5813 I32 make_mortal = 1;
5814 MAGIC *mg = (MAGIC *) NULL;
5817 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5822 DIE(aTHX_ "panic: pp_split");
5823 rx = pm->op_pmregexp;
5825 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5826 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5828 if (pm->op_pmreplroot) {
5830 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5832 ary = GvAVn((GV*)pm->op_pmreplroot);
5835 else if (gimme != G_ARRAY)
5837 ary = (AV*)PL_curpad[0];
5839 ary = GvAVn(PL_defgv);
5840 #endif /* USE_THREADS */
5843 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5849 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5851 XPUSHs(SvTIED_obj((SV*)ary, mg));
5857 for (i = AvFILLp(ary); i >= 0; i--)
5858 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5860 /* temporarily switch stacks */
5861 SWITCHSTACK(PL_curstack, ary);
5865 base = SP - PL_stack_base;
5867 if (pm->op_pmflags & PMf_SKIPWHITE) {
5868 if (pm->op_pmflags & PMf_LOCALE) {
5869 while (isSPACE_LC(*s))
5877 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5878 SAVEINT(PL_multiline);
5879 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5883 limit = maxiters + 2;
5884 if (pm->op_pmflags & PMf_WHITE) {
5887 while (m < strend &&
5888 !((pm->op_pmflags & PMf_LOCALE)
5889 ? isSPACE_LC(*m) : isSPACE(*m)))
5894 dstr = NEWSV(30, m-s);
5895 sv_setpvn(dstr, s, m-s);
5899 (void)SvUTF8_on(dstr);
5903 while (s < strend &&
5904 ((pm->op_pmflags & PMf_LOCALE)
5905 ? isSPACE_LC(*s) : isSPACE(*s)))
5909 else if (strEQ("^", rx->precomp)) {
5912 for (m = s; m < strend && *m != '\n'; m++) ;
5916 dstr = NEWSV(30, m-s);
5917 sv_setpvn(dstr, s, m-s);
5921 (void)SvUTF8_on(dstr);
5926 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5927 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5928 && (rx->reganch & ROPT_CHECK_ALL)
5929 && !(rx->reganch & ROPT_ANCH)) {
5930 int tail = (rx->reganch & RE_INTUIT_TAIL);
5931 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5934 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5936 char c = *SvPV(csv, n_a);
5939 for (m = s; m < strend && *m != c; m++) ;
5942 dstr = NEWSV(30, m-s);
5943 sv_setpvn(dstr, s, m-s);
5947 (void)SvUTF8_on(dstr);
5949 /* The rx->minlen is in characters but we want to step
5950 * s ahead by bytes. */
5952 s = (char*)utf8_hop((U8*)m, len);
5954 s = m + len; /* Fake \n at the end */
5959 while (s < strend && --limit &&
5960 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5961 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5964 dstr = NEWSV(31, m-s);
5965 sv_setpvn(dstr, s, m-s);
5969 (void)SvUTF8_on(dstr);
5971 /* The rx->minlen is in characters but we want to step
5972 * s ahead by bytes. */
5974 s = (char*)utf8_hop((U8*)m, len);
5976 s = m + len; /* Fake \n at the end */
5981 maxiters += slen * rx->nparens;
5982 while (s < strend && --limit
5983 /* && (!rx->check_substr
5984 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5986 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5987 1 /* minend */, sv, NULL, 0))
5989 TAINT_IF(RX_MATCH_TAINTED(rx));
5990 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5995 strend = s + (strend - m);
5997 m = rx->startp[0] + orig;
5998 dstr = NEWSV(32, m-s);
5999 sv_setpvn(dstr, s, m-s);
6003 (void)SvUTF8_on(dstr);
6006 for (i = 1; i <= rx->nparens; i++) {
6007 s = rx->startp[i] + orig;
6008 m = rx->endp[i] + orig;
6010 dstr = NEWSV(33, m-s);
6011 sv_setpvn(dstr, s, m-s);
6014 dstr = NEWSV(33, 0);
6018 (void)SvUTF8_on(dstr);
6022 s = rx->endp[0] + orig;
6026 LEAVE_SCOPE(oldsave);
6027 iters = (SP - PL_stack_base) - base;
6028 if (iters > maxiters)
6029 DIE(aTHX_ "Split loop");
6031 /* keep field after final delim? */
6032 if (s < strend || (iters && origlimit)) {
6033 STRLEN l = strend - s;
6034 dstr = NEWSV(34, l);
6035 sv_setpvn(dstr, s, l);
6039 (void)SvUTF8_on(dstr);
6043 else if (!origlimit) {
6044 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6050 SWITCHSTACK(ary, oldstack);
6051 if (SvSMAGICAL(ary)) {
6056 if (gimme == G_ARRAY) {
6058 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6066 call_method("PUSH",G_SCALAR|G_DISCARD);
6069 if (gimme == G_ARRAY) {
6070 /* EXTEND should not be needed - we just popped them */
6072 for (i=0; i < iters; i++) {
6073 SV **svp = av_fetch(ary, i, FALSE);
6074 PUSHs((svp) ? *svp : &PL_sv_undef);
6081 if (gimme == G_ARRAY)
6084 if (iters || !pm->op_pmreplroot) {
6094 Perl_unlock_condpair(pTHX_ void *svv)
6096 MAGIC *mg = mg_find((SV*)svv, 'm');
6099 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6100 MUTEX_LOCK(MgMUTEXP(mg));
6101 if (MgOWNER(mg) != thr)
6102 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6104 COND_SIGNAL(MgOWNERCONDP(mg));
6105 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6106 PTR2UV(thr), PTR2UV(svv));)
6107 MUTEX_UNLOCK(MgMUTEXP(mg));
6109 #endif /* USE_THREADS */
6118 #endif /* USE_THREADS */
6119 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6120 || SvTYPE(retsv) == SVt_PVCV) {
6121 retsv = refto(retsv);
6132 if (PL_op->op_private & OPpLVAL_INTRO)
6133 PUSHs(*save_threadsv(PL_op->op_targ));
6135 PUSHs(THREADSV(PL_op->op_targ));
6138 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6139 #endif /* USE_THREADS */