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. */
1268 register UV auv = 0;
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 = (IN_LOCALE_RUNTIME
1915 ? sv_cmp_locale(left, right)
1916 : sv_cmp(left, right));
1917 SETs(boolSV(cmp < 0));
1924 dSP; tryAMAGICbinSET(sgt,0);
1927 int cmp = (IN_LOCALE_RUNTIME
1928 ? sv_cmp_locale(left, right)
1929 : sv_cmp(left, right));
1930 SETs(boolSV(cmp > 0));
1937 dSP; tryAMAGICbinSET(sle,0);
1940 int cmp = (IN_LOCALE_RUNTIME
1941 ? sv_cmp_locale(left, right)
1942 : sv_cmp(left, right));
1943 SETs(boolSV(cmp <= 0));
1950 dSP; tryAMAGICbinSET(sge,0);
1953 int cmp = (IN_LOCALE_RUNTIME
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 = (IN_LOCALE_RUNTIME
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 # ifdef HAS_MODFL_POW32_BUG
2602 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2604 NV offset = Perl_modf(value, &value);
2605 (void)Perl_modf(offset, &offset);
2609 (void)Perl_modf(value, &value);
2612 double tmp = (double)value;
2613 (void)Perl_modf(tmp, &tmp);
2620 if (value > (NV)IV_MIN - 0.5) {
2623 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2624 # ifdef HAS_MODFL_POW32_BUG
2625 /* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2627 NV offset = Perl_modf(-value, &value);
2628 (void)Perl_modf(offset, &offset);
2632 (void)Perl_modf(-value, &value);
2636 double tmp = (double)value;
2637 (void)Perl_modf(-tmp, &tmp);
2650 dSP; dTARGET; tryAMAGICun(abs);
2652 /* This will cache the NV value if string isn't actually integer */
2656 /* IVX is precise */
2658 SETu(TOPu); /* force it to be numeric only */
2666 /* 2s complement assumption. Also, not really needed as
2667 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2689 tmps = (SvPVx(POPs, len));
2690 argtype = 1; /* allow underscores */
2691 XPUSHn(scan_hex(tmps, len, &argtype));
2703 tmps = (SvPVx(POPs, len));
2704 while (*tmps && len && isSPACE(*tmps))
2708 argtype = 1; /* allow underscores */
2710 value = scan_hex(++tmps, --len, &argtype);
2711 else if (*tmps == 'b')
2712 value = scan_bin(++tmps, --len, &argtype);
2714 value = scan_oct(tmps, len, &argtype);
2727 SETi(sv_len_utf8(sv));
2743 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2745 I32 arybase = PL_curcop->cop_arybase;
2749 int num_args = PL_op->op_private & 7;
2750 bool repl_need_utf8_upgrade = FALSE;
2751 bool repl_is_utf8 = FALSE;
2753 SvTAINTED_off(TARG); /* decontaminate */
2754 SvUTF8_off(TARG); /* decontaminate */
2758 repl = SvPV(repl_sv, repl_len);
2759 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2769 sv_utf8_upgrade(sv);
2771 else if (DO_UTF8(sv))
2772 repl_need_utf8_upgrade = TRUE;
2774 tmps = SvPV(sv, curlen);
2776 utf8_curlen = sv_len_utf8(sv);
2777 if (utf8_curlen == curlen)
2780 curlen = utf8_curlen;
2785 if (pos >= arybase) {
2803 else if (len >= 0) {
2805 if (rem > (I32)curlen)
2820 Perl_croak(aTHX_ "substr outside of string");
2821 if (ckWARN(WARN_SUBSTR))
2822 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2829 sv_pos_u2b(sv, &pos, &rem);
2831 sv_setpvn(TARG, tmps, rem);
2832 #ifdef USE_LOCALE_COLLATE
2833 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
2838 SV* repl_sv_copy = NULL;
2840 if (repl_need_utf8_upgrade) {
2841 repl_sv_copy = newSVsv(repl_sv);
2842 sv_utf8_upgrade(repl_sv_copy);
2843 repl = SvPV(repl_sv_copy, repl_len);
2844 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2846 sv_insert(sv, pos, rem, repl, repl_len);
2850 SvREFCNT_dec(repl_sv_copy);
2852 else if (lvalue) { /* it's an lvalue! */
2853 if (!SvGMAGICAL(sv)) {
2857 if (ckWARN(WARN_SUBSTR))
2858 Perl_warner(aTHX_ WARN_SUBSTR,
2859 "Attempt to use reference as lvalue in substr");
2861 if (SvOK(sv)) /* is it defined ? */
2862 (void)SvPOK_only_UTF8(sv);
2864 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2867 if (SvTYPE(TARG) < SVt_PVLV) {
2868 sv_upgrade(TARG, SVt_PVLV);
2869 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
2873 if (LvTARG(TARG) != sv) {
2875 SvREFCNT_dec(LvTARG(TARG));
2876 LvTARG(TARG) = SvREFCNT_inc(sv);
2878 LvTARGOFF(TARG) = upos;
2879 LvTARGLEN(TARG) = urem;
2883 PUSHs(TARG); /* avoid SvSETMAGIC here */
2890 register IV size = POPi;
2891 register IV offset = POPi;
2892 register SV *src = POPs;
2893 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2895 SvTAINTED_off(TARG); /* decontaminate */
2896 if (lvalue) { /* it's an lvalue! */
2897 if (SvTYPE(TARG) < SVt_PVLV) {
2898 sv_upgrade(TARG, SVt_PVLV);
2899 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
2902 if (LvTARG(TARG) != src) {
2904 SvREFCNT_dec(LvTARG(TARG));
2905 LvTARG(TARG) = SvREFCNT_inc(src);
2907 LvTARGOFF(TARG) = offset;
2908 LvTARGLEN(TARG) = size;
2911 sv_setuv(TARG, do_vecget(src, offset, size));
2926 I32 arybase = PL_curcop->cop_arybase;
2931 offset = POPi - arybase;
2934 tmps = SvPV(big, biglen);
2935 if (offset > 0 && DO_UTF8(big))
2936 sv_pos_u2b(big, &offset, 0);
2939 else if (offset > biglen)
2941 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2942 (unsigned char*)tmps + biglen, little, 0)))
2945 retval = tmps2 - tmps;
2946 if (retval > 0 && DO_UTF8(big))
2947 sv_pos_b2u(big, &retval);
2948 PUSHi(retval + arybase);
2963 I32 arybase = PL_curcop->cop_arybase;
2969 tmps2 = SvPV(little, llen);
2970 tmps = SvPV(big, blen);
2974 if (offset > 0 && DO_UTF8(big))
2975 sv_pos_u2b(big, &offset, 0);
2976 offset = offset - arybase + llen;
2980 else if (offset > blen)
2982 if (!(tmps2 = rninstr(tmps, tmps + offset,
2983 tmps2, tmps2 + llen)))
2986 retval = tmps2 - tmps;
2987 if (retval > 0 && DO_UTF8(big))
2988 sv_pos_b2u(big, &retval);
2989 PUSHi(retval + arybase);
2995 dSP; dMARK; dORIGMARK; dTARGET;
2996 do_sprintf(TARG, SP-MARK, MARK+1);
2997 TAINT_IF(SvTAINTED(TARG));
3008 U8 *s = (U8*)SvPVx(argsv, len);
3010 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
3020 (void)SvUPGRADE(TARG,SVt_PV);
3022 if (value > 255 && !IN_BYTES) {
3023 SvGROW(TARG, UNISKIP(value)+1);
3024 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
3025 SvCUR_set(TARG, tmps - SvPVX(TARG));
3027 (void)SvPOK_only(TARG);
3038 (void)SvPOK_only(TARG);
3045 dSP; dTARGET; dPOPTOPssrl;
3048 char *tmps = SvPV(left, n_a);
3050 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3052 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3056 "The crypt() function is unimplemented due to excessive paranoia.");
3069 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3071 U8 tmpbuf[UTF8_MAXLEN+1];
3075 if (IN_LOCALE_RUNTIME) {
3078 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3081 uv = toTITLE_utf8(s);
3083 tend = uvchr_to_utf8(tmpbuf, uv);
3085 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3087 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3088 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3093 s = (U8*)SvPV_force(sv, slen);
3094 Copy(tmpbuf, s, ulen, U8);
3098 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3100 SvUTF8_off(TARG); /* decontaminate */
3105 s = (U8*)SvPV_force(sv, slen);
3107 if (IN_LOCALE_RUNTIME) {
3110 *s = toUPPER_LC(*s);
3128 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3130 U8 tmpbuf[UTF8_MAXLEN+1];
3134 if (IN_LOCALE_RUNTIME) {
3137 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3140 uv = toLOWER_utf8(s);
3142 tend = uvchr_to_utf8(tmpbuf, uv);
3144 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3146 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3147 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3152 s = (U8*)SvPV_force(sv, slen);
3153 Copy(tmpbuf, s, ulen, U8);
3157 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3159 SvUTF8_off(TARG); /* decontaminate */
3164 s = (U8*)SvPV_force(sv, slen);
3166 if (IN_LOCALE_RUNTIME) {
3169 *s = toLOWER_LC(*s);
3193 s = (U8*)SvPV(sv,len);
3195 SvUTF8_off(TARG); /* decontaminate */
3196 sv_setpvn(TARG, "", 0);
3200 (void)SvUPGRADE(TARG, SVt_PV);
3201 SvGROW(TARG, (len * 2) + 1);
3202 (void)SvPOK_only(TARG);
3203 d = (U8*)SvPVX(TARG);
3205 if (IN_LOCALE_RUNTIME) {
3209 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3215 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3221 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3226 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3228 SvUTF8_off(TARG); /* decontaminate */
3233 s = (U8*)SvPV_force(sv, len);
3235 register U8 *send = s + len;
3237 if (IN_LOCALE_RUNTIME) {
3240 for (; s < send; s++)
3241 *s = toUPPER_LC(*s);
3244 for (; s < send; s++)
3267 s = (U8*)SvPV(sv,len);
3269 SvUTF8_off(TARG); /* decontaminate */
3270 sv_setpvn(TARG, "", 0);
3274 (void)SvUPGRADE(TARG, SVt_PV);
3275 SvGROW(TARG, (len * 2) + 1);
3276 (void)SvPOK_only(TARG);
3277 d = (U8*)SvPVX(TARG);
3279 if (IN_LOCALE_RUNTIME) {
3283 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3289 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3295 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3300 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3302 SvUTF8_off(TARG); /* decontaminate */
3308 s = (U8*)SvPV_force(sv, len);
3310 register U8 *send = s + len;
3312 if (IN_LOCALE_RUNTIME) {
3315 for (; s < send; s++)
3316 *s = toLOWER_LC(*s);
3319 for (; s < send; s++)
3334 register char *s = SvPV(sv,len);
3337 SvUTF8_off(TARG); /* decontaminate */
3339 (void)SvUPGRADE(TARG, SVt_PV);
3340 SvGROW(TARG, (len * 2) + 1);
3344 if (UTF8_IS_CONTINUED(*s)) {
3345 STRLEN ulen = UTF8SKIP(s);
3369 SvCUR_set(TARG, d - SvPVX(TARG));
3370 (void)SvPOK_only_UTF8(TARG);
3373 sv_setpvn(TARG, s, len);
3375 if (SvSMAGICAL(TARG))
3384 dSP; dMARK; dORIGMARK;
3386 register AV* av = (AV*)POPs;
3387 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3388 I32 arybase = PL_curcop->cop_arybase;
3391 if (SvTYPE(av) == SVt_PVAV) {
3392 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3394 for (svp = MARK + 1; svp <= SP; svp++) {
3399 if (max > AvMAX(av))
3402 while (++MARK <= SP) {
3403 elem = SvIVx(*MARK);
3407 svp = av_fetch(av, elem, lval);
3409 if (!svp || *svp == &PL_sv_undef)
3410 DIE(aTHX_ PL_no_aelem, elem);
3411 if (PL_op->op_private & OPpLVAL_INTRO)
3412 save_aelem(av, elem, svp);
3414 *MARK = svp ? *svp : &PL_sv_undef;
3417 if (GIMME != G_ARRAY) {
3425 /* Associative arrays. */
3430 HV *hash = (HV*)POPs;
3432 I32 gimme = GIMME_V;
3433 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3436 /* might clobber stack_sp */
3437 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3442 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3443 if (gimme == G_ARRAY) {
3446 /* might clobber stack_sp */
3448 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3453 else if (gimme == G_SCALAR)
3472 I32 gimme = GIMME_V;
3473 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3477 if (PL_op->op_private & OPpSLICE) {
3481 hvtype = SvTYPE(hv);
3482 if (hvtype == SVt_PVHV) { /* hash element */
3483 while (++MARK <= SP) {
3484 sv = hv_delete_ent(hv, *MARK, discard, 0);
3485 *MARK = sv ? sv : &PL_sv_undef;
3488 else if (hvtype == SVt_PVAV) {
3489 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3490 while (++MARK <= SP) {
3491 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3492 *MARK = sv ? sv : &PL_sv_undef;
3495 else { /* pseudo-hash element */
3496 while (++MARK <= SP) {
3497 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3498 *MARK = sv ? sv : &PL_sv_undef;
3503 DIE(aTHX_ "Not a HASH reference");
3506 else if (gimme == G_SCALAR) {
3515 if (SvTYPE(hv) == SVt_PVHV)
3516 sv = hv_delete_ent(hv, keysv, discard, 0);
3517 else if (SvTYPE(hv) == SVt_PVAV) {
3518 if (PL_op->op_flags & OPf_SPECIAL)
3519 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3521 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3524 DIE(aTHX_ "Not a HASH reference");
3539 if (PL_op->op_private & OPpEXISTS_SUB) {
3543 cv = sv_2cv(sv, &hv, &gv, FALSE);
3546 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3552 if (SvTYPE(hv) == SVt_PVHV) {
3553 if (hv_exists_ent(hv, tmpsv, 0))
3556 else if (SvTYPE(hv) == SVt_PVAV) {
3557 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3558 if (av_exists((AV*)hv, SvIV(tmpsv)))
3561 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3565 DIE(aTHX_ "Not a HASH reference");
3572 dSP; dMARK; dORIGMARK;
3573 register HV *hv = (HV*)POPs;
3574 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3575 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3577 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3578 DIE(aTHX_ "Can't localize pseudo-hash element");
3580 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3581 while (++MARK <= SP) {
3584 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3585 realhv ? hv_exists_ent(hv, keysv, 0)
3586 : avhv_exists_ent((AV*)hv, keysv, 0);
3588 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3589 svp = he ? &HeVAL(he) : 0;
3592 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3595 if (!svp || *svp == &PL_sv_undef) {
3597 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3599 if (PL_op->op_private & OPpLVAL_INTRO) {
3601 save_helem(hv, keysv, svp);
3604 char *key = SvPV(keysv, keylen);
3605 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3609 *MARK = svp ? *svp : &PL_sv_undef;
3612 if (GIMME != G_ARRAY) {
3620 /* List operators. */
3625 if (GIMME != G_ARRAY) {
3627 *MARK = *SP; /* unwanted list, return last item */
3629 *MARK = &PL_sv_undef;
3638 SV **lastrelem = PL_stack_sp;
3639 SV **lastlelem = PL_stack_base + POPMARK;
3640 SV **firstlelem = PL_stack_base + POPMARK + 1;
3641 register SV **firstrelem = lastlelem + 1;
3642 I32 arybase = PL_curcop->cop_arybase;
3643 I32 lval = PL_op->op_flags & OPf_MOD;
3644 I32 is_something_there = lval;
3646 register I32 max = lastrelem - lastlelem;
3647 register SV **lelem;
3650 if (GIMME != G_ARRAY) {
3651 ix = SvIVx(*lastlelem);
3656 if (ix < 0 || ix >= max)
3657 *firstlelem = &PL_sv_undef;
3659 *firstlelem = firstrelem[ix];
3665 SP = firstlelem - 1;
3669 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3675 if (ix < 0 || ix >= max)
3676 *lelem = &PL_sv_undef;
3678 is_something_there = TRUE;
3679 if (!(*lelem = firstrelem[ix]))
3680 *lelem = &PL_sv_undef;
3683 if (is_something_there)
3686 SP = firstlelem - 1;
3692 dSP; dMARK; dORIGMARK;
3693 I32 items = SP - MARK;
3694 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3695 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3702 dSP; dMARK; dORIGMARK;
3703 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3707 SV *val = NEWSV(46, 0);
3709 sv_setsv(val, *++MARK);
3710 else if (ckWARN(WARN_MISC))
3711 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3712 (void)hv_store_ent(hv,key,val,0);
3721 dSP; dMARK; dORIGMARK;
3722 register AV *ary = (AV*)*++MARK;
3726 register I32 offset;
3727 register I32 length;
3734 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3735 *MARK-- = SvTIED_obj((SV*)ary, mg);
3739 call_method("SPLICE",GIMME_V);
3748 offset = i = SvIVx(*MARK);
3750 offset += AvFILLp(ary) + 1;
3752 offset -= PL_curcop->cop_arybase;
3754 DIE(aTHX_ PL_no_aelem, i);
3756 length = SvIVx(*MARK++);
3758 length += AvFILLp(ary) - offset + 1;
3764 length = AvMAX(ary) + 1; /* close enough to infinity */
3768 length = AvMAX(ary) + 1;
3770 if (offset > AvFILLp(ary) + 1)
3771 offset = AvFILLp(ary) + 1;
3772 after = AvFILLp(ary) + 1 - (offset + length);
3773 if (after < 0) { /* not that much array */
3774 length += after; /* offset+length now in array */
3780 /* At this point, MARK .. SP-1 is our new LIST */
3783 diff = newlen - length;
3784 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3787 if (diff < 0) { /* shrinking the area */
3789 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3790 Copy(MARK, tmparyval, newlen, SV*);
3793 MARK = ORIGMARK + 1;
3794 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3795 MEXTEND(MARK, length);
3796 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3798 EXTEND_MORTAL(length);
3799 for (i = length, dst = MARK; i; i--) {
3800 sv_2mortal(*dst); /* free them eventualy */
3807 *MARK = AvARRAY(ary)[offset+length-1];
3810 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3811 SvREFCNT_dec(*dst++); /* free them now */
3814 AvFILLp(ary) += diff;
3816 /* pull up or down? */
3818 if (offset < after) { /* easier to pull up */
3819 if (offset) { /* esp. if nothing to pull */
3820 src = &AvARRAY(ary)[offset-1];
3821 dst = src - diff; /* diff is negative */
3822 for (i = offset; i > 0; i--) /* can't trust Copy */
3826 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3830 if (after) { /* anything to pull down? */
3831 src = AvARRAY(ary) + offset + length;
3832 dst = src + diff; /* diff is negative */
3833 Move(src, dst, after, SV*);
3835 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3836 /* avoid later double free */
3840 dst[--i] = &PL_sv_undef;
3843 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3845 *dst = NEWSV(46, 0);
3846 sv_setsv(*dst++, *src++);
3848 Safefree(tmparyval);
3851 else { /* no, expanding (or same) */
3853 New(452, tmparyval, length, SV*); /* so remember deletion */
3854 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3857 if (diff > 0) { /* expanding */
3859 /* push up or down? */
3861 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3865 Move(src, dst, offset, SV*);
3867 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3869 AvFILLp(ary) += diff;
3872 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3873 av_extend(ary, AvFILLp(ary) + diff);
3874 AvFILLp(ary) += diff;
3877 dst = AvARRAY(ary) + AvFILLp(ary);
3879 for (i = after; i; i--) {
3886 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3887 *dst = NEWSV(46, 0);
3888 sv_setsv(*dst++, *src++);
3890 MARK = ORIGMARK + 1;
3891 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3893 Copy(tmparyval, MARK, length, SV*);
3895 EXTEND_MORTAL(length);
3896 for (i = length, dst = MARK; i; i--) {
3897 sv_2mortal(*dst); /* free them eventualy */
3901 Safefree(tmparyval);
3905 else if (length--) {
3906 *MARK = tmparyval[length];
3909 while (length-- > 0)
3910 SvREFCNT_dec(tmparyval[length]);
3912 Safefree(tmparyval);
3915 *MARK = &PL_sv_undef;
3923 dSP; dMARK; dORIGMARK; dTARGET;
3924 register AV *ary = (AV*)*++MARK;
3925 register SV *sv = &PL_sv_undef;
3928 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3929 *MARK-- = SvTIED_obj((SV*)ary, mg);
3933 call_method("PUSH",G_SCALAR|G_DISCARD);
3938 /* Why no pre-extend of ary here ? */
3939 for (++MARK; MARK <= SP; MARK++) {
3942 sv_setsv(sv, *MARK);
3947 PUSHi( AvFILL(ary) + 1 );
3955 SV *sv = av_pop(av);
3957 (void)sv_2mortal(sv);
3966 SV *sv = av_shift(av);
3971 (void)sv_2mortal(sv);
3978 dSP; dMARK; dORIGMARK; dTARGET;
3979 register AV *ary = (AV*)*++MARK;
3984 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
3985 *MARK-- = SvTIED_obj((SV*)ary, mg);
3989 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3994 av_unshift(ary, SP - MARK);
3997 sv_setsv(sv, *++MARK);
3998 (void)av_store(ary, i++, sv);
4002 PUSHi( AvFILL(ary) + 1 );
4012 if (GIMME == G_ARRAY) {
4019 /* safe as long as stack cannot get extended in the above */
4024 register char *down;
4029 SvUTF8_off(TARG); /* decontaminate */
4031 do_join(TARG, &PL_sv_no, MARK, SP);
4033 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4034 up = SvPV_force(TARG, len);
4036 if (DO_UTF8(TARG)) { /* first reverse each character */
4037 U8* s = (U8*)SvPVX(TARG);
4038 U8* send = (U8*)(s + len);
4040 if (UTF8_IS_INVARIANT(*s)) {
4045 if (!utf8_to_uvchr(s, 0))
4049 down = (char*)(s - 1);
4050 /* reverse this character */
4060 down = SvPVX(TARG) + len - 1;
4066 (void)SvPOK_only_UTF8(TARG);
4075 S_mul128(pTHX_ SV *sv, U8 m)
4078 char *s = SvPV(sv, len);
4082 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4083 SV *tmpNew = newSVpvn("0000000000", 10);
4085 sv_catsv(tmpNew, sv);
4086 SvREFCNT_dec(sv); /* free old sv */
4091 while (!*t) /* trailing '\0'? */
4094 i = ((*t - '0') << 7) + m;
4095 *(t--) = '0' + (i % 10);
4101 /* Explosives and implosives. */
4103 #if 'I' == 73 && 'J' == 74
4104 /* On an ASCII/ISO kind of system */
4105 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4108 Some other sort of character set - use memchr() so we don't match
4111 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4119 I32 start_sp_offset = SP - PL_stack_base;
4120 I32 gimme = GIMME_V;
4124 register char *pat = SvPV(left, llen);
4125 #ifdef PACKED_IS_OCTETS
4126 /* Packed side is assumed to be octets - so force downgrade if it
4127 has been UTF-8 encoded by accident
4129 register char *s = SvPVbyte(right, rlen);
4131 register char *s = SvPV(right, rlen);
4133 char *strend = s + rlen;
4135 register char *patend = pat + llen;
4138 register I32 bits = 0;
4141 /* These must not be in registers: */
4158 register U32 culong = 0;
4162 #ifdef PERL_NATINT_PACK
4163 int natint; /* native integer */
4164 int unatint; /* unsigned native integer */
4167 if (gimme != G_ARRAY) { /* arrange to do first one only */
4169 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4170 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4172 while (isDIGIT(*patend) || *patend == '*')
4178 while (pat < patend) {
4180 datumtype = *pat++ & 0xFF;
4181 #ifdef PERL_NATINT_PACK
4184 if (isSPACE(datumtype))
4186 if (datumtype == '#') {
4187 while (pat < patend && *pat != '\n')
4192 char *natstr = "sSiIlL";
4194 if (strchr(natstr, datumtype)) {
4195 #ifdef PERL_NATINT_PACK
4201 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4206 else if (*pat == '*') {
4207 len = strend - strbeg; /* long enough */
4211 else if (isDIGIT(*pat)) {
4213 while (isDIGIT(*pat)) {
4214 len = (len * 10) + (*pat++ - '0');
4216 DIE(aTHX_ "Repeat count in unpack overflows");
4220 len = (datumtype != '@');
4224 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4225 case ',': /* grandfather in commas but with a warning */
4226 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4227 Perl_warner(aTHX_ WARN_UNPACK,
4228 "Invalid type in unpack: '%c'", (int)datumtype);
4231 if (len == 1 && pat[-1] != '1')
4240 if (len > strend - strbeg)
4241 DIE(aTHX_ "@ outside of string");
4245 if (len > s - strbeg)
4246 DIE(aTHX_ "X outside of string");
4250 if (len > strend - s)
4251 DIE(aTHX_ "x outside of string");
4255 if (start_sp_offset >= SP - PL_stack_base)
4256 DIE(aTHX_ "/ must follow a numeric type");
4259 pat++; /* ignore '*' for compatibility with pack */
4261 DIE(aTHX_ "/ cannot take a count" );
4268 if (len > strend - s)
4271 goto uchar_checksum;
4272 sv = NEWSV(35, len);
4273 sv_setpvn(sv, s, len);
4275 if (datumtype == 'A' || datumtype == 'Z') {
4276 aptr = s; /* borrow register */
4277 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4282 else { /* 'A' strips both nulls and spaces */
4283 s = SvPVX(sv) + len - 1;
4284 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4288 SvCUR_set(sv, s - SvPVX(sv));
4289 s = aptr; /* unborrow register */
4291 XPUSHs(sv_2mortal(sv));
4295 if (star || len > (strend - s) * 8)
4296 len = (strend - s) * 8;
4299 Newz(601, PL_bitcount, 256, char);
4300 for (bits = 1; bits < 256; bits++) {
4301 if (bits & 1) PL_bitcount[bits]++;
4302 if (bits & 2) PL_bitcount[bits]++;
4303 if (bits & 4) PL_bitcount[bits]++;
4304 if (bits & 8) PL_bitcount[bits]++;
4305 if (bits & 16) PL_bitcount[bits]++;
4306 if (bits & 32) PL_bitcount[bits]++;
4307 if (bits & 64) PL_bitcount[bits]++;
4308 if (bits & 128) PL_bitcount[bits]++;
4312 culong += PL_bitcount[*(unsigned char*)s++];
4317 if (datumtype == 'b') {
4319 if (bits & 1) culong++;
4325 if (bits & 128) culong++;
4332 sv = NEWSV(35, len + 1);
4336 if (datumtype == 'b') {
4338 for (len = 0; len < aint; len++) {
4339 if (len & 7) /*SUPPRESS 595*/
4343 *str++ = '0' + (bits & 1);
4348 for (len = 0; len < aint; len++) {
4353 *str++ = '0' + ((bits & 128) != 0);
4357 XPUSHs(sv_2mortal(sv));
4361 if (star || len > (strend - s) * 2)
4362 len = (strend - s) * 2;
4363 sv = NEWSV(35, len + 1);
4367 if (datumtype == 'h') {
4369 for (len = 0; len < aint; len++) {
4374 *str++ = PL_hexdigit[bits & 15];
4379 for (len = 0; len < aint; len++) {
4384 *str++ = PL_hexdigit[(bits >> 4) & 15];
4388 XPUSHs(sv_2mortal(sv));
4391 if (len > strend - s)
4396 if (aint >= 128) /* fake up signed chars */
4406 if (aint >= 128) /* fake up signed chars */
4409 sv_setiv(sv, (IV)aint);
4410 PUSHs(sv_2mortal(sv));
4415 if (len > strend - s)
4430 sv_setiv(sv, (IV)auint);
4431 PUSHs(sv_2mortal(sv));
4436 if (len > strend - s)
4439 while (len-- > 0 && s < strend) {
4441 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4445 cdouble += (NV)auint;
4453 while (len-- > 0 && s < strend) {
4455 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4459 sv_setuv(sv, (UV)auint);
4460 PUSHs(sv_2mortal(sv));
4465 #if SHORTSIZE == SIZE16
4466 along = (strend - s) / SIZE16;
4468 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4473 #if SHORTSIZE != SIZE16
4477 COPYNN(s, &ashort, sizeof(short));
4488 #if SHORTSIZE > SIZE16
4500 #if SHORTSIZE != SIZE16
4504 COPYNN(s, &ashort, sizeof(short));
4507 sv_setiv(sv, (IV)ashort);
4508 PUSHs(sv_2mortal(sv));
4516 #if SHORTSIZE > SIZE16
4522 sv_setiv(sv, (IV)ashort);
4523 PUSHs(sv_2mortal(sv));
4531 #if SHORTSIZE == SIZE16
4532 along = (strend - s) / SIZE16;
4534 unatint = natint && datumtype == 'S';
4535 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4540 #if SHORTSIZE != SIZE16
4542 unsigned short aushort;
4544 COPYNN(s, &aushort, sizeof(unsigned short));
4545 s += sizeof(unsigned short);
4553 COPY16(s, &aushort);
4556 if (datumtype == 'n')
4557 aushort = PerlSock_ntohs(aushort);
4560 if (datumtype == 'v')
4561 aushort = vtohs(aushort);
4570 #if SHORTSIZE != SIZE16
4572 unsigned short aushort;
4574 COPYNN(s, &aushort, sizeof(unsigned short));
4575 s += sizeof(unsigned short);
4577 sv_setiv(sv, (UV)aushort);
4578 PUSHs(sv_2mortal(sv));
4585 COPY16(s, &aushort);
4589 if (datumtype == 'n')
4590 aushort = PerlSock_ntohs(aushort);
4593 if (datumtype == 'v')
4594 aushort = vtohs(aushort);
4596 sv_setiv(sv, (UV)aushort);
4597 PUSHs(sv_2mortal(sv));
4603 along = (strend - s) / sizeof(int);
4608 Copy(s, &aint, 1, int);
4611 cdouble += (NV)aint;
4620 Copy(s, &aint, 1, int);
4624 /* Without the dummy below unpack("i", pack("i",-1))
4625 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4626 * cc with optimization turned on.
4628 * The bug was detected in
4629 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4630 * with optimization (-O4) turned on.
4631 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4632 * does not have this problem even with -O4.
4634 * This bug was reported as DECC_BUGS 1431
4635 * and tracked internally as GEM_BUGS 7775.
4637 * The bug is fixed in
4638 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4639 * UNIX V4.0F support: DEC C V5.9-006 or later
4640 * UNIX V4.0E support: DEC C V5.8-011 or later
4643 * See also few lines later for the same bug.
4646 sv_setiv(sv, (IV)aint) :
4648 sv_setiv(sv, (IV)aint);
4649 PUSHs(sv_2mortal(sv));
4654 along = (strend - s) / sizeof(unsigned int);
4659 Copy(s, &auint, 1, unsigned int);
4660 s += sizeof(unsigned int);
4662 cdouble += (NV)auint;
4671 Copy(s, &auint, 1, unsigned int);
4672 s += sizeof(unsigned int);
4675 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4676 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4677 * See details few lines earlier. */
4679 sv_setuv(sv, (UV)auint) :
4681 sv_setuv(sv, (UV)auint);
4682 PUSHs(sv_2mortal(sv));
4687 #if LONGSIZE == SIZE32
4688 along = (strend - s) / SIZE32;
4690 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4695 #if LONGSIZE != SIZE32
4698 COPYNN(s, &along, sizeof(long));
4701 cdouble += (NV)along;
4710 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4714 #if LONGSIZE > SIZE32
4715 if (along > 2147483647)
4716 along -= 4294967296;
4720 cdouble += (NV)along;
4729 #if LONGSIZE != SIZE32
4732 COPYNN(s, &along, sizeof(long));
4735 sv_setiv(sv, (IV)along);
4736 PUSHs(sv_2mortal(sv));
4743 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4747 #if LONGSIZE > SIZE32
4748 if (along > 2147483647)
4749 along -= 4294967296;
4753 sv_setiv(sv, (IV)along);
4754 PUSHs(sv_2mortal(sv));
4762 #if LONGSIZE == SIZE32
4763 along = (strend - s) / SIZE32;
4765 unatint = natint && datumtype == 'L';
4766 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4771 #if LONGSIZE != SIZE32
4773 unsigned long aulong;
4775 COPYNN(s, &aulong, sizeof(unsigned long));
4776 s += sizeof(unsigned long);
4778 cdouble += (NV)aulong;
4790 if (datumtype == 'N')
4791 aulong = PerlSock_ntohl(aulong);
4794 if (datumtype == 'V')
4795 aulong = vtohl(aulong);
4798 cdouble += (NV)aulong;
4807 #if LONGSIZE != SIZE32
4809 unsigned long aulong;
4811 COPYNN(s, &aulong, sizeof(unsigned long));
4812 s += sizeof(unsigned long);
4814 sv_setuv(sv, (UV)aulong);
4815 PUSHs(sv_2mortal(sv));
4825 if (datumtype == 'N')
4826 aulong = PerlSock_ntohl(aulong);
4829 if (datumtype == 'V')
4830 aulong = vtohl(aulong);
4833 sv_setuv(sv, (UV)aulong);
4834 PUSHs(sv_2mortal(sv));
4840 along = (strend - s) / sizeof(char*);
4846 if (sizeof(char*) > strend - s)
4849 Copy(s, &aptr, 1, char*);
4855 PUSHs(sv_2mortal(sv));
4865 while ((len > 0) && (s < strend)) {
4866 auv = (auv << 7) | (*s & 0x7f);
4867 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4868 if ((U8)(*s++) < 0x80) {
4872 PUSHs(sv_2mortal(sv));
4876 else if (++bytes >= sizeof(UV)) { /* promote to string */
4880 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4881 while (s < strend) {
4882 sv = mul128(sv, *s & 0x7f);
4883 if (!(*s++ & 0x80)) {
4892 PUSHs(sv_2mortal(sv));
4897 if ((s >= strend) && bytes)
4898 DIE(aTHX_ "Unterminated compressed integer");
4903 if (sizeof(char*) > strend - s)
4906 Copy(s, &aptr, 1, char*);
4911 sv_setpvn(sv, aptr, len);
4912 PUSHs(sv_2mortal(sv));
4916 along = (strend - s) / sizeof(Quad_t);
4922 if (s + sizeof(Quad_t) > strend)
4925 Copy(s, &aquad, 1, Quad_t);
4926 s += sizeof(Quad_t);
4929 if (aquad >= IV_MIN && aquad <= IV_MAX)
4930 sv_setiv(sv, (IV)aquad);
4932 sv_setnv(sv, (NV)aquad);
4933 PUSHs(sv_2mortal(sv));
4937 along = (strend - s) / sizeof(Quad_t);
4943 if (s + sizeof(Uquad_t) > strend)
4946 Copy(s, &auquad, 1, Uquad_t);
4947 s += sizeof(Uquad_t);
4950 if (auquad <= UV_MAX)
4951 sv_setuv(sv, (UV)auquad);
4953 sv_setnv(sv, (NV)auquad);
4954 PUSHs(sv_2mortal(sv));
4958 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4961 along = (strend - s) / sizeof(float);
4966 Copy(s, &afloat, 1, float);
4975 Copy(s, &afloat, 1, float);
4978 sv_setnv(sv, (NV)afloat);
4979 PUSHs(sv_2mortal(sv));
4985 along = (strend - s) / sizeof(double);
4990 Copy(s, &adouble, 1, double);
4991 s += sizeof(double);
4999 Copy(s, &adouble, 1, double);
5000 s += sizeof(double);
5002 sv_setnv(sv, (NV)adouble);
5003 PUSHs(sv_2mortal(sv));
5009 * Initialise the decode mapping. By using a table driven
5010 * algorithm, the code will be character-set independent
5011 * (and just as fast as doing character arithmetic)
5013 if (PL_uudmap['M'] == 0) {
5016 for (i = 0; i < sizeof(PL_uuemap); i += 1)
5017 PL_uudmap[(U8)PL_uuemap[i]] = i;
5019 * Because ' ' and '`' map to the same value,
5020 * we need to decode them both the same.
5025 along = (strend - s) * 3 / 4;
5026 sv = NEWSV(42, along);
5029 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
5034 len = PL_uudmap[*(U8*)s++] & 077;
5036 if (s < strend && ISUUCHAR(*s))
5037 a = PL_uudmap[*(U8*)s++] & 077;
5040 if (s < strend && ISUUCHAR(*s))
5041 b = PL_uudmap[*(U8*)s++] & 077;
5044 if (s < strend && ISUUCHAR(*s))
5045 c = PL_uudmap[*(U8*)s++] & 077;
5048 if (s < strend && ISUUCHAR(*s))
5049 d = PL_uudmap[*(U8*)s++] & 077;
5052 hunk[0] = (a << 2) | (b >> 4);
5053 hunk[1] = (b << 4) | (c >> 2);
5054 hunk[2] = (c << 6) | d;
5055 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5060 else if (s[1] == '\n') /* possible checksum byte */
5063 XPUSHs(sv_2mortal(sv));
5068 if (strchr("fFdD", datumtype) ||
5069 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5073 while (checksum >= 16) {
5077 while (checksum >= 4) {
5083 along = (1 << checksum) - 1;
5084 while (cdouble < 0.0)
5086 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5087 sv_setnv(sv, cdouble);
5090 if (checksum < 32) {
5091 aulong = (1 << checksum) - 1;
5094 sv_setuv(sv, (UV)culong);
5096 XPUSHs(sv_2mortal(sv));
5100 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5101 PUSHs(&PL_sv_undef);
5106 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5110 *hunk = PL_uuemap[len];
5111 sv_catpvn(sv, hunk, 1);
5114 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5115 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5116 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5117 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5118 sv_catpvn(sv, hunk, 4);
5123 char r = (len > 1 ? s[1] : '\0');
5124 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5125 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5126 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5127 hunk[3] = PL_uuemap[0];
5128 sv_catpvn(sv, hunk, 4);
5130 sv_catpvn(sv, "\n", 1);
5134 S_is_an_int(pTHX_ char *s, STRLEN l)
5137 SV *result = newSVpvn(s, l);
5138 char *result_c = SvPV(result, n_a); /* convenience */
5139 char *out = result_c;
5149 SvREFCNT_dec(result);
5172 SvREFCNT_dec(result);
5178 SvCUR_set(result, out - result_c);
5182 /* pnum must be '\0' terminated */
5184 S_div128(pTHX_ SV *pnum, bool *done)
5187 char *s = SvPV(pnum, len);
5196 i = m * 10 + (*t - '0');
5198 r = (i >> 7); /* r < 10 */
5205 SvCUR_set(pnum, (STRLEN) (t - s));
5212 dSP; dMARK; dORIGMARK; dTARGET;
5213 register SV *cat = TARG;
5216 register char *pat = SvPVx(*++MARK, fromlen);
5218 register char *patend = pat + fromlen;
5223 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5224 static char *space10 = " ";
5226 /* These must not be in registers: */
5241 #ifdef PERL_NATINT_PACK
5242 int natint; /* native integer */
5247 sv_setpvn(cat, "", 0);
5249 while (pat < patend) {
5250 SV *lengthcode = Nullsv;
5251 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5252 datumtype = *pat++ & 0xFF;
5253 #ifdef PERL_NATINT_PACK
5256 if (isSPACE(datumtype)) {
5260 #ifndef PACKED_IS_OCTETS
5261 if (datumtype == 'U' && pat == patcopy+1)
5264 if (datumtype == '#') {
5265 while (pat < patend && *pat != '\n')
5270 char *natstr = "sSiIlL";
5272 if (strchr(natstr, datumtype)) {
5273 #ifdef PERL_NATINT_PACK
5279 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5282 len = strchr("@Xxu", datumtype) ? 0 : items;
5285 else if (isDIGIT(*pat)) {
5287 while (isDIGIT(*pat)) {
5288 len = (len * 10) + (*pat++ - '0');
5290 DIE(aTHX_ "Repeat count in pack overflows");
5297 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5298 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5299 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5300 ? *MARK : &PL_sv_no)
5301 + (*pat == 'Z' ? 1 : 0)));
5305 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5306 case ',': /* grandfather in commas but with a warning */
5307 if (commas++ == 0 && ckWARN(WARN_PACK))
5308 Perl_warner(aTHX_ WARN_PACK,
5309 "Invalid type in pack: '%c'", (int)datumtype);
5312 DIE(aTHX_ "%% may only be used in unpack");
5323 if (SvCUR(cat) < len)
5324 DIE(aTHX_ "X outside of string");
5331 sv_catpvn(cat, null10, 10);
5334 sv_catpvn(cat, null10, len);
5340 aptr = SvPV(fromstr, fromlen);
5341 if (pat[-1] == '*') {
5343 if (datumtype == 'Z')
5346 if (fromlen >= len) {
5347 sv_catpvn(cat, aptr, len);
5348 if (datumtype == 'Z')
5349 *(SvEND(cat)-1) = '\0';
5352 sv_catpvn(cat, aptr, fromlen);
5354 if (datumtype == 'A') {
5356 sv_catpvn(cat, space10, 10);
5359 sv_catpvn(cat, space10, len);
5363 sv_catpvn(cat, null10, 10);
5366 sv_catpvn(cat, null10, len);
5378 str = SvPV(fromstr, fromlen);
5382 SvCUR(cat) += (len+7)/8;
5383 SvGROW(cat, SvCUR(cat) + 1);
5384 aptr = SvPVX(cat) + aint;
5389 if (datumtype == 'B') {
5390 for (len = 0; len++ < aint;) {
5391 items |= *str++ & 1;
5395 *aptr++ = items & 0xff;
5401 for (len = 0; len++ < aint;) {
5407 *aptr++ = items & 0xff;
5413 if (datumtype == 'B')
5414 items <<= 7 - (aint & 7);
5416 items >>= 7 - (aint & 7);
5417 *aptr++ = items & 0xff;
5419 str = SvPVX(cat) + SvCUR(cat);
5434 str = SvPV(fromstr, fromlen);
5438 SvCUR(cat) += (len+1)/2;
5439 SvGROW(cat, SvCUR(cat) + 1);
5440 aptr = SvPVX(cat) + aint;
5445 if (datumtype == 'H') {
5446 for (len = 0; len++ < aint;) {
5448 items |= ((*str++ & 15) + 9) & 15;
5450 items |= *str++ & 15;
5454 *aptr++ = items & 0xff;
5460 for (len = 0; len++ < aint;) {
5462 items |= (((*str++ & 15) + 9) & 15) << 4;
5464 items |= (*str++ & 15) << 4;
5468 *aptr++ = items & 0xff;
5474 *aptr++ = items & 0xff;
5475 str = SvPVX(cat) + SvCUR(cat);
5486 switch (datumtype) {
5488 aint = SvIV(fromstr);
5489 if ((aint < 0 || aint > 255) &&
5491 Perl_warner(aTHX_ WARN_PACK,
5492 "Character in \"C\" format wrapped");
5494 sv_catpvn(cat, &achar, sizeof(char));
5497 aint = SvIV(fromstr);
5498 if ((aint < -128 || aint > 127) &&
5500 Perl_warner(aTHX_ WARN_PACK,
5501 "Character in \"c\" format wrapped");
5503 sv_catpvn(cat, &achar, sizeof(char));
5511 auint = SvUV(fromstr);
5512 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5513 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5518 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5523 afloat = (float)SvNV(fromstr);
5524 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5531 adouble = (double)SvNV(fromstr);
5532 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5538 ashort = (I16)SvIV(fromstr);
5540 ashort = PerlSock_htons(ashort);
5542 CAT16(cat, &ashort);
5548 ashort = (I16)SvIV(fromstr);
5550 ashort = htovs(ashort);
5552 CAT16(cat, &ashort);
5556 #if SHORTSIZE != SIZE16
5558 unsigned short aushort;
5562 aushort = SvUV(fromstr);
5563 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5573 aushort = (U16)SvUV(fromstr);
5574 CAT16(cat, &aushort);
5580 #if SHORTSIZE != SIZE16
5586 ashort = SvIV(fromstr);
5587 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5595 ashort = (I16)SvIV(fromstr);
5596 CAT16(cat, &ashort);
5603 auint = SvUV(fromstr);
5604 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5610 adouble = Perl_floor(SvNV(fromstr));
5613 DIE(aTHX_ "Cannot compress negative numbers");
5616 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5617 adouble <= 0xffffffff
5619 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5620 adouble <= UV_MAX_cxux
5627 char buf[1 + sizeof(UV)];
5628 char *in = buf + sizeof(buf);
5629 UV auv = U_V(adouble);
5632 *--in = (auv & 0x7f) | 0x80;
5635 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5636 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5638 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5639 char *from, *result, *in;
5644 /* Copy string and check for compliance */
5645 from = SvPV(fromstr, len);
5646 if ((norm = is_an_int(from, len)) == NULL)
5647 DIE(aTHX_ "can compress only unsigned integer");
5649 New('w', result, len, char);
5653 *--in = div128(norm, &done) | 0x80;
5654 result[len - 1] &= 0x7F; /* clear continue bit */
5655 sv_catpvn(cat, in, (result + len) - in);
5657 SvREFCNT_dec(norm); /* free norm */
5659 else if (SvNOKp(fromstr)) {
5660 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5661 char *in = buf + sizeof(buf);
5664 double next = floor(adouble / 128);
5665 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5666 if (in <= buf) /* this cannot happen ;-) */
5667 DIE(aTHX_ "Cannot compress integer");
5670 } while (adouble > 0);
5671 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5672 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5675 DIE(aTHX_ "Cannot compress non integer");
5681 aint = SvIV(fromstr);
5682 sv_catpvn(cat, (char*)&aint, sizeof(int));
5688 aulong = SvUV(fromstr);
5690 aulong = PerlSock_htonl(aulong);
5692 CAT32(cat, &aulong);
5698 aulong = SvUV(fromstr);
5700 aulong = htovl(aulong);
5702 CAT32(cat, &aulong);
5706 #if LONGSIZE != SIZE32
5708 unsigned long aulong;
5712 aulong = SvUV(fromstr);
5713 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5721 aulong = SvUV(fromstr);
5722 CAT32(cat, &aulong);
5727 #if LONGSIZE != SIZE32
5733 along = SvIV(fromstr);
5734 sv_catpvn(cat, (char *)&along, sizeof(long));
5742 along = SvIV(fromstr);
5751 auquad = (Uquad_t)SvUV(fromstr);
5752 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5758 aquad = (Quad_t)SvIV(fromstr);
5759 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5764 len = 1; /* assume SV is correct length */
5769 if (fromstr == &PL_sv_undef)
5773 /* XXX better yet, could spirit away the string to
5774 * a safe spot and hang on to it until the result
5775 * of pack() (and all copies of the result) are
5778 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5779 || (SvPADTMP(fromstr)
5780 && !SvREADONLY(fromstr))))
5782 Perl_warner(aTHX_ WARN_PACK,
5783 "Attempt to pack pointer to temporary value");
5785 if (SvPOK(fromstr) || SvNIOK(fromstr))
5786 aptr = SvPV(fromstr,n_a);
5788 aptr = SvPV_force(fromstr,n_a);
5790 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5795 aptr = SvPV(fromstr, fromlen);
5796 SvGROW(cat, fromlen * 4 / 3);
5801 while (fromlen > 0) {
5808 doencodes(cat, aptr, todo);
5827 register IV limit = POPi; /* note, negative is forever */
5830 register char *s = SvPV(sv, len);
5831 bool do_utf8 = DO_UTF8(sv);
5832 char *strend = s + len;
5834 register REGEXP *rx;
5838 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5839 I32 maxiters = slen + 10;
5842 I32 origlimit = limit;
5845 AV *oldstack = PL_curstack;
5846 I32 gimme = GIMME_V;
5847 I32 oldsave = PL_savestack_ix;
5848 I32 make_mortal = 1;
5849 MAGIC *mg = (MAGIC *) NULL;
5852 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5857 DIE(aTHX_ "panic: pp_split");
5858 rx = pm->op_pmregexp;
5860 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5861 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5863 if (pm->op_pmreplroot) {
5865 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5867 ary = GvAVn((GV*)pm->op_pmreplroot);
5870 else if (gimme != G_ARRAY)
5872 ary = (AV*)PL_curpad[0];
5874 ary = GvAVn(PL_defgv);
5875 #endif /* USE_THREADS */
5878 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5884 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
5886 XPUSHs(SvTIED_obj((SV*)ary, mg));
5892 for (i = AvFILLp(ary); i >= 0; i--)
5893 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5895 /* temporarily switch stacks */
5896 SWITCHSTACK(PL_curstack, ary);
5900 base = SP - PL_stack_base;
5902 if (pm->op_pmflags & PMf_SKIPWHITE) {
5903 if (pm->op_pmflags & PMf_LOCALE) {
5904 while (isSPACE_LC(*s))
5912 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5913 SAVEINT(PL_multiline);
5914 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5918 limit = maxiters + 2;
5919 if (pm->op_pmflags & PMf_WHITE) {
5922 while (m < strend &&
5923 !((pm->op_pmflags & PMf_LOCALE)
5924 ? isSPACE_LC(*m) : isSPACE(*m)))
5929 dstr = NEWSV(30, m-s);
5930 sv_setpvn(dstr, s, m-s);
5934 (void)SvUTF8_on(dstr);
5938 while (s < strend &&
5939 ((pm->op_pmflags & PMf_LOCALE)
5940 ? isSPACE_LC(*s) : isSPACE(*s)))
5944 else if (strEQ("^", rx->precomp)) {
5947 for (m = s; m < strend && *m != '\n'; m++) ;
5951 dstr = NEWSV(30, m-s);
5952 sv_setpvn(dstr, s, m-s);
5956 (void)SvUTF8_on(dstr);
5961 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5962 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5963 && (rx->reganch & ROPT_CHECK_ALL)
5964 && !(rx->reganch & ROPT_ANCH)) {
5965 int tail = (rx->reganch & RE_INTUIT_TAIL);
5966 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5969 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5971 char c = *SvPV(csv, n_a);
5974 for (m = s; m < strend && *m != c; m++) ;
5977 dstr = NEWSV(30, m-s);
5978 sv_setpvn(dstr, s, m-s);
5982 (void)SvUTF8_on(dstr);
5984 /* The rx->minlen is in characters but we want to step
5985 * s ahead by bytes. */
5987 s = (char*)utf8_hop((U8*)m, len);
5989 s = m + len; /* Fake \n at the end */
5994 while (s < strend && --limit &&
5995 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5996 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5999 dstr = NEWSV(31, m-s);
6000 sv_setpvn(dstr, s, m-s);
6004 (void)SvUTF8_on(dstr);
6006 /* The rx->minlen is in characters but we want to step
6007 * s ahead by bytes. */
6009 s = (char*)utf8_hop((U8*)m, len);
6011 s = m + len; /* Fake \n at the end */
6016 maxiters += slen * rx->nparens;
6017 while (s < strend && --limit
6018 /* && (!rx->check_substr
6019 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
6021 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
6022 1 /* minend */, sv, NULL, 0))
6024 TAINT_IF(RX_MATCH_TAINTED(rx));
6025 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
6030 strend = s + (strend - m);
6032 m = rx->startp[0] + orig;
6033 dstr = NEWSV(32, m-s);
6034 sv_setpvn(dstr, s, m-s);
6038 (void)SvUTF8_on(dstr);
6041 for (i = 1; i <= rx->nparens; i++) {
6042 s = rx->startp[i] + orig;
6043 m = rx->endp[i] + orig;
6045 dstr = NEWSV(33, m-s);
6046 sv_setpvn(dstr, s, m-s);
6049 dstr = NEWSV(33, 0);
6053 (void)SvUTF8_on(dstr);
6057 s = rx->endp[0] + orig;
6061 LEAVE_SCOPE(oldsave);
6062 iters = (SP - PL_stack_base) - base;
6063 if (iters > maxiters)
6064 DIE(aTHX_ "Split loop");
6066 /* keep field after final delim? */
6067 if (s < strend || (iters && origlimit)) {
6068 STRLEN l = strend - s;
6069 dstr = NEWSV(34, l);
6070 sv_setpvn(dstr, s, l);
6074 (void)SvUTF8_on(dstr);
6078 else if (!origlimit) {
6079 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6085 SWITCHSTACK(ary, oldstack);
6086 if (SvSMAGICAL(ary)) {
6091 if (gimme == G_ARRAY) {
6093 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6101 call_method("PUSH",G_SCALAR|G_DISCARD);
6104 if (gimme == G_ARRAY) {
6105 /* EXTEND should not be needed - we just popped them */
6107 for (i=0; i < iters; i++) {
6108 SV **svp = av_fetch(ary, i, FALSE);
6109 PUSHs((svp) ? *svp : &PL_sv_undef);
6116 if (gimme == G_ARRAY)
6119 if (iters || !pm->op_pmreplroot) {
6129 Perl_unlock_condpair(pTHX_ void *svv)
6131 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
6134 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6135 MUTEX_LOCK(MgMUTEXP(mg));
6136 if (MgOWNER(mg) != thr)
6137 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6139 COND_SIGNAL(MgOWNERCONDP(mg));
6140 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6141 PTR2UV(thr), PTR2UV(svv));)
6142 MUTEX_UNLOCK(MgMUTEXP(mg));
6144 #endif /* USE_THREADS */
6153 #endif /* USE_THREADS */
6154 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6155 || SvTYPE(retsv) == SVt_PVCV) {
6156 retsv = refto(retsv);
6167 if (PL_op->op_private & OPpLVAL_INTRO)
6168 PUSHs(*save_threadsv(PL_op->op_targ));
6170 PUSHs(THREADSV(PL_op->op_targ));
6173 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6174 #endif /* USE_THREADS */