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, PERL_MAGIC_arylen, 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, PERL_MAGIC_pos, 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, PERL_MAGIC_regex_global);
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 /* piggyback on m//g magic */
719 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
728 if (PL_op->op_flags & OPf_STACKED)
734 TARG = sv_newmortal();
739 /* Lvalue operators. */
751 dSP; dMARK; dTARGET; dORIGMARK;
753 do_chop(TARG, *++MARK);
762 SETi(do_chomp(TOPs));
769 register I32 count = 0;
772 count += do_chomp(POPs);
783 if (!sv || !SvANY(sv))
785 switch (SvTYPE(sv)) {
787 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
788 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
792 if (HvARRAY(sv) || SvGMAGICAL(sv)
793 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
797 if (CvROOT(sv) || CvXSUB(sv))
814 if (!PL_op->op_private) {
823 if (SvTHINKFIRST(sv))
826 switch (SvTYPE(sv)) {
836 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
837 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
838 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
842 /* let user-undef'd sub keep its identity */
843 GV* gv = CvGV((CV*)sv);
850 SvSetMagicSV(sv, &PL_sv_undef);
854 Newz(602, gp, 1, GP);
855 GvGP(sv) = gp_ref(gp);
856 GvSV(sv) = NEWSV(72,0);
857 GvLINE(sv) = CopLINE(PL_curcop);
863 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
866 SvPV_set(sv, Nullch);
879 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
880 DIE(aTHX_ PL_no_modify);
881 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
882 SvIVX(TOPs) != IV_MIN)
885 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
896 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
897 DIE(aTHX_ PL_no_modify);
898 sv_setsv(TARG, TOPs);
899 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
900 SvIVX(TOPs) != IV_MAX)
903 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
917 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
918 DIE(aTHX_ PL_no_modify);
919 sv_setsv(TARG, TOPs);
920 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
921 SvIVX(TOPs) != IV_MIN)
924 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
933 /* Ordinary operators. */
937 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
940 SETn( Perl_pow( left, right) );
947 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
948 #ifdef PERL_PRESERVE_IVUV
951 /* Unless the left argument is integer in range we are going to have to
952 use NV maths. Hence only attempt to coerce the right argument if
953 we know the left is integer. */
954 /* Left operand is defined, so is it IV? */
957 bool auvok = SvUOK(TOPm1s);
958 bool buvok = SvUOK(TOPs);
959 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
960 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
967 alow = SvUVX(TOPm1s);
969 IV aiv = SvIVX(TOPm1s);
972 auvok = TRUE; /* effectively it's a UV now */
974 alow = -aiv; /* abs, auvok == false records sign */
980 IV biv = SvIVX(TOPs);
983 buvok = TRUE; /* effectively it's a UV now */
985 blow = -biv; /* abs, buvok == false records sign */
989 /* If this does sign extension on unsigned it's time for plan B */
990 ahigh = alow >> (4 * sizeof (UV));
992 bhigh = blow >> (4 * sizeof (UV));
994 if (ahigh && bhigh) {
995 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
996 which is overflow. Drop to NVs below. */
997 } else if (!ahigh && !bhigh) {
998 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
999 so the unsigned multiply cannot overflow. */
1000 UV product = alow * blow;
1001 if (auvok == buvok) {
1002 /* -ve * -ve or +ve * +ve gives a +ve result. */
1006 } else if (product <= (UV)IV_MIN) {
1007 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1008 /* -ve result, which could overflow an IV */
1012 } /* else drop to NVs below. */
1014 /* One operand is large, 1 small */
1017 /* swap the operands */
1019 bhigh = blow; /* bhigh now the temp var for the swap */
1023 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1024 multiplies can't overflow. shift can, add can, -ve can. */
1025 product_middle = ahigh * blow;
1026 if (!(product_middle & topmask)) {
1027 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1029 product_middle <<= (4 * sizeof (UV));
1030 product_low = alow * blow;
1032 /* as for pp_add, UV + something mustn't get smaller.
1033 IIRC ANSI mandates this wrapping *behaviour* for
1034 unsigned whatever the actual representation*/
1035 product_low += product_middle;
1036 if (product_low >= product_middle) {
1037 /* didn't overflow */
1038 if (auvok == buvok) {
1039 /* -ve * -ve or +ve * +ve gives a +ve result. */
1041 SETu( product_low );
1043 } else if (product_low <= (UV)IV_MIN) {
1044 /* 2s complement assumption again */
1045 /* -ve result, which could overflow an IV */
1047 SETi( -product_low );
1049 } /* else drop to NVs below. */
1051 } /* product_middle too large */
1052 } /* ahigh && bhigh */
1053 } /* SvIOK(TOPm1s) */
1058 SETn( left * right );
1065 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1070 DIE(aTHX_ "Illegal division by zero");
1072 /* insure that 20./5. == 4. */
1075 if ((NV)I_V(left) == left &&
1076 (NV)I_V(right) == right &&
1077 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1081 value = left / right;
1085 value = left / right;
1094 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1100 bool use_double = 0;
1104 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1106 right = (right_neg = (i < 0)) ? -i : i;
1111 right_neg = dright < 0;
1116 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1118 left = (left_neg = (i < 0)) ? -i : i;
1126 left_neg = dleft < 0;
1135 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1137 # define CAST_D2UV(d) U_V(d)
1139 # define CAST_D2UV(d) ((UV)(d))
1141 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1142 * or, in other words, precision of UV more than of NV.
1143 * But in fact the approach below turned out to be an
1144 * optimization - floor() may be slow */
1145 if (dright <= UV_MAX && dleft <= UV_MAX) {
1146 right = CAST_D2UV(dright);
1147 left = CAST_D2UV(dleft);
1152 /* Backward-compatibility clause: */
1153 dright = Perl_floor(dright + 0.5);
1154 dleft = Perl_floor(dleft + 0.5);
1157 DIE(aTHX_ "Illegal modulus zero");
1159 dans = Perl_fmod(dleft, dright);
1160 if ((left_neg != right_neg) && dans)
1161 dans = dright - dans;
1164 sv_setnv(TARG, dans);
1171 DIE(aTHX_ "Illegal modulus zero");
1174 if ((left_neg != right_neg) && ans)
1177 /* XXX may warn: unary minus operator applied to unsigned type */
1178 /* could change -foo to be (~foo)+1 instead */
1179 if (ans <= ~((UV)IV_MAX)+1)
1180 sv_setiv(TARG, ~ans+1);
1182 sv_setnv(TARG, -(NV)ans);
1185 sv_setuv(TARG, ans);
1194 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1196 register IV count = POPi;
1197 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1199 I32 items = SP - MARK;
1202 max = items * count;
1211 repeatcpy((char*)(MARK + items), (char*)MARK,
1212 items * sizeof(SV*), count - 1);
1215 else if (count <= 0)
1218 else { /* Note: mark already snarfed by pp_list */
1223 SvSetSV(TARG, tmpstr);
1224 SvPV_force(TARG, len);
1225 isutf = DO_UTF8(TARG);
1230 SvGROW(TARG, (count * len) + 1);
1231 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1232 SvCUR(TARG) *= count;
1234 *SvEND(TARG) = '\0';
1237 (void)SvPOK_only_UTF8(TARG);
1239 (void)SvPOK_only(TARG);
1241 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1242 /* The parser saw this as a list repeat, and there
1243 are probably several items on the stack. But we're
1244 in scalar context, and there's no pp_list to save us
1245 now. So drop the rest of the items -- robin@kitsite.com
1258 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1259 useleft = USE_LEFT(TOPm1s);
1260 #ifdef PERL_PRESERVE_IVUV
1261 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1262 "bad things" happen if you rely on signed integers wrapping. */
1265 /* Unless the left argument is integer in range we are going to have to
1266 use NV maths. Hence only attempt to coerce the right argument if
1267 we know the left is integer. */
1274 a_valid = auvok = 1;
1275 /* left operand is undef, treat as zero. */
1277 /* Left operand is defined, so is it IV? */
1278 SvIV_please(TOPm1s);
1279 if (SvIOK(TOPm1s)) {
1280 if ((auvok = SvUOK(TOPm1s)))
1281 auv = SvUVX(TOPm1s);
1283 register IV aiv = SvIVX(TOPm1s);
1286 auvok = 1; /* Now acting as a sign flag. */
1287 } else { /* 2s complement assumption for IV_MIN */
1295 bool result_good = 0;
1298 bool buvok = SvUOK(TOPs);
1303 register IV biv = SvIVX(TOPs);
1310 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1311 else "IV" now, independant of how it came in.
1312 if a, b represents positive, A, B negative, a maps to -A etc
1317 all UV maths. negate result if A negative.
1318 subtract if signs same, add if signs differ. */
1320 if (auvok ^ buvok) {
1329 /* Must get smaller */
1334 if (result <= buv) {
1335 /* result really should be -(auv-buv). as its negation
1336 of true value, need to swap our result flag */
1348 if (result <= (UV)IV_MIN)
1349 SETi( -(IV)result );
1351 /* result valid, but out of range for IV. */
1352 SETn( -(NV)result );
1356 } /* Overflow, drop through to NVs. */
1360 useleft = USE_LEFT(TOPm1s);
1364 /* left operand is undef, treat as zero - value */
1368 SETn( TOPn - value );
1375 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1378 if (PL_op->op_private & HINT_INTEGER) {
1392 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1395 if (PL_op->op_private & HINT_INTEGER) {
1409 dSP; tryAMAGICbinSET(lt,0);
1410 #ifdef PERL_PRESERVE_IVUV
1413 SvIV_please(TOPm1s);
1414 if (SvIOK(TOPm1s)) {
1415 bool auvok = SvUOK(TOPm1s);
1416 bool buvok = SvUOK(TOPs);
1418 if (!auvok && !buvok) { /* ## IV < IV ## */
1419 IV aiv = SvIVX(TOPm1s);
1420 IV biv = SvIVX(TOPs);
1423 SETs(boolSV(aiv < biv));
1426 if (auvok && buvok) { /* ## UV < UV ## */
1427 UV auv = SvUVX(TOPm1s);
1428 UV buv = SvUVX(TOPs);
1431 SETs(boolSV(auv < buv));
1434 if (auvok) { /* ## UV < IV ## */
1441 /* As (a) is a UV, it's >=0, so it cannot be < */
1446 if (auv >= (UV) IV_MAX) {
1447 /* As (b) is an IV, it cannot be > IV_MAX */
1451 SETs(boolSV(auv < (UV)biv));
1454 { /* ## IV < UV ## */
1458 aiv = SvIVX(TOPm1s);
1460 /* As (b) is a UV, it's >=0, so it must be < */
1467 if (buv > (UV) IV_MAX) {
1468 /* As (a) is an IV, it cannot be > IV_MAX */
1472 SETs(boolSV((UV)aiv < buv));
1480 SETs(boolSV(TOPn < value));
1487 dSP; tryAMAGICbinSET(gt,0);
1488 #ifdef PERL_PRESERVE_IVUV
1491 SvIV_please(TOPm1s);
1492 if (SvIOK(TOPm1s)) {
1493 bool auvok = SvUOK(TOPm1s);
1494 bool buvok = SvUOK(TOPs);
1496 if (!auvok && !buvok) { /* ## IV > IV ## */
1497 IV aiv = SvIVX(TOPm1s);
1498 IV biv = SvIVX(TOPs);
1501 SETs(boolSV(aiv > biv));
1504 if (auvok && buvok) { /* ## UV > UV ## */
1505 UV auv = SvUVX(TOPm1s);
1506 UV buv = SvUVX(TOPs);
1509 SETs(boolSV(auv > buv));
1512 if (auvok) { /* ## UV > IV ## */
1519 /* As (a) is a UV, it's >=0, so it must be > */
1524 if (auv > (UV) IV_MAX) {
1525 /* As (b) is an IV, it cannot be > IV_MAX */
1529 SETs(boolSV(auv > (UV)biv));
1532 { /* ## IV > UV ## */
1536 aiv = SvIVX(TOPm1s);
1538 /* As (b) is a UV, it's >=0, so it cannot be > */
1545 if (buv >= (UV) IV_MAX) {
1546 /* As (a) is an IV, it cannot be > IV_MAX */
1550 SETs(boolSV((UV)aiv > buv));
1558 SETs(boolSV(TOPn > value));
1565 dSP; tryAMAGICbinSET(le,0);
1566 #ifdef PERL_PRESERVE_IVUV
1569 SvIV_please(TOPm1s);
1570 if (SvIOK(TOPm1s)) {
1571 bool auvok = SvUOK(TOPm1s);
1572 bool buvok = SvUOK(TOPs);
1574 if (!auvok && !buvok) { /* ## IV <= IV ## */
1575 IV aiv = SvIVX(TOPm1s);
1576 IV biv = SvIVX(TOPs);
1579 SETs(boolSV(aiv <= biv));
1582 if (auvok && buvok) { /* ## UV <= UV ## */
1583 UV auv = SvUVX(TOPm1s);
1584 UV buv = SvUVX(TOPs);
1587 SETs(boolSV(auv <= buv));
1590 if (auvok) { /* ## UV <= IV ## */
1597 /* As (a) is a UV, it's >=0, so a cannot be <= */
1602 if (auv > (UV) IV_MAX) {
1603 /* As (b) is an IV, it cannot be > IV_MAX */
1607 SETs(boolSV(auv <= (UV)biv));
1610 { /* ## IV <= UV ## */
1614 aiv = SvIVX(TOPm1s);
1616 /* As (b) is a UV, it's >=0, so a must be <= */
1623 if (buv >= (UV) IV_MAX) {
1624 /* As (a) is an IV, it cannot be > IV_MAX */
1628 SETs(boolSV((UV)aiv <= buv));
1636 SETs(boolSV(TOPn <= value));
1643 dSP; tryAMAGICbinSET(ge,0);
1644 #ifdef PERL_PRESERVE_IVUV
1647 SvIV_please(TOPm1s);
1648 if (SvIOK(TOPm1s)) {
1649 bool auvok = SvUOK(TOPm1s);
1650 bool buvok = SvUOK(TOPs);
1652 if (!auvok && !buvok) { /* ## IV >= IV ## */
1653 IV aiv = SvIVX(TOPm1s);
1654 IV biv = SvIVX(TOPs);
1657 SETs(boolSV(aiv >= biv));
1660 if (auvok && buvok) { /* ## UV >= UV ## */
1661 UV auv = SvUVX(TOPm1s);
1662 UV buv = SvUVX(TOPs);
1665 SETs(boolSV(auv >= buv));
1668 if (auvok) { /* ## UV >= IV ## */
1675 /* As (a) is a UV, it's >=0, so it must be >= */
1680 if (auv >= (UV) IV_MAX) {
1681 /* As (b) is an IV, it cannot be > IV_MAX */
1685 SETs(boolSV(auv >= (UV)biv));
1688 { /* ## IV >= UV ## */
1692 aiv = SvIVX(TOPm1s);
1694 /* As (b) is a UV, it's >=0, so a cannot be >= */
1701 if (buv > (UV) IV_MAX) {
1702 /* As (a) is an IV, it cannot be > IV_MAX */
1706 SETs(boolSV((UV)aiv >= buv));
1714 SETs(boolSV(TOPn >= value));
1721 dSP; tryAMAGICbinSET(ne,0);
1722 #ifndef NV_PRESERVES_UV
1723 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1724 SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
1728 #ifdef PERL_PRESERVE_IVUV
1731 SvIV_please(TOPm1s);
1732 if (SvIOK(TOPm1s)) {
1733 bool auvok = SvUOK(TOPm1s);
1734 bool buvok = SvUOK(TOPs);
1736 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1737 IV aiv = SvIVX(TOPm1s);
1738 IV biv = SvIVX(TOPs);
1741 SETs(boolSV(aiv != biv));
1744 if (auvok && buvok) { /* ## UV != UV ## */
1745 UV auv = SvUVX(TOPm1s);
1746 UV buv = SvUVX(TOPs);
1749 SETs(boolSV(auv != buv));
1752 { /* ## Mixed IV,UV ## */
1756 /* != is commutative so swap if needed (save code) */
1758 /* swap. top of stack (b) is the iv */
1762 /* As (a) is a UV, it's >0, so it cannot be == */
1771 /* As (b) is a UV, it's >0, so it cannot be == */
1775 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1777 /* we know iv is >= 0 */
1778 if (uv > (UV) IV_MAX) {
1782 SETs(boolSV((UV)iv != uv));
1790 SETs(boolSV(TOPn != value));
1797 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1798 #ifndef NV_PRESERVES_UV
1799 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1800 SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
1804 #ifdef PERL_PRESERVE_IVUV
1805 /* Fortunately it seems NaN isn't IOK */
1808 SvIV_please(TOPm1s);
1809 if (SvIOK(TOPm1s)) {
1810 bool leftuvok = SvUOK(TOPm1s);
1811 bool rightuvok = SvUOK(TOPs);
1813 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1814 IV leftiv = SvIVX(TOPm1s);
1815 IV rightiv = SvIVX(TOPs);
1817 if (leftiv > rightiv)
1819 else if (leftiv < rightiv)
1823 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1824 UV leftuv = SvUVX(TOPm1s);
1825 UV rightuv = SvUVX(TOPs);
1827 if (leftuv > rightuv)
1829 else if (leftuv < rightuv)
1833 } else if (leftuvok) { /* ## UV <=> IV ## */
1837 rightiv = SvIVX(TOPs);
1839 /* As (a) is a UV, it's >=0, so it cannot be < */
1842 leftuv = SvUVX(TOPm1s);
1843 if (leftuv > (UV) IV_MAX) {
1844 /* As (b) is an IV, it cannot be > IV_MAX */
1846 } else if (leftuv > (UV)rightiv) {
1848 } else if (leftuv < (UV)rightiv) {
1854 } else { /* ## IV <=> UV ## */
1858 leftiv = SvIVX(TOPm1s);
1860 /* As (b) is a UV, it's >=0, so it must be < */
1863 rightuv = SvUVX(TOPs);
1864 if (rightuv > (UV) IV_MAX) {
1865 /* As (a) is an IV, it cannot be > IV_MAX */
1867 } else if (leftiv > (UV)rightuv) {
1869 } else if (leftiv < (UV)rightuv) {
1887 if (Perl_isnan(left) || Perl_isnan(right)) {
1891 value = (left > right) - (left < right);
1895 else if (left < right)
1897 else if (left > right)
1911 dSP; tryAMAGICbinSET(slt,0);
1914 int cmp = ((PL_op->op_private & OPpLOCALE)
1915 ? sv_cmp_locale(left, right)
1916 : sv_cmp(left, right));
1917 SETs(boolSV(cmp < 0));
1924 dSP; tryAMAGICbinSET(sgt,0);
1927 int cmp = ((PL_op->op_private & OPpLOCALE)
1928 ? sv_cmp_locale(left, right)
1929 : sv_cmp(left, right));
1930 SETs(boolSV(cmp > 0));
1937 dSP; tryAMAGICbinSET(sle,0);
1940 int cmp = ((PL_op->op_private & OPpLOCALE)
1941 ? sv_cmp_locale(left, right)
1942 : sv_cmp(left, right));
1943 SETs(boolSV(cmp <= 0));
1950 dSP; tryAMAGICbinSET(sge,0);
1953 int cmp = ((PL_op->op_private & OPpLOCALE)
1954 ? sv_cmp_locale(left, right)
1955 : sv_cmp(left, right));
1956 SETs(boolSV(cmp >= 0));
1963 dSP; tryAMAGICbinSET(seq,0);
1966 SETs(boolSV(sv_eq(left, right)));
1973 dSP; tryAMAGICbinSET(sne,0);
1976 SETs(boolSV(!sv_eq(left, right)));
1983 dSP; dTARGET; tryAMAGICbin(scmp,0);
1986 int cmp = ((PL_op->op_private & OPpLOCALE)
1987 ? sv_cmp_locale(left, right)
1988 : sv_cmp(left, right));
1996 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1999 if (SvNIOKp(left) || SvNIOKp(right)) {
2000 if (PL_op->op_private & HINT_INTEGER) {
2001 IV i = SvIV(left) & SvIV(right);
2005 UV u = SvUV(left) & SvUV(right);
2010 do_vop(PL_op->op_type, TARG, left, right);
2019 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2022 if (SvNIOKp(left) || SvNIOKp(right)) {
2023 if (PL_op->op_private & HINT_INTEGER) {
2024 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2028 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2033 do_vop(PL_op->op_type, TARG, left, right);
2042 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2045 if (SvNIOKp(left) || SvNIOKp(right)) {
2046 if (PL_op->op_private & HINT_INTEGER) {
2047 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2051 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2056 do_vop(PL_op->op_type, TARG, left, right);
2065 dSP; dTARGET; tryAMAGICun(neg);
2068 int flags = SvFLAGS(sv);
2071 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2072 /* It's publicly an integer, or privately an integer-not-float */
2075 if (SvIVX(sv) == IV_MIN) {
2076 /* 2s complement assumption. */
2077 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2080 else if (SvUVX(sv) <= IV_MAX) {
2085 else if (SvIVX(sv) != IV_MIN) {
2089 #ifdef PERL_PRESERVE_IVUV
2098 else if (SvPOKp(sv)) {
2100 char *s = SvPV(sv, len);
2101 if (isIDFIRST(*s)) {
2102 sv_setpvn(TARG, "-", 1);
2105 else if (*s == '+' || *s == '-') {
2107 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2109 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2110 sv_setpvn(TARG, "-", 1);
2116 goto oops_its_an_int;
2117 sv_setnv(TARG, -SvNV(sv));
2129 dSP; tryAMAGICunSET(not);
2130 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2136 dSP; dTARGET; tryAMAGICun(compl);
2140 if (PL_op->op_private & HINT_INTEGER) {
2155 tmps = (U8*)SvPV_force(TARG, len);
2158 /* Calculate exact length, let's not estimate. */
2167 while (tmps < send) {
2168 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2169 tmps += UTF8SKIP(tmps);
2170 targlen += UNISKIP(~c);
2176 /* Now rewind strings and write them. */
2180 Newz(0, result, targlen + 1, U8);
2181 while (tmps < send) {
2182 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2183 tmps += UTF8SKIP(tmps);
2184 result = uvchr_to_utf8(result, ~c);
2188 sv_setpvn(TARG, (char*)result, targlen);
2192 Newz(0, result, nchar + 1, U8);
2193 while (tmps < send) {
2194 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2195 tmps += UTF8SKIP(tmps);
2200 sv_setpvn(TARG, (char*)result, nchar);
2208 register long *tmpl;
2209 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2212 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2217 for ( ; anum > 0; anum--, tmps++)
2226 /* integer versions of some of the above */
2230 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2233 SETi( left * right );
2240 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2244 DIE(aTHX_ "Illegal division by zero");
2245 value = POPi / value;
2253 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2257 DIE(aTHX_ "Illegal modulus zero");
2258 SETi( left % right );
2265 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2268 SETi( left + right );
2275 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2278 SETi( left - right );
2285 dSP; tryAMAGICbinSET(lt,0);
2288 SETs(boolSV(left < right));
2295 dSP; tryAMAGICbinSET(gt,0);
2298 SETs(boolSV(left > right));
2305 dSP; tryAMAGICbinSET(le,0);
2308 SETs(boolSV(left <= right));
2315 dSP; tryAMAGICbinSET(ge,0);
2318 SETs(boolSV(left >= right));
2325 dSP; tryAMAGICbinSET(eq,0);
2328 SETs(boolSV(left == right));
2335 dSP; tryAMAGICbinSET(ne,0);
2338 SETs(boolSV(left != right));
2345 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2352 else if (left < right)
2363 dSP; dTARGET; tryAMAGICun(neg);
2368 /* High falutin' math. */
2372 dSP; dTARGET; tryAMAGICbin(atan2,0);
2375 SETn(Perl_atan2(left, right));
2382 dSP; dTARGET; tryAMAGICun(sin);
2386 value = Perl_sin(value);
2394 dSP; dTARGET; tryAMAGICun(cos);
2398 value = Perl_cos(value);
2404 /* Support Configure command-line overrides for rand() functions.
2405 After 5.005, perhaps we should replace this by Configure support
2406 for drand48(), random(), or rand(). For 5.005, though, maintain
2407 compatibility by calling rand() but allow the user to override it.
2408 See INSTALL for details. --Andy Dougherty 15 July 1998
2410 /* Now it's after 5.005, and Configure supports drand48() and random(),
2411 in addition to rand(). So the overrides should not be needed any more.
2412 --Jarkko Hietaniemi 27 September 1998
2415 #ifndef HAS_DRAND48_PROTO
2416 extern double drand48 (void);
2429 if (!PL_srand_called) {
2430 (void)seedDrand01((Rand_seed_t)seed());
2431 PL_srand_called = TRUE;
2446 (void)seedDrand01((Rand_seed_t)anum);
2447 PL_srand_called = TRUE;
2456 * This is really just a quick hack which grabs various garbage
2457 * values. It really should be a real hash algorithm which
2458 * spreads the effect of every input bit onto every output bit,
2459 * if someone who knows about such things would bother to write it.
2460 * Might be a good idea to add that function to CORE as well.
2461 * No numbers below come from careful analysis or anything here,
2462 * except they are primes and SEED_C1 > 1E6 to get a full-width
2463 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2464 * probably be bigger too.
2467 # define SEED_C1 1000003
2468 #define SEED_C4 73819
2470 # define SEED_C1 25747
2471 #define SEED_C4 20639
2475 #define SEED_C5 26107
2477 #ifndef PERL_NO_DEV_RANDOM
2482 # include <starlet.h>
2483 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2484 * in 100-ns units, typically incremented ever 10 ms. */
2485 unsigned int when[2];
2487 # ifdef HAS_GETTIMEOFDAY
2488 struct timeval when;
2494 /* This test is an escape hatch, this symbol isn't set by Configure. */
2495 #ifndef PERL_NO_DEV_RANDOM
2496 #ifndef PERL_RANDOM_DEVICE
2497 /* /dev/random isn't used by default because reads from it will block
2498 * if there isn't enough entropy available. You can compile with
2499 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2500 * is enough real entropy to fill the seed. */
2501 # define PERL_RANDOM_DEVICE "/dev/urandom"
2503 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2505 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2514 _ckvmssts(sys$gettim(when));
2515 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2517 # ifdef HAS_GETTIMEOFDAY
2518 gettimeofday(&when,(struct timezone *) 0);
2519 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2522 u = (U32)SEED_C1 * when;
2525 u += SEED_C3 * (U32)PerlProc_getpid();
2526 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2527 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2528 u += SEED_C5 * (U32)PTR2UV(&when);
2535 dSP; dTARGET; tryAMAGICun(exp);
2539 value = Perl_exp(value);
2547 dSP; dTARGET; tryAMAGICun(log);
2552 SET_NUMERIC_STANDARD();
2553 DIE(aTHX_ "Can't take log of %g", value);
2555 value = Perl_log(value);
2563 dSP; dTARGET; tryAMAGICun(sqrt);
2568 SET_NUMERIC_STANDARD();
2569 DIE(aTHX_ "Can't take sqrt of %g", value);
2571 value = Perl_sqrt(value);
2579 dSP; dTARGET; tryAMAGICun(int);
2582 IV iv = TOPi; /* attempt to convert to IV if possible. */
2583 /* XXX it's arguable that compiler casting to IV might be subtly
2584 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2585 else preferring IV has introduced a subtle behaviour change bug. OTOH
2586 relying on floating point to be accurate is a bug. */
2597 if (value < (NV)UV_MAX + 0.5) {
2600 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2601 (void)Perl_modf(value, &value);
2603 double tmp = (double)value;
2604 (void)Perl_modf(tmp, &tmp);
2611 if (value > (NV)IV_MIN - 0.5) {
2614 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2615 (void)Perl_modf(-value, &value);
2618 double tmp = (double)value;
2619 (void)Perl_modf(-tmp, &tmp);
2632 dSP; dTARGET; tryAMAGICun(abs);
2634 /* This will cache the NV value if string isn't actually integer */
2638 /* IVX is precise */
2640 SETu(TOPu); /* force it to be numeric only */
2648 /* 2s complement assumption. Also, not really needed as
2649 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2671 tmps = (SvPVx(POPs, len));
2672 argtype = 1; /* allow underscores */
2673 XPUSHn(scan_hex(tmps, len, &argtype));
2685 tmps = (SvPVx(POPs, len));
2686 while (*tmps && len && isSPACE(*tmps))
2690 argtype = 1; /* allow underscores */
2692 value = scan_hex(++tmps, --len, &argtype);
2693 else if (*tmps == 'b')
2694 value = scan_bin(++tmps, --len, &argtype);
2696 value = scan_oct(tmps, len, &argtype);
2709 SETi(sv_len_utf8(sv));
2725 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2727 I32 arybase = PL_curcop->cop_arybase;
2731 int num_args = PL_op->op_private & 7;
2732 bool repl_need_utf8_upgrade = FALSE;
2733 bool repl_is_utf8 = FALSE;
2735 SvTAINTED_off(TARG); /* decontaminate */
2736 SvUTF8_off(TARG); /* decontaminate */
2740 repl = SvPV(repl_sv, repl_len);
2741 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2751 sv_utf8_upgrade(sv);
2753 else if (DO_UTF8(sv))
2754 repl_need_utf8_upgrade = TRUE;
2756 tmps = SvPV(sv, curlen);
2758 utf8_curlen = sv_len_utf8(sv);
2759 if (utf8_curlen == curlen)
2762 curlen = utf8_curlen;
2767 if (pos >= arybase) {
2785 else if (len >= 0) {
2787 if (rem > (I32)curlen)
2802 Perl_croak(aTHX_ "substr outside of string");
2803 if (ckWARN(WARN_SUBSTR))
2804 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2811 sv_pos_u2b(sv, &pos, &rem);
2813 sv_setpvn(TARG, tmps, rem);
2814 #ifdef USE_LOCALE_COLLATE
2815 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
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, PERL_MAGIC_substr, 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, PERL_MAGIC_vec, 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, PERL_MAGIC_tied))) {
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, PERL_MAGIC_tied))) {
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, PERL_MAGIC_tied))) {
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, PERL_MAGIC_tied))) {
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, PERL_MAGIC_mutex);
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 */