3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if LONGSIZE > 4 && defined(_CRAY)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
85 /* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
89 #ifdef NEED_GETPID_PROTO
90 extern Pid_t getpid (void);
96 if (GIMME_V == G_SCALAR)
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
114 if (PL_op->op_flags & OPf_REF) {
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
123 if (GIMME == G_ARRAY) {
124 I32 maxarg = AvFILL((AV*)TARG) + 1;
126 if (SvMAGICAL(TARG)) {
128 for (i=0; i < maxarg; i++) {
129 SV **svp = av_fetch((AV*)TARG, i, FALSE);
130 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
134 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
139 SV* sv = sv_newmortal();
140 I32 maxarg = AvFILL((AV*)TARG) + 1;
141 sv_setiv(sv, maxarg);
153 if (PL_op->op_private & OPpLVAL_INTRO)
154 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
155 if (PL_op->op_flags & OPf_REF)
158 if (GIMME == G_SCALAR)
159 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
163 if (gimme == G_ARRAY) {
166 else if (gimme == G_SCALAR) {
167 SV* sv = sv_newmortal();
168 if (HvFILL((HV*)TARG))
169 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
170 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
180 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
191 tryAMAGICunDEREF(to_gv);
194 if (SvTYPE(sv) == SVt_PVIO) {
195 GV *gv = (GV*) sv_newmortal();
196 gv_init(gv, 0, "", 0, 0);
197 GvIOp(gv) = (IO *)sv;
198 (void)SvREFCNT_inc(sv);
201 else if (SvTYPE(sv) != SVt_PVGV)
202 DIE(aTHX_ "Not a GLOB reference");
205 if (SvTYPE(sv) != SVt_PVGV) {
209 if (SvGMAGICAL(sv)) {
214 if (!SvOK(sv) && sv != &PL_sv_undef) {
215 /* If this is a 'my' scalar and flag is set then vivify
218 if (PL_op->op_private & OPpDEREF) {
221 if (cUNOP->op_targ) {
223 SV *namesv = PL_curpad[cUNOP->op_targ];
224 name = SvPV(namesv, len);
225 gv = (GV*)NEWSV(0,0);
226 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
229 name = CopSTASHPV(PL_curcop);
232 if (SvTYPE(sv) < SVt_RV)
233 sv_upgrade(sv, SVt_RV);
239 if (PL_op->op_flags & OPf_REF ||
240 PL_op->op_private & HINT_STRICT_REFS)
241 DIE(aTHX_ PL_no_usym, "a symbol");
242 if (ckWARN(WARN_UNINITIALIZED))
247 if ((PL_op->op_flags & OPf_SPECIAL) &&
248 !(PL_op->op_flags & OPf_MOD))
250 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
252 && (!is_gv_magical(sym,len,0)
253 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
259 if (PL_op->op_private & HINT_STRICT_REFS)
260 DIE(aTHX_ PL_no_symref, sym, "a symbol");
261 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
265 if (PL_op->op_private & OPpLVAL_INTRO)
266 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
277 tryAMAGICunDEREF(to_sv);
280 switch (SvTYPE(sv)) {
284 DIE(aTHX_ "Not a SCALAR reference");
292 if (SvTYPE(gv) != SVt_PVGV) {
293 if (SvGMAGICAL(sv)) {
299 if (PL_op->op_flags & OPf_REF ||
300 PL_op->op_private & HINT_STRICT_REFS)
301 DIE(aTHX_ PL_no_usym, "a SCALAR");
302 if (ckWARN(WARN_UNINITIALIZED))
307 if ((PL_op->op_flags & OPf_SPECIAL) &&
308 !(PL_op->op_flags & OPf_MOD))
310 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
312 && (!is_gv_magical(sym,len,0)
313 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
319 if (PL_op->op_private & HINT_STRICT_REFS)
320 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
321 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
326 if (PL_op->op_flags & OPf_MOD) {
327 if (PL_op->op_private & OPpLVAL_INTRO)
328 sv = save_scalar((GV*)TOPs);
329 else if (PL_op->op_private & OPpDEREF)
330 vivify_ref(sv, PL_op->op_private & OPpDEREF);
340 SV *sv = AvARYLEN(av);
342 AvARYLEN(av) = sv = NEWSV(0,0);
343 sv_upgrade(sv, SVt_IV);
344 sv_magic(sv, (SV*)av, '#', Nullch, 0);
352 dSP; dTARGET; dPOPss;
354 if (PL_op->op_flags & OPf_MOD || LVRET) {
355 if (SvTYPE(TARG) < SVt_PVLV) {
356 sv_upgrade(TARG, SVt_PVLV);
357 sv_magic(TARG, Nullsv, '.', Nullch, 0);
361 if (LvTARG(TARG) != sv) {
363 SvREFCNT_dec(LvTARG(TARG));
364 LvTARG(TARG) = SvREFCNT_inc(sv);
366 PUSHs(TARG); /* no SvSETMAGIC */
372 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
373 mg = mg_find(sv, 'g');
374 if (mg && mg->mg_len >= 0) {
378 PUSHi(i + PL_curcop->cop_arybase);
392 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
393 /* (But not in defined().) */
394 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
397 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
398 if ((PL_op->op_private & OPpLVAL_INTRO)) {
399 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
402 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
406 cv = (CV*)&PL_sv_undef;
420 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
421 char *s = SvPVX(TOPs);
422 if (strnEQ(s, "CORE::", 6)) {
425 code = keyword(s + 6, SvCUR(TOPs) - 6);
426 if (code < 0) { /* Overridable. */
427 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
428 int i = 0, n = 0, seen_question = 0;
430 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
432 while (i < MAXO) { /* The slow way. */
433 if (strEQ(s + 6, PL_op_name[i])
434 || strEQ(s + 6, PL_op_desc[i]))
440 goto nonesuch; /* Should not happen... */
442 oa = PL_opargs[i] >> OASHIFT;
444 if (oa & OA_OPTIONAL && !seen_question) {
448 else if (n && str[0] == ';' && seen_question)
449 goto set; /* XXXX system, exec */
450 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
451 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
454 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
455 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
459 ret = sv_2mortal(newSVpvn(str, n - 1));
461 else if (code) /* Non-Overridable */
463 else { /* None such */
465 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
469 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
471 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
480 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
482 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
498 if (GIMME != G_ARRAY) {
502 *MARK = &PL_sv_undef;
503 *MARK = refto(*MARK);
507 EXTEND_MORTAL(SP - MARK);
509 *MARK = refto(*MARK);
514 S_refto(pTHX_ SV *sv)
518 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
521 if (!(sv = LvTARG(sv)))
524 (void)SvREFCNT_inc(sv);
526 else if (SvTYPE(sv) == SVt_PVAV) {
527 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
530 (void)SvREFCNT_inc(sv);
532 else if (SvPADTMP(sv))
536 (void)SvREFCNT_inc(sv);
539 sv_upgrade(rv, SVt_RV);
553 if (sv && SvGMAGICAL(sv))
556 if (!sv || !SvROK(sv))
560 pv = sv_reftype(sv,TRUE);
561 PUSHp(pv, strlen(pv));
571 stash = CopSTASH(PL_curcop);
577 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
578 Perl_croak(aTHX_ "Attempt to bless into a reference");
580 if (ckWARN(WARN_MISC) && len == 0)
581 Perl_warner(aTHX_ WARN_MISC,
582 "Explicit blessing to '' (assuming package main)");
583 stash = gv_stashpvn(ptr, len, TRUE);
586 (void)sv_bless(TOPs, stash);
600 elem = SvPV(sv, n_a);
604 switch (elem ? *elem : '\0')
607 if (strEQ(elem, "ARRAY"))
608 tmpRef = (SV*)GvAV(gv);
611 if (strEQ(elem, "CODE"))
612 tmpRef = (SV*)GvCVu(gv);
615 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
616 tmpRef = (SV*)GvIOp(gv);
618 if (strEQ(elem, "FORMAT"))
619 tmpRef = (SV*)GvFORM(gv);
622 if (strEQ(elem, "GLOB"))
626 if (strEQ(elem, "HASH"))
627 tmpRef = (SV*)GvHV(gv);
630 if (strEQ(elem, "IO"))
631 tmpRef = (SV*)GvIOp(gv);
634 if (strEQ(elem, "NAME"))
635 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
638 if (strEQ(elem, "PACKAGE"))
639 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
642 if (strEQ(elem, "SCALAR"))
656 /* Pattern matching */
661 register unsigned char *s;
664 register I32 *sfirst;
668 if (sv == PL_lastscream) {
674 SvSCREAM_off(PL_lastscream);
675 SvREFCNT_dec(PL_lastscream);
677 PL_lastscream = SvREFCNT_inc(sv);
680 s = (unsigned char*)(SvPV(sv, len));
684 if (pos > PL_maxscream) {
685 if (PL_maxscream < 0) {
686 PL_maxscream = pos + 80;
687 New(301, PL_screamfirst, 256, I32);
688 New(302, PL_screamnext, PL_maxscream, I32);
691 PL_maxscream = pos + pos / 4;
692 Renew(PL_screamnext, PL_maxscream, I32);
696 sfirst = PL_screamfirst;
697 snext = PL_screamnext;
699 if (!sfirst || !snext)
700 DIE(aTHX_ "do_study: out of memory");
702 for (ch = 256; ch; --ch)
709 snext[pos] = sfirst[ch] - pos;
716 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
725 if (PL_op->op_flags & OPf_STACKED)
731 TARG = sv_newmortal();
736 /* Lvalue operators. */
748 dSP; dMARK; dTARGET; dORIGMARK;
750 do_chop(TARG, *++MARK);
759 SETi(do_chomp(TOPs));
766 register I32 count = 0;
769 count += do_chomp(POPs);
780 if (!sv || !SvANY(sv))
782 switch (SvTYPE(sv)) {
784 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
788 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
792 if (CvROOT(sv) || CvXSUB(sv))
809 if (!PL_op->op_private) {
818 if (SvTHINKFIRST(sv))
821 switch (SvTYPE(sv)) {
831 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
832 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
833 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
837 /* let user-undef'd sub keep its identity */
838 GV* gv = CvGV((CV*)sv);
845 SvSetMagicSV(sv, &PL_sv_undef);
849 Newz(602, gp, 1, GP);
850 GvGP(sv) = gp_ref(gp);
851 GvSV(sv) = NEWSV(72,0);
852 GvLINE(sv) = CopLINE(PL_curcop);
858 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
861 SvPV_set(sv, Nullch);
874 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
875 DIE(aTHX_ PL_no_modify);
876 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
877 SvIVX(TOPs) != IV_MIN)
880 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
891 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
892 DIE(aTHX_ PL_no_modify);
893 sv_setsv(TARG, TOPs);
894 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
895 SvIVX(TOPs) != IV_MAX)
898 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
912 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
913 DIE(aTHX_ PL_no_modify);
914 sv_setsv(TARG, TOPs);
915 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
916 SvIVX(TOPs) != IV_MIN)
919 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
928 /* Ordinary operators. */
932 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
935 SETn( Perl_pow( left, right) );
942 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
943 #ifdef PERL_PRESERVE_IVUV
946 /* Unless the left argument is integer in range we are going to have to
947 use NV maths. Hence only attempt to coerce the right argument if
948 we know the left is integer. */
949 /* Left operand is defined, so is it IV? */
952 bool auvok = SvUOK(TOPm1s);
953 bool buvok = SvUOK(TOPs);
954 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
955 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
962 alow = SvUVX(TOPm1s);
964 IV aiv = SvIVX(TOPm1s);
967 auvok = TRUE; /* effectively it's a UV now */
969 alow = -aiv; /* abs, auvok == false records sign */
975 IV biv = SvIVX(TOPs);
978 buvok = TRUE; /* effectively it's a UV now */
980 blow = -biv; /* abs, buvok == false records sign */
984 /* If this does sign extension on unsigned it's time for plan B */
985 ahigh = alow >> (4 * sizeof (UV));
987 bhigh = blow >> (4 * sizeof (UV));
989 if (ahigh && bhigh) {
990 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
991 which is overflow. Drop to NVs below. */
992 } else if (!ahigh && !bhigh) {
993 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
994 so the unsigned multiply cannot overflow. */
995 UV product = alow * blow;
996 if (auvok == buvok) {
997 /* -ve * -ve or +ve * +ve gives a +ve result. */
1001 } else if (product <= (UV)IV_MIN) {
1002 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1003 /* -ve result, which could overflow an IV */
1007 } /* else drop to NVs below. */
1009 /* One operand is large, 1 small */
1012 /* swap the operands */
1014 bhigh = blow; /* bhigh now the temp var for the swap */
1018 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1019 multiplies can't overflow. shift can, add can, -ve can. */
1020 product_middle = ahigh * blow;
1021 if (!(product_middle & topmask)) {
1022 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1024 product_middle <<= (4 * sizeof (UV));
1025 product_low = alow * blow;
1027 /* as for pp_add, UV + something mustn't get smaller.
1028 IIRC ANSI mandates this wrapping *behaviour* for
1029 unsigned whatever the actual representation*/
1030 product_low += product_middle;
1031 if (product_low >= product_middle) {
1032 /* didn't overflow */
1033 if (auvok == buvok) {
1034 /* -ve * -ve or +ve * +ve gives a +ve result. */
1036 SETu( product_low );
1038 } else if (product_low <= (UV)IV_MIN) {
1039 /* 2s complement assumption again */
1040 /* -ve result, which could overflow an IV */
1042 SETi( -product_low );
1044 } /* else drop to NVs below. */
1046 } /* product_middle too large */
1047 } /* ahigh && bhigh */
1048 } /* SvIOK(TOPm1s) */
1053 SETn( left * right );
1060 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1065 DIE(aTHX_ "Illegal division by zero");
1067 /* insure that 20./5. == 4. */
1070 if ((NV)I_V(left) == left &&
1071 (NV)I_V(right) == right &&
1072 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
1076 value = left / right;
1080 value = left / right;
1089 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1095 bool use_double = 0;
1099 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1101 right = (right_neg = (i < 0)) ? -i : i;
1106 right_neg = dright < 0;
1111 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1113 left = (left_neg = (i < 0)) ? -i : i;
1121 left_neg = dleft < 0;
1130 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1132 # define CAST_D2UV(d) U_V(d)
1134 # define CAST_D2UV(d) ((UV)(d))
1136 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1137 * or, in other words, precision of UV more than of NV.
1138 * But in fact the approach below turned out to be an
1139 * optimization - floor() may be slow */
1140 if (dright <= UV_MAX && dleft <= UV_MAX) {
1141 right = CAST_D2UV(dright);
1142 left = CAST_D2UV(dleft);
1147 /* Backward-compatibility clause: */
1148 dright = Perl_floor(dright + 0.5);
1149 dleft = Perl_floor(dleft + 0.5);
1152 DIE(aTHX_ "Illegal modulus zero");
1154 dans = Perl_fmod(dleft, dright);
1155 if ((left_neg != right_neg) && dans)
1156 dans = dright - dans;
1159 sv_setnv(TARG, dans);
1166 DIE(aTHX_ "Illegal modulus zero");
1169 if ((left_neg != right_neg) && ans)
1172 /* XXX may warn: unary minus operator applied to unsigned type */
1173 /* could change -foo to be (~foo)+1 instead */
1174 if (ans <= ~((UV)IV_MAX)+1)
1175 sv_setiv(TARG, ~ans+1);
1177 sv_setnv(TARG, -(NV)ans);
1180 sv_setuv(TARG, ans);
1189 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1191 register IV count = POPi;
1192 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1194 I32 items = SP - MARK;
1197 max = items * count;
1206 repeatcpy((char*)(MARK + items), (char*)MARK,
1207 items * sizeof(SV*), count - 1);
1210 else if (count <= 0)
1213 else { /* Note: mark already snarfed by pp_list */
1218 SvSetSV(TARG, tmpstr);
1219 SvPV_force(TARG, len);
1220 isutf = DO_UTF8(TARG);
1225 SvGROW(TARG, (count * len) + 1);
1226 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1227 SvCUR(TARG) *= count;
1229 *SvEND(TARG) = '\0';
1232 (void)SvPOK_only_UTF8(TARG);
1234 (void)SvPOK_only(TARG);
1243 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1244 useleft = USE_LEFT(TOPm1s);
1245 #ifdef PERL_PRESERVE_IVUV
1246 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1247 "bad things" happen if you rely on signed integers wrapping. */
1250 /* Unless the left argument is integer in range we are going to have to
1251 use NV maths. Hence only attempt to coerce the right argument if
1252 we know the left is integer. */
1259 a_valid = auvok = 1;
1260 /* left operand is undef, treat as zero. */
1262 /* Left operand is defined, so is it IV? */
1263 SvIV_please(TOPm1s);
1264 if (SvIOK(TOPm1s)) {
1265 if ((auvok = SvUOK(TOPm1s)))
1266 auv = SvUVX(TOPm1s);
1268 register IV aiv = SvIVX(TOPm1s);
1271 auvok = 1; /* Now acting as a sign flag. */
1272 } else { /* 2s complement assumption for IV_MIN */
1280 bool result_good = 0;
1283 bool buvok = SvUOK(TOPs);
1288 register IV biv = SvIVX(TOPs);
1295 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1296 else "IV" now, independant of how it came in.
1297 if a, b represents positive, A, B negative, a maps to -A etc
1302 all UV maths. negate result if A negative.
1303 subtract if signs same, add if signs differ. */
1305 if (auvok ^ buvok) {
1314 /* Must get smaller */
1319 if (result <= buv) {
1320 /* result really should be -(auv-buv). as its negation
1321 of true value, need to swap our result flag */
1333 if (result <= (UV)IV_MIN)
1334 SETi( -(IV)result );
1336 /* result valid, but out of range for IV. */
1337 SETn( -(NV)result );
1341 } /* Overflow, drop through to NVs. */
1345 useleft = USE_LEFT(TOPm1s);
1349 /* left operand is undef, treat as zero - value */
1353 SETn( TOPn - value );
1360 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1363 if (PL_op->op_private & HINT_INTEGER) {
1377 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1380 if (PL_op->op_private & HINT_INTEGER) {
1394 dSP; tryAMAGICbinSET(lt,0);
1395 #ifdef PERL_PRESERVE_IVUV
1398 SvIV_please(TOPm1s);
1399 if (SvIOK(TOPm1s)) {
1400 bool auvok = SvUOK(TOPm1s);
1401 bool buvok = SvUOK(TOPs);
1403 if (!auvok && !buvok) { /* ## IV < IV ## */
1404 IV aiv = SvIVX(TOPm1s);
1405 IV biv = SvIVX(TOPs);
1408 SETs(boolSV(aiv < biv));
1411 if (auvok && buvok) { /* ## UV < UV ## */
1412 UV auv = SvUVX(TOPm1s);
1413 UV buv = SvUVX(TOPs);
1416 SETs(boolSV(auv < buv));
1419 if (auvok) { /* ## UV < IV ## */
1426 /* As (a) is a UV, it's >=0, so it cannot be < */
1431 if (auv >= (UV) IV_MAX) {
1432 /* As (b) is an IV, it cannot be > IV_MAX */
1436 SETs(boolSV(auv < (UV)biv));
1439 { /* ## IV < UV ## */
1443 aiv = SvIVX(TOPm1s);
1445 /* As (b) is a UV, it's >=0, so it must be < */
1452 if (buv > (UV) IV_MAX) {
1453 /* As (a) is an IV, it cannot be > IV_MAX */
1457 SETs(boolSV((UV)aiv < buv));
1465 SETs(boolSV(TOPn < value));
1472 dSP; tryAMAGICbinSET(gt,0);
1473 #ifdef PERL_PRESERVE_IVUV
1476 SvIV_please(TOPm1s);
1477 if (SvIOK(TOPm1s)) {
1478 bool auvok = SvUOK(TOPm1s);
1479 bool buvok = SvUOK(TOPs);
1481 if (!auvok && !buvok) { /* ## IV > IV ## */
1482 IV aiv = SvIVX(TOPm1s);
1483 IV biv = SvIVX(TOPs);
1486 SETs(boolSV(aiv > biv));
1489 if (auvok && buvok) { /* ## UV > UV ## */
1490 UV auv = SvUVX(TOPm1s);
1491 UV buv = SvUVX(TOPs);
1494 SETs(boolSV(auv > buv));
1497 if (auvok) { /* ## UV > IV ## */
1504 /* As (a) is a UV, it's >=0, so it must be > */
1509 if (auv > (UV) IV_MAX) {
1510 /* As (b) is an IV, it cannot be > IV_MAX */
1514 SETs(boolSV(auv > (UV)biv));
1517 { /* ## IV > UV ## */
1521 aiv = SvIVX(TOPm1s);
1523 /* As (b) is a UV, it's >=0, so it cannot be > */
1530 if (buv >= (UV) IV_MAX) {
1531 /* As (a) is an IV, it cannot be > IV_MAX */
1535 SETs(boolSV((UV)aiv > buv));
1543 SETs(boolSV(TOPn > value));
1550 dSP; tryAMAGICbinSET(le,0);
1551 #ifdef PERL_PRESERVE_IVUV
1554 SvIV_please(TOPm1s);
1555 if (SvIOK(TOPm1s)) {
1556 bool auvok = SvUOK(TOPm1s);
1557 bool buvok = SvUOK(TOPs);
1559 if (!auvok && !buvok) { /* ## IV <= IV ## */
1560 IV aiv = SvIVX(TOPm1s);
1561 IV biv = SvIVX(TOPs);
1564 SETs(boolSV(aiv <= biv));
1567 if (auvok && buvok) { /* ## UV <= UV ## */
1568 UV auv = SvUVX(TOPm1s);
1569 UV buv = SvUVX(TOPs);
1572 SETs(boolSV(auv <= buv));
1575 if (auvok) { /* ## UV <= IV ## */
1582 /* As (a) is a UV, it's >=0, so a cannot be <= */
1587 if (auv > (UV) IV_MAX) {
1588 /* As (b) is an IV, it cannot be > IV_MAX */
1592 SETs(boolSV(auv <= (UV)biv));
1595 { /* ## IV <= UV ## */
1599 aiv = SvIVX(TOPm1s);
1601 /* As (b) is a UV, it's >=0, so a must be <= */
1608 if (buv >= (UV) IV_MAX) {
1609 /* As (a) is an IV, it cannot be > IV_MAX */
1613 SETs(boolSV((UV)aiv <= buv));
1621 SETs(boolSV(TOPn <= value));
1628 dSP; tryAMAGICbinSET(ge,0);
1629 #ifdef PERL_PRESERVE_IVUV
1632 SvIV_please(TOPm1s);
1633 if (SvIOK(TOPm1s)) {
1634 bool auvok = SvUOK(TOPm1s);
1635 bool buvok = SvUOK(TOPs);
1637 if (!auvok && !buvok) { /* ## IV >= IV ## */
1638 IV aiv = SvIVX(TOPm1s);
1639 IV biv = SvIVX(TOPs);
1642 SETs(boolSV(aiv >= biv));
1645 if (auvok && buvok) { /* ## UV >= UV ## */
1646 UV auv = SvUVX(TOPm1s);
1647 UV buv = SvUVX(TOPs);
1650 SETs(boolSV(auv >= buv));
1653 if (auvok) { /* ## UV >= IV ## */
1660 /* As (a) is a UV, it's >=0, so it must be >= */
1665 if (auv >= (UV) IV_MAX) {
1666 /* As (b) is an IV, it cannot be > IV_MAX */
1670 SETs(boolSV(auv >= (UV)biv));
1673 { /* ## IV >= UV ## */
1677 aiv = SvIVX(TOPm1s);
1679 /* As (b) is a UV, it's >=0, so a cannot be >= */
1686 if (buv > (UV) IV_MAX) {
1687 /* As (a) is an IV, it cannot be > IV_MAX */
1691 SETs(boolSV((UV)aiv >= buv));
1699 SETs(boolSV(TOPn >= value));
1706 dSP; tryAMAGICbinSET(ne,0);
1707 #ifdef PERL_PRESERVE_IVUV
1710 SvIV_please(TOPm1s);
1711 if (SvIOK(TOPm1s)) {
1712 bool auvok = SvUOK(TOPm1s);
1713 bool buvok = SvUOK(TOPs);
1715 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1716 IV aiv = SvIVX(TOPm1s);
1717 IV biv = SvIVX(TOPs);
1720 SETs(boolSV(aiv != biv));
1723 if (auvok && buvok) { /* ## UV != UV ## */
1724 UV auv = SvUVX(TOPm1s);
1725 UV buv = SvUVX(TOPs);
1728 SETs(boolSV(auv != buv));
1731 { /* ## Mixed IV,UV ## */
1735 /* != is commutative so swap if needed (save code) */
1737 /* swap. top of stack (b) is the iv */
1741 /* As (a) is a UV, it's >0, so it cannot be == */
1750 /* As (b) is a UV, it's >0, so it cannot be == */
1754 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1756 /* we know iv is >= 0 */
1757 if (uv > (UV) IV_MAX) {
1761 SETs(boolSV((UV)iv != uv));
1769 SETs(boolSV(TOPn != value));
1776 dSP; dTARGET; tryAMAGICbin(ncmp,0);
1777 #ifdef PERL_PRESERVE_IVUV
1778 /* Fortunately it seems NaN isn't IOK */
1781 SvIV_please(TOPm1s);
1782 if (SvIOK(TOPm1s)) {
1783 bool leftuvok = SvUOK(TOPm1s);
1784 bool rightuvok = SvUOK(TOPs);
1786 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1787 IV leftiv = SvIVX(TOPm1s);
1788 IV rightiv = SvIVX(TOPs);
1790 if (leftiv > rightiv)
1792 else if (leftiv < rightiv)
1796 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1797 UV leftuv = SvUVX(TOPm1s);
1798 UV rightuv = SvUVX(TOPs);
1800 if (leftuv > rightuv)
1802 else if (leftuv < rightuv)
1806 } else if (leftuvok) { /* ## UV <=> IV ## */
1810 rightiv = SvIVX(TOPs);
1812 /* As (a) is a UV, it's >=0, so it cannot be < */
1815 leftuv = SvUVX(TOPm1s);
1816 if (leftuv > (UV) IV_MAX) {
1817 /* As (b) is an IV, it cannot be > IV_MAX */
1819 } else if (leftuv > (UV)rightiv) {
1821 } else if (leftuv < (UV)rightiv) {
1827 } else { /* ## IV <=> UV ## */
1831 leftiv = SvIVX(TOPm1s);
1833 /* As (b) is a UV, it's >=0, so it must be < */
1836 rightuv = SvUVX(TOPs);
1837 if (rightuv > (UV) IV_MAX) {
1838 /* As (a) is an IV, it cannot be > IV_MAX */
1840 } else if (leftiv > (UV)rightuv) {
1842 } else if (leftiv < (UV)rightuv) {
1860 if (Perl_isnan(left) || Perl_isnan(right)) {
1864 value = (left > right) - (left < right);
1868 else if (left < right)
1870 else if (left > right)
1884 dSP; tryAMAGICbinSET(slt,0);
1887 int cmp = ((PL_op->op_private & OPpLOCALE)
1888 ? sv_cmp_locale(left, right)
1889 : sv_cmp(left, right));
1890 SETs(boolSV(cmp < 0));
1897 dSP; tryAMAGICbinSET(sgt,0);
1900 int cmp = ((PL_op->op_private & OPpLOCALE)
1901 ? sv_cmp_locale(left, right)
1902 : sv_cmp(left, right));
1903 SETs(boolSV(cmp > 0));
1910 dSP; tryAMAGICbinSET(sle,0);
1913 int cmp = ((PL_op->op_private & OPpLOCALE)
1914 ? sv_cmp_locale(left, right)
1915 : sv_cmp(left, right));
1916 SETs(boolSV(cmp <= 0));
1923 dSP; tryAMAGICbinSET(sge,0);
1926 int cmp = ((PL_op->op_private & OPpLOCALE)
1927 ? sv_cmp_locale(left, right)
1928 : sv_cmp(left, right));
1929 SETs(boolSV(cmp >= 0));
1936 dSP; tryAMAGICbinSET(seq,0);
1939 SETs(boolSV(sv_eq(left, right)));
1946 dSP; tryAMAGICbinSET(sne,0);
1949 SETs(boolSV(!sv_eq(left, right)));
1956 dSP; dTARGET; tryAMAGICbin(scmp,0);
1959 int cmp = ((PL_op->op_private & OPpLOCALE)
1960 ? sv_cmp_locale(left, right)
1961 : sv_cmp(left, right));
1969 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1972 if (SvNIOKp(left) || SvNIOKp(right)) {
1973 if (PL_op->op_private & HINT_INTEGER) {
1974 IV i = SvIV(left) & SvIV(right);
1978 UV u = SvUV(left) & SvUV(right);
1983 do_vop(PL_op->op_type, TARG, left, right);
1992 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1995 if (SvNIOKp(left) || SvNIOKp(right)) {
1996 if (PL_op->op_private & HINT_INTEGER) {
1997 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2001 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2006 do_vop(PL_op->op_type, TARG, left, right);
2015 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2018 if (SvNIOKp(left) || SvNIOKp(right)) {
2019 if (PL_op->op_private & HINT_INTEGER) {
2020 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2024 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2029 do_vop(PL_op->op_type, TARG, left, right);
2038 dSP; dTARGET; tryAMAGICun(neg);
2041 int flags = SvFLAGS(sv);
2044 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2045 /* It's publicly an integer, or privately an integer-not-float */
2048 if (SvIVX(sv) == IV_MIN) {
2049 /* 2s complement assumption. */
2050 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2053 else if (SvUVX(sv) <= IV_MAX) {
2058 else if (SvIVX(sv) != IV_MIN) {
2062 #ifdef PERL_PRESERVE_IVUV
2071 else if (SvPOKp(sv)) {
2073 char *s = SvPV(sv, len);
2074 if (isIDFIRST(*s)) {
2075 sv_setpvn(TARG, "-", 1);
2078 else if (*s == '+' || *s == '-') {
2080 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2082 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
2083 sv_setpvn(TARG, "-", 1);
2089 goto oops_its_an_int;
2090 sv_setnv(TARG, -SvNV(sv));
2102 dSP; tryAMAGICunSET(not);
2103 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2109 dSP; dTARGET; tryAMAGICun(compl);
2113 if (PL_op->op_private & HINT_INTEGER) {
2128 tmps = (U8*)SvPV_force(TARG, len);
2131 /* Calculate exact length, let's not estimate. */
2140 while (tmps < send) {
2141 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2142 tmps += UTF8SKIP(tmps);
2143 targlen += UNISKIP(~c);
2149 /* Now rewind strings and write them. */
2153 Newz(0, result, targlen + 1, U8);
2154 while (tmps < send) {
2155 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2156 tmps += UTF8SKIP(tmps);
2157 result = uvchr_to_utf8(result, ~c);
2161 sv_setpvn(TARG, (char*)result, targlen);
2165 Newz(0, result, nchar + 1, U8);
2166 while (tmps < send) {
2167 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2168 tmps += UTF8SKIP(tmps);
2173 sv_setpvn(TARG, (char*)result, nchar);
2181 register long *tmpl;
2182 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2185 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2190 for ( ; anum > 0; anum--, tmps++)
2199 /* integer versions of some of the above */
2203 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2206 SETi( left * right );
2213 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2217 DIE(aTHX_ "Illegal division by zero");
2218 value = POPi / value;
2226 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2230 DIE(aTHX_ "Illegal modulus zero");
2231 SETi( left % right );
2238 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2241 SETi( left + right );
2248 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2251 SETi( left - right );
2258 dSP; tryAMAGICbinSET(lt,0);
2261 SETs(boolSV(left < right));
2268 dSP; tryAMAGICbinSET(gt,0);
2271 SETs(boolSV(left > right));
2278 dSP; tryAMAGICbinSET(le,0);
2281 SETs(boolSV(left <= right));
2288 dSP; tryAMAGICbinSET(ge,0);
2291 SETs(boolSV(left >= right));
2298 dSP; tryAMAGICbinSET(eq,0);
2301 SETs(boolSV(left == right));
2308 dSP; tryAMAGICbinSET(ne,0);
2311 SETs(boolSV(left != right));
2318 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2325 else if (left < right)
2336 dSP; dTARGET; tryAMAGICun(neg);
2341 /* High falutin' math. */
2345 dSP; dTARGET; tryAMAGICbin(atan2,0);
2348 SETn(Perl_atan2(left, right));
2355 dSP; dTARGET; tryAMAGICun(sin);
2359 value = Perl_sin(value);
2367 dSP; dTARGET; tryAMAGICun(cos);
2371 value = Perl_cos(value);
2377 /* Support Configure command-line overrides for rand() functions.
2378 After 5.005, perhaps we should replace this by Configure support
2379 for drand48(), random(), or rand(). For 5.005, though, maintain
2380 compatibility by calling rand() but allow the user to override it.
2381 See INSTALL for details. --Andy Dougherty 15 July 1998
2383 /* Now it's after 5.005, and Configure supports drand48() and random(),
2384 in addition to rand(). So the overrides should not be needed any more.
2385 --Jarkko Hietaniemi 27 September 1998
2388 #ifndef HAS_DRAND48_PROTO
2389 extern double drand48 (void);
2402 if (!PL_srand_called) {
2403 (void)seedDrand01((Rand_seed_t)seed());
2404 PL_srand_called = TRUE;
2419 (void)seedDrand01((Rand_seed_t)anum);
2420 PL_srand_called = TRUE;
2429 * This is really just a quick hack which grabs various garbage
2430 * values. It really should be a real hash algorithm which
2431 * spreads the effect of every input bit onto every output bit,
2432 * if someone who knows about such things would bother to write it.
2433 * Might be a good idea to add that function to CORE as well.
2434 * No numbers below come from careful analysis or anything here,
2435 * except they are primes and SEED_C1 > 1E6 to get a full-width
2436 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2437 * probably be bigger too.
2440 # define SEED_C1 1000003
2441 #define SEED_C4 73819
2443 # define SEED_C1 25747
2444 #define SEED_C4 20639
2448 #define SEED_C5 26107
2450 #ifndef PERL_NO_DEV_RANDOM
2455 # include <starlet.h>
2456 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2457 * in 100-ns units, typically incremented ever 10 ms. */
2458 unsigned int when[2];
2460 # ifdef HAS_GETTIMEOFDAY
2461 struct timeval when;
2467 /* This test is an escape hatch, this symbol isn't set by Configure. */
2468 #ifndef PERL_NO_DEV_RANDOM
2469 #ifndef PERL_RANDOM_DEVICE
2470 /* /dev/random isn't used by default because reads from it will block
2471 * if there isn't enough entropy available. You can compile with
2472 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2473 * is enough real entropy to fill the seed. */
2474 # define PERL_RANDOM_DEVICE "/dev/urandom"
2476 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2478 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2487 _ckvmssts(sys$gettim(when));
2488 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
2490 # ifdef HAS_GETTIMEOFDAY
2491 gettimeofday(&when,(struct timezone *) 0);
2492 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
2495 u = (U32)SEED_C1 * when;
2498 u += SEED_C3 * (U32)PerlProc_getpid();
2499 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
2500 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
2501 u += SEED_C5 * (U32)PTR2UV(&when);
2508 dSP; dTARGET; tryAMAGICun(exp);
2512 value = Perl_exp(value);
2520 dSP; dTARGET; tryAMAGICun(log);
2525 SET_NUMERIC_STANDARD();
2526 DIE(aTHX_ "Can't take log of %g", value);
2528 value = Perl_log(value);
2536 dSP; dTARGET; tryAMAGICun(sqrt);
2541 SET_NUMERIC_STANDARD();
2542 DIE(aTHX_ "Can't take sqrt of %g", value);
2544 value = Perl_sqrt(value);
2552 dSP; dTARGET; tryAMAGICun(int);
2555 IV iv = TOPi; /* attempt to convert to IV if possible. */
2556 /* XXX it's arguable that compiler casting to IV might be subtly
2557 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2558 else preferring IV has introduced a subtle behaviour change bug. OTOH
2559 relying on floating point to be accurate is a bug. */
2570 if (value < (NV)UV_MAX + 0.5) {
2573 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2574 (void)Perl_modf(value, &value);
2576 double tmp = (double)value;
2577 (void)Perl_modf(tmp, &tmp);
2584 if (value > (NV)IV_MIN - 0.5) {
2587 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2588 (void)Perl_modf(-value, &value);
2591 double tmp = (double)value;
2592 (void)Perl_modf(-tmp, &tmp);
2605 dSP; dTARGET; tryAMAGICun(abs);
2607 /* This will cache the NV value if string isn't actually integer */
2611 /* IVX is precise */
2613 SETu(TOPu); /* force it to be numeric only */
2621 /* 2s complement assumption. Also, not really needed as
2622 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2645 argtype = 1; /* allow underscores */
2646 XPUSHn(scan_hex(tmps, 99, &argtype));
2659 while (*tmps && isSPACE(*tmps))
2663 argtype = 1; /* allow underscores */
2665 value = scan_hex(++tmps, 99, &argtype);
2666 else if (*tmps == 'b')
2667 value = scan_bin(++tmps, 99, &argtype);
2669 value = scan_oct(tmps, 99, &argtype);
2682 SETi(sv_len_utf8(sv));
2698 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2700 I32 arybase = PL_curcop->cop_arybase;
2702 SV *repl_sv_copy = NULL;
2705 int num_args = PL_op->op_private & 7;
2706 bool repl_is_utf8 = FALSE;
2708 SvTAINTED_off(TARG); /* decontaminate */
2709 SvUTF8_off(TARG); /* decontaminate */
2713 repl = SvPV(repl_sv, repl_len);
2714 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2724 sv_utf8_upgrade(sv);
2726 else if (DO_UTF8(sv)) {
2727 repl_sv_copy = newSVsv(repl_sv);
2728 sv_utf8_upgrade(repl_sv_copy);
2729 repl = SvPV(repl_sv_copy, repl_len);
2730 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2733 tmps = SvPV(sv, curlen);
2735 utf8_curlen = sv_len_utf8(sv);
2736 if (utf8_curlen == curlen)
2739 curlen = utf8_curlen;
2744 if (pos >= arybase) {
2762 else if (len >= 0) {
2764 if (rem > (I32)curlen)
2779 Perl_croak(aTHX_ "substr outside of string");
2780 if (ckWARN(WARN_SUBSTR))
2781 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2788 sv_pos_u2b(sv, &pos, &rem);
2790 sv_setpvn(TARG, tmps, rem);
2794 sv_insert(sv, pos, rem, repl, repl_len);
2798 SvREFCNT_dec(repl_sv_copy);
2800 else if (lvalue) { /* it's an lvalue! */
2801 if (!SvGMAGICAL(sv)) {
2805 if (ckWARN(WARN_SUBSTR))
2806 Perl_warner(aTHX_ WARN_SUBSTR,
2807 "Attempt to use reference as lvalue in substr");
2809 if (SvOK(sv)) /* is it defined ? */
2810 (void)SvPOK_only_UTF8(sv);
2812 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2815 if (SvTYPE(TARG) < SVt_PVLV) {
2816 sv_upgrade(TARG, SVt_PVLV);
2817 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2821 if (LvTARG(TARG) != sv) {
2823 SvREFCNT_dec(LvTARG(TARG));
2824 LvTARG(TARG) = SvREFCNT_inc(sv);
2826 LvTARGOFF(TARG) = upos;
2827 LvTARGLEN(TARG) = urem;
2831 PUSHs(TARG); /* avoid SvSETMAGIC here */
2838 register IV size = POPi;
2839 register IV offset = POPi;
2840 register SV *src = POPs;
2841 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2843 SvTAINTED_off(TARG); /* decontaminate */
2844 if (lvalue) { /* it's an lvalue! */
2845 if (SvTYPE(TARG) < SVt_PVLV) {
2846 sv_upgrade(TARG, SVt_PVLV);
2847 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2850 if (LvTARG(TARG) != src) {
2852 SvREFCNT_dec(LvTARG(TARG));
2853 LvTARG(TARG) = SvREFCNT_inc(src);
2855 LvTARGOFF(TARG) = offset;
2856 LvTARGLEN(TARG) = size;
2859 sv_setuv(TARG, do_vecget(src, offset, size));
2874 I32 arybase = PL_curcop->cop_arybase;
2879 offset = POPi - arybase;
2882 tmps = SvPV(big, biglen);
2883 if (offset > 0 && DO_UTF8(big))
2884 sv_pos_u2b(big, &offset, 0);
2887 else if (offset > biglen)
2889 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2890 (unsigned char*)tmps + biglen, little, 0)))
2893 retval = tmps2 - tmps;
2894 if (retval > 0 && DO_UTF8(big))
2895 sv_pos_b2u(big, &retval);
2896 PUSHi(retval + arybase);
2911 I32 arybase = PL_curcop->cop_arybase;
2917 tmps2 = SvPV(little, llen);
2918 tmps = SvPV(big, blen);
2922 if (offset > 0 && DO_UTF8(big))
2923 sv_pos_u2b(big, &offset, 0);
2924 offset = offset - arybase + llen;
2928 else if (offset > blen)
2930 if (!(tmps2 = rninstr(tmps, tmps + offset,
2931 tmps2, tmps2 + llen)))
2934 retval = tmps2 - tmps;
2935 if (retval > 0 && DO_UTF8(big))
2936 sv_pos_b2u(big, &retval);
2937 PUSHi(retval + arybase);
2943 dSP; dMARK; dORIGMARK; dTARGET;
2944 do_sprintf(TARG, SP-MARK, MARK+1);
2945 TAINT_IF(SvTAINTED(TARG));
2956 U8 *s = (U8*)SvPVx(argsv, len);
2958 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
2968 (void)SvUPGRADE(TARG,SVt_PV);
2970 if (value > 255 && !IN_BYTE) {
2971 SvGROW(TARG, UNISKIP(value)+1);
2972 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
2973 SvCUR_set(TARG, tmps - SvPVX(TARG));
2975 (void)SvPOK_only(TARG);
2986 (void)SvPOK_only(TARG);
2993 dSP; dTARGET; dPOPTOPssrl;
2996 char *tmps = SvPV(left, n_a);
2998 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3000 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3004 "The crypt() function is unimplemented due to excessive paranoia.");
3017 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3019 U8 tmpbuf[UTF8_MAXLEN+1];
3023 if (PL_op->op_private & OPpLOCALE) {
3026 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3029 uv = toTITLE_utf8(s);
3031 tend = uvchr_to_utf8(tmpbuf, uv);
3033 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3035 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3036 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3041 s = (U8*)SvPV_force(sv, slen);
3042 Copy(tmpbuf, s, ulen, U8);
3046 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3048 SvUTF8_off(TARG); /* decontaminate */
3053 s = (U8*)SvPV_force(sv, slen);
3055 if (PL_op->op_private & OPpLOCALE) {
3058 *s = toUPPER_LC(*s);
3076 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
3078 U8 tmpbuf[UTF8_MAXLEN+1];
3082 if (PL_op->op_private & OPpLOCALE) {
3085 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
3088 uv = toLOWER_utf8(s);
3090 tend = uvchr_to_utf8(tmpbuf, uv);
3092 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
3094 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3095 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3100 s = (U8*)SvPV_force(sv, slen);
3101 Copy(tmpbuf, s, ulen, U8);
3105 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3107 SvUTF8_off(TARG); /* decontaminate */
3112 s = (U8*)SvPV_force(sv, slen);
3114 if (PL_op->op_private & OPpLOCALE) {
3117 *s = toLOWER_LC(*s);
3141 s = (U8*)SvPV(sv,len);
3143 SvUTF8_off(TARG); /* decontaminate */
3144 sv_setpvn(TARG, "", 0);
3148 (void)SvUPGRADE(TARG, SVt_PV);
3149 SvGROW(TARG, (len * 2) + 1);
3150 (void)SvPOK_only(TARG);
3151 d = (U8*)SvPVX(TARG);
3153 if (PL_op->op_private & OPpLOCALE) {
3157 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3163 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
3169 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3174 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3176 SvUTF8_off(TARG); /* decontaminate */
3181 s = (U8*)SvPV_force(sv, len);
3183 register U8 *send = s + len;
3185 if (PL_op->op_private & OPpLOCALE) {
3188 for (; s < send; s++)
3189 *s = toUPPER_LC(*s);
3192 for (; s < send; s++)
3215 s = (U8*)SvPV(sv,len);
3217 SvUTF8_off(TARG); /* decontaminate */
3218 sv_setpvn(TARG, "", 0);
3222 (void)SvUPGRADE(TARG, SVt_PV);
3223 SvGROW(TARG, (len * 2) + 1);
3224 (void)SvPOK_only(TARG);
3225 d = (U8*)SvPVX(TARG);
3227 if (PL_op->op_private & OPpLOCALE) {
3231 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
3237 d = uvchr_to_utf8(d, toLOWER_utf8(s));
3243 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3248 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3250 SvUTF8_off(TARG); /* decontaminate */
3256 s = (U8*)SvPV_force(sv, len);
3258 register U8 *send = s + len;
3260 if (PL_op->op_private & OPpLOCALE) {
3263 for (; s < send; s++)
3264 *s = toLOWER_LC(*s);
3267 for (; s < send; s++)
3282 register char *s = SvPV(sv,len);
3285 SvUTF8_off(TARG); /* decontaminate */
3287 (void)SvUPGRADE(TARG, SVt_PV);
3288 SvGROW(TARG, (len * 2) + 1);
3292 if (UTF8_IS_CONTINUED(*s)) {
3293 STRLEN ulen = UTF8SKIP(s);
3317 SvCUR_set(TARG, d - SvPVX(TARG));
3318 (void)SvPOK_only_UTF8(TARG);
3321 sv_setpvn(TARG, s, len);
3323 if (SvSMAGICAL(TARG))
3332 dSP; dMARK; dORIGMARK;
3334 register AV* av = (AV*)POPs;
3335 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3336 I32 arybase = PL_curcop->cop_arybase;
3339 if (SvTYPE(av) == SVt_PVAV) {
3340 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3342 for (svp = MARK + 1; svp <= SP; svp++) {
3347 if (max > AvMAX(av))
3350 while (++MARK <= SP) {
3351 elem = SvIVx(*MARK);
3355 svp = av_fetch(av, elem, lval);
3357 if (!svp || *svp == &PL_sv_undef)
3358 DIE(aTHX_ PL_no_aelem, elem);
3359 if (PL_op->op_private & OPpLVAL_INTRO)
3360 save_aelem(av, elem, svp);
3362 *MARK = svp ? *svp : &PL_sv_undef;
3365 if (GIMME != G_ARRAY) {
3373 /* Associative arrays. */
3378 HV *hash = (HV*)POPs;
3380 I32 gimme = GIMME_V;
3381 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3384 /* might clobber stack_sp */
3385 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3390 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3391 if (gimme == G_ARRAY) {
3394 /* might clobber stack_sp */
3396 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3401 else if (gimme == G_SCALAR)
3420 I32 gimme = GIMME_V;
3421 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3425 if (PL_op->op_private & OPpSLICE) {
3429 hvtype = SvTYPE(hv);
3430 if (hvtype == SVt_PVHV) { /* hash element */
3431 while (++MARK <= SP) {
3432 sv = hv_delete_ent(hv, *MARK, discard, 0);
3433 *MARK = sv ? sv : &PL_sv_undef;
3436 else if (hvtype == SVt_PVAV) {
3437 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3438 while (++MARK <= SP) {
3439 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3440 *MARK = sv ? sv : &PL_sv_undef;
3443 else { /* pseudo-hash element */
3444 while (++MARK <= SP) {
3445 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3446 *MARK = sv ? sv : &PL_sv_undef;
3451 DIE(aTHX_ "Not a HASH reference");
3454 else if (gimme == G_SCALAR) {
3463 if (SvTYPE(hv) == SVt_PVHV)
3464 sv = hv_delete_ent(hv, keysv, discard, 0);
3465 else if (SvTYPE(hv) == SVt_PVAV) {
3466 if (PL_op->op_flags & OPf_SPECIAL)
3467 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3469 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3472 DIE(aTHX_ "Not a HASH reference");
3487 if (PL_op->op_private & OPpEXISTS_SUB) {
3491 cv = sv_2cv(sv, &hv, &gv, FALSE);
3494 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3500 if (SvTYPE(hv) == SVt_PVHV) {
3501 if (hv_exists_ent(hv, tmpsv, 0))
3504 else if (SvTYPE(hv) == SVt_PVAV) {
3505 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3506 if (av_exists((AV*)hv, SvIV(tmpsv)))
3509 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3513 DIE(aTHX_ "Not a HASH reference");
3520 dSP; dMARK; dORIGMARK;
3521 register HV *hv = (HV*)POPs;
3522 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3523 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3525 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
3526 DIE(aTHX_ "Can't localize pseudo-hash element");
3528 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3529 while (++MARK <= SP) {
3532 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
3534 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3535 svp = he ? &HeVAL(he) : 0;
3538 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3541 if (!svp || *svp == &PL_sv_undef) {
3543 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3545 if (PL_op->op_private & OPpLVAL_INTRO) {
3547 save_helem(hv, keysv, svp);
3550 char *key = SvPV(keysv, keylen);
3551 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3555 *MARK = svp ? *svp : &PL_sv_undef;
3558 if (GIMME != G_ARRAY) {
3566 /* List operators. */
3571 if (GIMME != G_ARRAY) {
3573 *MARK = *SP; /* unwanted list, return last item */
3575 *MARK = &PL_sv_undef;
3584 SV **lastrelem = PL_stack_sp;
3585 SV **lastlelem = PL_stack_base + POPMARK;
3586 SV **firstlelem = PL_stack_base + POPMARK + 1;
3587 register SV **firstrelem = lastlelem + 1;
3588 I32 arybase = PL_curcop->cop_arybase;
3589 I32 lval = PL_op->op_flags & OPf_MOD;
3590 I32 is_something_there = lval;
3592 register I32 max = lastrelem - lastlelem;
3593 register SV **lelem;
3596 if (GIMME != G_ARRAY) {
3597 ix = SvIVx(*lastlelem);
3602 if (ix < 0 || ix >= max)
3603 *firstlelem = &PL_sv_undef;
3605 *firstlelem = firstrelem[ix];
3611 SP = firstlelem - 1;
3615 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3621 if (ix < 0 || ix >= max)
3622 *lelem = &PL_sv_undef;
3624 is_something_there = TRUE;
3625 if (!(*lelem = firstrelem[ix]))
3626 *lelem = &PL_sv_undef;
3629 if (is_something_there)
3632 SP = firstlelem - 1;
3638 dSP; dMARK; dORIGMARK;
3639 I32 items = SP - MARK;
3640 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3641 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3648 dSP; dMARK; dORIGMARK;
3649 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3653 SV *val = NEWSV(46, 0);
3655 sv_setsv(val, *++MARK);
3656 else if (ckWARN(WARN_MISC))
3657 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
3658 (void)hv_store_ent(hv,key,val,0);
3667 dSP; dMARK; dORIGMARK;
3668 register AV *ary = (AV*)*++MARK;
3672 register I32 offset;
3673 register I32 length;
3680 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3681 *MARK-- = SvTIED_obj((SV*)ary, mg);
3685 call_method("SPLICE",GIMME_V);
3694 offset = i = SvIVx(*MARK);
3696 offset += AvFILLp(ary) + 1;
3698 offset -= PL_curcop->cop_arybase;
3700 DIE(aTHX_ PL_no_aelem, i);
3702 length = SvIVx(*MARK++);
3704 length += AvFILLp(ary) - offset + 1;
3710 length = AvMAX(ary) + 1; /* close enough to infinity */
3714 length = AvMAX(ary) + 1;
3716 if (offset > AvFILLp(ary) + 1)
3717 offset = AvFILLp(ary) + 1;
3718 after = AvFILLp(ary) + 1 - (offset + length);
3719 if (after < 0) { /* not that much array */
3720 length += after; /* offset+length now in array */
3726 /* At this point, MARK .. SP-1 is our new LIST */
3729 diff = newlen - length;
3730 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3733 if (diff < 0) { /* shrinking the area */
3735 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3736 Copy(MARK, tmparyval, newlen, SV*);
3739 MARK = ORIGMARK + 1;
3740 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3741 MEXTEND(MARK, length);
3742 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3744 EXTEND_MORTAL(length);
3745 for (i = length, dst = MARK; i; i--) {
3746 sv_2mortal(*dst); /* free them eventualy */
3753 *MARK = AvARRAY(ary)[offset+length-1];
3756 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3757 SvREFCNT_dec(*dst++); /* free them now */
3760 AvFILLp(ary) += diff;
3762 /* pull up or down? */
3764 if (offset < after) { /* easier to pull up */
3765 if (offset) { /* esp. if nothing to pull */
3766 src = &AvARRAY(ary)[offset-1];
3767 dst = src - diff; /* diff is negative */
3768 for (i = offset; i > 0; i--) /* can't trust Copy */
3772 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3776 if (after) { /* anything to pull down? */
3777 src = AvARRAY(ary) + offset + length;
3778 dst = src + diff; /* diff is negative */
3779 Move(src, dst, after, SV*);
3781 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3782 /* avoid later double free */
3786 dst[--i] = &PL_sv_undef;
3789 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3791 *dst = NEWSV(46, 0);
3792 sv_setsv(*dst++, *src++);
3794 Safefree(tmparyval);
3797 else { /* no, expanding (or same) */
3799 New(452, tmparyval, length, SV*); /* so remember deletion */
3800 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3803 if (diff > 0) { /* expanding */
3805 /* push up or down? */
3807 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3811 Move(src, dst, offset, SV*);
3813 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3815 AvFILLp(ary) += diff;
3818 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3819 av_extend(ary, AvFILLp(ary) + diff);
3820 AvFILLp(ary) += diff;
3823 dst = AvARRAY(ary) + AvFILLp(ary);
3825 for (i = after; i; i--) {
3832 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3833 *dst = NEWSV(46, 0);
3834 sv_setsv(*dst++, *src++);
3836 MARK = ORIGMARK + 1;
3837 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3839 Copy(tmparyval, MARK, length, SV*);
3841 EXTEND_MORTAL(length);
3842 for (i = length, dst = MARK; i; i--) {
3843 sv_2mortal(*dst); /* free them eventualy */
3847 Safefree(tmparyval);
3851 else if (length--) {
3852 *MARK = tmparyval[length];
3855 while (length-- > 0)
3856 SvREFCNT_dec(tmparyval[length]);
3858 Safefree(tmparyval);
3861 *MARK = &PL_sv_undef;
3869 dSP; dMARK; dORIGMARK; dTARGET;
3870 register AV *ary = (AV*)*++MARK;
3871 register SV *sv = &PL_sv_undef;
3874 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3875 *MARK-- = SvTIED_obj((SV*)ary, mg);
3879 call_method("PUSH",G_SCALAR|G_DISCARD);
3884 /* Why no pre-extend of ary here ? */
3885 for (++MARK; MARK <= SP; MARK++) {
3888 sv_setsv(sv, *MARK);
3893 PUSHi( AvFILL(ary) + 1 );
3901 SV *sv = av_pop(av);
3903 (void)sv_2mortal(sv);
3912 SV *sv = av_shift(av);
3917 (void)sv_2mortal(sv);
3924 dSP; dMARK; dORIGMARK; dTARGET;
3925 register AV *ary = (AV*)*++MARK;
3930 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3931 *MARK-- = SvTIED_obj((SV*)ary, mg);
3935 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3940 av_unshift(ary, SP - MARK);
3943 sv_setsv(sv, *++MARK);
3944 (void)av_store(ary, i++, sv);
3948 PUSHi( AvFILL(ary) + 1 );
3958 if (GIMME == G_ARRAY) {
3965 /* safe as long as stack cannot get extended in the above */
3970 register char *down;
3975 SvUTF8_off(TARG); /* decontaminate */
3977 do_join(TARG, &PL_sv_no, MARK, SP);
3979 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3980 up = SvPV_force(TARG, len);
3982 if (DO_UTF8(TARG)) { /* first reverse each character */
3983 U8* s = (U8*)SvPVX(TARG);
3984 U8* send = (U8*)(s + len);
3986 if (UTF8_IS_INVARIANT(*s)) {
3991 if (!utf8_to_uvchr(s, 0))
3995 down = (char*)(s - 1);
3996 /* reverse this character */
4006 down = SvPVX(TARG) + len - 1;
4012 (void)SvPOK_only_UTF8(TARG);
4021 S_mul128(pTHX_ SV *sv, U8 m)
4024 char *s = SvPV(sv, len);
4028 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
4029 SV *tmpNew = newSVpvn("0000000000", 10);
4031 sv_catsv(tmpNew, sv);
4032 SvREFCNT_dec(sv); /* free old sv */
4037 while (!*t) /* trailing '\0'? */
4040 i = ((*t - '0') << 7) + m;
4041 *(t--) = '0' + (i % 10);
4047 /* Explosives and implosives. */
4049 #if 'I' == 73 && 'J' == 74
4050 /* On an ASCII/ISO kind of system */
4051 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
4054 Some other sort of character set - use memchr() so we don't match
4057 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
4065 I32 start_sp_offset = SP - PL_stack_base;
4066 I32 gimme = GIMME_V;
4070 register char *pat = SvPV(left, llen);
4071 #ifdef PACKED_IS_OCTETS
4072 /* Packed side is assumed to be octets - so force downgrade if it
4073 has been UTF-8 encoded by accident
4075 register char *s = SvPVbyte(right, rlen);
4077 register char *s = SvPV(right, rlen);
4079 char *strend = s + rlen;
4081 register char *patend = pat + llen;
4087 /* These must not be in registers: */
4104 register U32 culong;
4108 #ifdef PERL_NATINT_PACK
4109 int natint; /* native integer */
4110 int unatint; /* unsigned native integer */
4113 if (gimme != G_ARRAY) { /* arrange to do first one only */
4115 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
4116 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
4118 while (isDIGIT(*patend) || *patend == '*')
4124 while (pat < patend) {
4126 datumtype = *pat++ & 0xFF;
4127 #ifdef PERL_NATINT_PACK
4130 if (isSPACE(datumtype))
4132 if (datumtype == '#') {
4133 while (pat < patend && *pat != '\n')
4138 char *natstr = "sSiIlL";
4140 if (strchr(natstr, datumtype)) {
4141 #ifdef PERL_NATINT_PACK
4147 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4152 else if (*pat == '*') {
4153 len = strend - strbeg; /* long enough */
4157 else if (isDIGIT(*pat)) {
4159 while (isDIGIT(*pat)) {
4160 len = (len * 10) + (*pat++ - '0');
4162 DIE(aTHX_ "Repeat count in unpack overflows");
4166 len = (datumtype != '@');
4170 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
4171 case ',': /* grandfather in commas but with a warning */
4172 if (commas++ == 0 && ckWARN(WARN_UNPACK))
4173 Perl_warner(aTHX_ WARN_UNPACK,
4174 "Invalid type in unpack: '%c'", (int)datumtype);
4177 if (len == 1 && pat[-1] != '1')
4186 if (len > strend - strbeg)
4187 DIE(aTHX_ "@ outside of string");
4191 if (len > s - strbeg)
4192 DIE(aTHX_ "X outside of string");
4196 if (len > strend - s)
4197 DIE(aTHX_ "x outside of string");
4201 if (start_sp_offset >= SP - PL_stack_base)
4202 DIE(aTHX_ "/ must follow a numeric type");
4205 pat++; /* ignore '*' for compatibility with pack */
4207 DIE(aTHX_ "/ cannot take a count" );
4214 if (len > strend - s)
4217 goto uchar_checksum;
4218 sv = NEWSV(35, len);
4219 sv_setpvn(sv, s, len);
4221 if (datumtype == 'A' || datumtype == 'Z') {
4222 aptr = s; /* borrow register */
4223 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
4228 else { /* 'A' strips both nulls and spaces */
4229 s = SvPVX(sv) + len - 1;
4230 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
4234 SvCUR_set(sv, s - SvPVX(sv));
4235 s = aptr; /* unborrow register */
4237 XPUSHs(sv_2mortal(sv));
4241 if (star || len > (strend - s) * 8)
4242 len = (strend - s) * 8;
4245 Newz(601, PL_bitcount, 256, char);
4246 for (bits = 1; bits < 256; bits++) {
4247 if (bits & 1) PL_bitcount[bits]++;
4248 if (bits & 2) PL_bitcount[bits]++;
4249 if (bits & 4) PL_bitcount[bits]++;
4250 if (bits & 8) PL_bitcount[bits]++;
4251 if (bits & 16) PL_bitcount[bits]++;
4252 if (bits & 32) PL_bitcount[bits]++;
4253 if (bits & 64) PL_bitcount[bits]++;
4254 if (bits & 128) PL_bitcount[bits]++;
4258 culong += PL_bitcount[*(unsigned char*)s++];
4263 if (datumtype == 'b') {
4265 if (bits & 1) culong++;
4271 if (bits & 128) culong++;
4278 sv = NEWSV(35, len + 1);
4282 if (datumtype == 'b') {
4284 for (len = 0; len < aint; len++) {
4285 if (len & 7) /*SUPPRESS 595*/
4289 *str++ = '0' + (bits & 1);
4294 for (len = 0; len < aint; len++) {
4299 *str++ = '0' + ((bits & 128) != 0);
4303 XPUSHs(sv_2mortal(sv));
4307 if (star || len > (strend - s) * 2)
4308 len = (strend - s) * 2;
4309 sv = NEWSV(35, len + 1);
4313 if (datumtype == 'h') {
4315 for (len = 0; len < aint; len++) {
4320 *str++ = PL_hexdigit[bits & 15];
4325 for (len = 0; len < aint; len++) {
4330 *str++ = PL_hexdigit[(bits >> 4) & 15];
4334 XPUSHs(sv_2mortal(sv));
4337 if (len > strend - s)
4342 if (aint >= 128) /* fake up signed chars */
4352 if (aint >= 128) /* fake up signed chars */
4355 sv_setiv(sv, (IV)aint);
4356 PUSHs(sv_2mortal(sv));
4361 if (len > strend - s)
4376 sv_setiv(sv, (IV)auint);
4377 PUSHs(sv_2mortal(sv));
4382 if (len > strend - s)
4385 while (len-- > 0 && s < strend) {
4387 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4391 cdouble += (NV)auint;
4399 while (len-- > 0 && s < strend) {
4401 auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
4405 sv_setuv(sv, (UV)auint);
4406 PUSHs(sv_2mortal(sv));
4411 #if SHORTSIZE == SIZE16
4412 along = (strend - s) / SIZE16;
4414 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
4419 #if SHORTSIZE != SIZE16
4423 COPYNN(s, &ashort, sizeof(short));
4434 #if SHORTSIZE > SIZE16
4446 #if SHORTSIZE != SIZE16
4450 COPYNN(s, &ashort, sizeof(short));
4453 sv_setiv(sv, (IV)ashort);
4454 PUSHs(sv_2mortal(sv));
4462 #if SHORTSIZE > SIZE16
4468 sv_setiv(sv, (IV)ashort);
4469 PUSHs(sv_2mortal(sv));
4477 #if SHORTSIZE == SIZE16
4478 along = (strend - s) / SIZE16;
4480 unatint = natint && datumtype == 'S';
4481 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
4486 #if SHORTSIZE != SIZE16
4488 unsigned short aushort;
4490 COPYNN(s, &aushort, sizeof(unsigned short));
4491 s += sizeof(unsigned short);
4499 COPY16(s, &aushort);
4502 if (datumtype == 'n')
4503 aushort = PerlSock_ntohs(aushort);
4506 if (datumtype == 'v')
4507 aushort = vtohs(aushort);
4516 #if SHORTSIZE != SIZE16
4518 unsigned short aushort;
4520 COPYNN(s, &aushort, sizeof(unsigned short));
4521 s += sizeof(unsigned short);
4523 sv_setiv(sv, (UV)aushort);
4524 PUSHs(sv_2mortal(sv));
4531 COPY16(s, &aushort);
4535 if (datumtype == 'n')
4536 aushort = PerlSock_ntohs(aushort);
4539 if (datumtype == 'v')
4540 aushort = vtohs(aushort);
4542 sv_setiv(sv, (UV)aushort);
4543 PUSHs(sv_2mortal(sv));
4549 along = (strend - s) / sizeof(int);
4554 Copy(s, &aint, 1, int);
4557 cdouble += (NV)aint;
4566 Copy(s, &aint, 1, int);
4570 /* Without the dummy below unpack("i", pack("i",-1))
4571 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
4572 * cc with optimization turned on.
4574 * The bug was detected in
4575 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
4576 * with optimization (-O4) turned on.
4577 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
4578 * does not have this problem even with -O4.
4580 * This bug was reported as DECC_BUGS 1431
4581 * and tracked internally as GEM_BUGS 7775.
4583 * The bug is fixed in
4584 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
4585 * UNIX V4.0F support: DEC C V5.9-006 or later
4586 * UNIX V4.0E support: DEC C V5.8-011 or later
4589 * See also few lines later for the same bug.
4592 sv_setiv(sv, (IV)aint) :
4594 sv_setiv(sv, (IV)aint);
4595 PUSHs(sv_2mortal(sv));
4600 along = (strend - s) / sizeof(unsigned int);
4605 Copy(s, &auint, 1, unsigned int);
4606 s += sizeof(unsigned int);
4608 cdouble += (NV)auint;
4617 Copy(s, &auint, 1, unsigned int);
4618 s += sizeof(unsigned int);
4621 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
4622 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
4623 * See details few lines earlier. */
4625 sv_setuv(sv, (UV)auint) :
4627 sv_setuv(sv, (UV)auint);
4628 PUSHs(sv_2mortal(sv));
4633 #if LONGSIZE == SIZE32
4634 along = (strend - s) / SIZE32;
4636 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
4641 #if LONGSIZE != SIZE32
4644 COPYNN(s, &along, sizeof(long));
4647 cdouble += (NV)along;
4656 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4660 #if LONGSIZE > SIZE32
4661 if (along > 2147483647)
4662 along -= 4294967296;
4666 cdouble += (NV)along;
4675 #if LONGSIZE != SIZE32
4678 COPYNN(s, &along, sizeof(long));
4681 sv_setiv(sv, (IV)along);
4682 PUSHs(sv_2mortal(sv));
4689 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
4693 #if LONGSIZE > SIZE32
4694 if (along > 2147483647)
4695 along -= 4294967296;
4699 sv_setiv(sv, (IV)along);
4700 PUSHs(sv_2mortal(sv));
4708 #if LONGSIZE == SIZE32
4709 along = (strend - s) / SIZE32;
4711 unatint = natint && datumtype == 'L';
4712 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4717 #if LONGSIZE != SIZE32
4719 unsigned long aulong;
4721 COPYNN(s, &aulong, sizeof(unsigned long));
4722 s += sizeof(unsigned long);
4724 cdouble += (NV)aulong;
4736 if (datumtype == 'N')
4737 aulong = PerlSock_ntohl(aulong);
4740 if (datumtype == 'V')
4741 aulong = vtohl(aulong);
4744 cdouble += (NV)aulong;
4753 #if LONGSIZE != SIZE32
4755 unsigned long aulong;
4757 COPYNN(s, &aulong, sizeof(unsigned long));
4758 s += sizeof(unsigned long);
4760 sv_setuv(sv, (UV)aulong);
4761 PUSHs(sv_2mortal(sv));
4771 if (datumtype == 'N')
4772 aulong = PerlSock_ntohl(aulong);
4775 if (datumtype == 'V')
4776 aulong = vtohl(aulong);
4779 sv_setuv(sv, (UV)aulong);
4780 PUSHs(sv_2mortal(sv));
4786 along = (strend - s) / sizeof(char*);
4792 if (sizeof(char*) > strend - s)
4795 Copy(s, &aptr, 1, char*);
4801 PUSHs(sv_2mortal(sv));
4811 while ((len > 0) && (s < strend)) {
4812 auv = (auv << 7) | (*s & 0x7f);
4813 /* UTF8_IS_XXXXX not right here - using constant 0x80 */
4814 if ((U8)(*s++) < 0x80) {
4818 PUSHs(sv_2mortal(sv));
4822 else if (++bytes >= sizeof(UV)) { /* promote to string */
4826 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4827 while (s < strend) {
4828 sv = mul128(sv, *s & 0x7f);
4829 if (!(*s++ & 0x80)) {
4838 PUSHs(sv_2mortal(sv));
4843 if ((s >= strend) && bytes)
4844 DIE(aTHX_ "Unterminated compressed integer");
4849 if (sizeof(char*) > strend - s)
4852 Copy(s, &aptr, 1, char*);
4857 sv_setpvn(sv, aptr, len);
4858 PUSHs(sv_2mortal(sv));
4862 along = (strend - s) / sizeof(Quad_t);
4868 if (s + sizeof(Quad_t) > strend)
4871 Copy(s, &aquad, 1, Quad_t);
4872 s += sizeof(Quad_t);
4875 if (aquad >= IV_MIN && aquad <= IV_MAX)
4876 sv_setiv(sv, (IV)aquad);
4878 sv_setnv(sv, (NV)aquad);
4879 PUSHs(sv_2mortal(sv));
4883 along = (strend - s) / sizeof(Quad_t);
4889 if (s + sizeof(Uquad_t) > strend)
4892 Copy(s, &auquad, 1, Uquad_t);
4893 s += sizeof(Uquad_t);
4896 if (auquad <= UV_MAX)
4897 sv_setuv(sv, (UV)auquad);
4899 sv_setnv(sv, (NV)auquad);
4900 PUSHs(sv_2mortal(sv));
4904 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4907 along = (strend - s) / sizeof(float);
4912 Copy(s, &afloat, 1, float);
4921 Copy(s, &afloat, 1, float);
4924 sv_setnv(sv, (NV)afloat);
4925 PUSHs(sv_2mortal(sv));
4931 along = (strend - s) / sizeof(double);
4936 Copy(s, &adouble, 1, double);
4937 s += sizeof(double);
4945 Copy(s, &adouble, 1, double);
4946 s += sizeof(double);
4948 sv_setnv(sv, (NV)adouble);
4949 PUSHs(sv_2mortal(sv));
4955 * Initialise the decode mapping. By using a table driven
4956 * algorithm, the code will be character-set independent
4957 * (and just as fast as doing character arithmetic)
4959 if (PL_uudmap['M'] == 0) {
4962 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4963 PL_uudmap[(U8)PL_uuemap[i]] = i;
4965 * Because ' ' and '`' map to the same value,
4966 * we need to decode them both the same.
4971 along = (strend - s) * 3 / 4;
4972 sv = NEWSV(42, along);
4975 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4980 len = PL_uudmap[*(U8*)s++] & 077;
4982 if (s < strend && ISUUCHAR(*s))
4983 a = PL_uudmap[*(U8*)s++] & 077;
4986 if (s < strend && ISUUCHAR(*s))
4987 b = PL_uudmap[*(U8*)s++] & 077;
4990 if (s < strend && ISUUCHAR(*s))
4991 c = PL_uudmap[*(U8*)s++] & 077;
4994 if (s < strend && ISUUCHAR(*s))
4995 d = PL_uudmap[*(U8*)s++] & 077;
4998 hunk[0] = (a << 2) | (b >> 4);
4999 hunk[1] = (b << 4) | (c >> 2);
5000 hunk[2] = (c << 6) | d;
5001 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
5006 else if (s[1] == '\n') /* possible checksum byte */
5009 XPUSHs(sv_2mortal(sv));
5014 if (strchr("fFdD", datumtype) ||
5015 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
5019 while (checksum >= 16) {
5023 while (checksum >= 4) {
5029 along = (1 << checksum) - 1;
5030 while (cdouble < 0.0)
5032 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
5033 sv_setnv(sv, cdouble);
5036 if (checksum < 32) {
5037 aulong = (1 << checksum) - 1;
5040 sv_setuv(sv, (UV)culong);
5042 XPUSHs(sv_2mortal(sv));
5046 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
5047 PUSHs(&PL_sv_undef);
5052 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
5056 *hunk = PL_uuemap[len];
5057 sv_catpvn(sv, hunk, 1);
5060 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5061 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
5062 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
5063 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
5064 sv_catpvn(sv, hunk, 4);
5069 char r = (len > 1 ? s[1] : '\0');
5070 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
5071 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
5072 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
5073 hunk[3] = PL_uuemap[0];
5074 sv_catpvn(sv, hunk, 4);
5076 sv_catpvn(sv, "\n", 1);
5080 S_is_an_int(pTHX_ char *s, STRLEN l)
5083 SV *result = newSVpvn(s, l);
5084 char *result_c = SvPV(result, n_a); /* convenience */
5085 char *out = result_c;
5095 SvREFCNT_dec(result);
5118 SvREFCNT_dec(result);
5124 SvCUR_set(result, out - result_c);
5128 /* pnum must be '\0' terminated */
5130 S_div128(pTHX_ SV *pnum, bool *done)
5133 char *s = SvPV(pnum, len);
5142 i = m * 10 + (*t - '0');
5144 r = (i >> 7); /* r < 10 */
5151 SvCUR_set(pnum, (STRLEN) (t - s));
5158 dSP; dMARK; dORIGMARK; dTARGET;
5159 register SV *cat = TARG;
5162 register char *pat = SvPVx(*++MARK, fromlen);
5164 register char *patend = pat + fromlen;
5169 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
5170 static char *space10 = " ";
5172 /* These must not be in registers: */
5187 #ifdef PERL_NATINT_PACK
5188 int natint; /* native integer */
5193 sv_setpvn(cat, "", 0);
5195 while (pat < patend) {
5196 SV *lengthcode = Nullsv;
5197 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
5198 datumtype = *pat++ & 0xFF;
5199 #ifdef PERL_NATINT_PACK
5202 if (isSPACE(datumtype)) {
5206 #ifndef PACKED_IS_OCTETS
5207 if (datumtype == 'U' && pat == patcopy+1)
5210 if (datumtype == '#') {
5211 while (pat < patend && *pat != '\n')
5216 char *natstr = "sSiIlL";
5218 if (strchr(natstr, datumtype)) {
5219 #ifdef PERL_NATINT_PACK
5225 DIE(aTHX_ "'!' allowed only after types %s", natstr);
5228 len = strchr("@Xxu", datumtype) ? 0 : items;
5231 else if (isDIGIT(*pat)) {
5233 while (isDIGIT(*pat)) {
5234 len = (len * 10) + (*pat++ - '0');
5236 DIE(aTHX_ "Repeat count in pack overflows");
5243 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
5244 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
5245 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
5246 ? *MARK : &PL_sv_no)
5247 + (*pat == 'Z' ? 1 : 0)));
5251 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
5252 case ',': /* grandfather in commas but with a warning */
5253 if (commas++ == 0 && ckWARN(WARN_PACK))
5254 Perl_warner(aTHX_ WARN_PACK,
5255 "Invalid type in pack: '%c'", (int)datumtype);
5258 DIE(aTHX_ "%% may only be used in unpack");
5269 if (SvCUR(cat) < len)
5270 DIE(aTHX_ "X outside of string");
5277 sv_catpvn(cat, null10, 10);
5280 sv_catpvn(cat, null10, len);
5286 aptr = SvPV(fromstr, fromlen);
5287 if (pat[-1] == '*') {
5289 if (datumtype == 'Z')
5292 if (fromlen >= len) {
5293 sv_catpvn(cat, aptr, len);
5294 if (datumtype == 'Z')
5295 *(SvEND(cat)-1) = '\0';
5298 sv_catpvn(cat, aptr, fromlen);
5300 if (datumtype == 'A') {
5302 sv_catpvn(cat, space10, 10);
5305 sv_catpvn(cat, space10, len);
5309 sv_catpvn(cat, null10, 10);
5312 sv_catpvn(cat, null10, len);
5324 str = SvPV(fromstr, fromlen);
5328 SvCUR(cat) += (len+7)/8;
5329 SvGROW(cat, SvCUR(cat) + 1);
5330 aptr = SvPVX(cat) + aint;
5335 if (datumtype == 'B') {
5336 for (len = 0; len++ < aint;) {
5337 items |= *str++ & 1;
5341 *aptr++ = items & 0xff;
5347 for (len = 0; len++ < aint;) {
5353 *aptr++ = items & 0xff;
5359 if (datumtype == 'B')
5360 items <<= 7 - (aint & 7);
5362 items >>= 7 - (aint & 7);
5363 *aptr++ = items & 0xff;
5365 str = SvPVX(cat) + SvCUR(cat);
5380 str = SvPV(fromstr, fromlen);
5384 SvCUR(cat) += (len+1)/2;
5385 SvGROW(cat, SvCUR(cat) + 1);
5386 aptr = SvPVX(cat) + aint;
5391 if (datumtype == 'H') {
5392 for (len = 0; len++ < aint;) {
5394 items |= ((*str++ & 15) + 9) & 15;
5396 items |= *str++ & 15;
5400 *aptr++ = items & 0xff;
5406 for (len = 0; len++ < aint;) {
5408 items |= (((*str++ & 15) + 9) & 15) << 4;
5410 items |= (*str++ & 15) << 4;
5414 *aptr++ = items & 0xff;
5420 *aptr++ = items & 0xff;
5421 str = SvPVX(cat) + SvCUR(cat);
5432 aint = SvIV(fromstr);
5434 sv_catpvn(cat, &achar, sizeof(char));
5440 auint = SvUV(fromstr);
5441 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
5442 SvCUR_set(cat, (char*)uvchr_to_utf8((U8*)SvEND(cat),auint)
5447 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
5452 afloat = (float)SvNV(fromstr);
5453 sv_catpvn(cat, (char *)&afloat, sizeof (float));
5460 adouble = (double)SvNV(fromstr);
5461 sv_catpvn(cat, (char *)&adouble, sizeof (double));
5467 ashort = (I16)SvIV(fromstr);
5469 ashort = PerlSock_htons(ashort);
5471 CAT16(cat, &ashort);
5477 ashort = (I16)SvIV(fromstr);
5479 ashort = htovs(ashort);
5481 CAT16(cat, &ashort);
5485 #if SHORTSIZE != SIZE16
5487 unsigned short aushort;
5491 aushort = SvUV(fromstr);
5492 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
5502 aushort = (U16)SvUV(fromstr);
5503 CAT16(cat, &aushort);
5509 #if SHORTSIZE != SIZE16
5515 ashort = SvIV(fromstr);
5516 sv_catpvn(cat, (char *)&ashort, sizeof(short));
5524 ashort = (I16)SvIV(fromstr);
5525 CAT16(cat, &ashort);
5532 auint = SvUV(fromstr);
5533 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
5539 adouble = Perl_floor(SvNV(fromstr));
5542 DIE(aTHX_ "Cannot compress negative numbers");
5545 #if UVSIZE > 4 && UVSIZE >= NVSIZE
5546 adouble <= 0xffffffff
5548 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
5549 adouble <= UV_MAX_cxux
5556 char buf[1 + sizeof(UV)];
5557 char *in = buf + sizeof(buf);
5558 UV auv = U_V(adouble);
5561 *--in = (auv & 0x7f) | 0x80;
5564 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5565 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5567 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
5568 char *from, *result, *in;
5573 /* Copy string and check for compliance */
5574 from = SvPV(fromstr, len);
5575 if ((norm = is_an_int(from, len)) == NULL)
5576 DIE(aTHX_ "can compress only unsigned integer");
5578 New('w', result, len, char);
5582 *--in = div128(norm, &done) | 0x80;
5583 result[len - 1] &= 0x7F; /* clear continue bit */
5584 sv_catpvn(cat, in, (result + len) - in);
5586 SvREFCNT_dec(norm); /* free norm */
5588 else if (SvNOKp(fromstr)) {
5589 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
5590 char *in = buf + sizeof(buf);
5593 double next = floor(adouble / 128);
5594 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
5595 if (in <= buf) /* this cannot happen ;-) */
5596 DIE(aTHX_ "Cannot compress integer");
5599 } while (adouble > 0);
5600 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
5601 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
5604 DIE(aTHX_ "Cannot compress non integer");
5610 aint = SvIV(fromstr);
5611 sv_catpvn(cat, (char*)&aint, sizeof(int));
5617 aulong = SvUV(fromstr);
5619 aulong = PerlSock_htonl(aulong);
5621 CAT32(cat, &aulong);
5627 aulong = SvUV(fromstr);
5629 aulong = htovl(aulong);
5631 CAT32(cat, &aulong);
5635 #if LONGSIZE != SIZE32
5637 unsigned long aulong;
5641 aulong = SvUV(fromstr);
5642 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
5650 aulong = SvUV(fromstr);
5651 CAT32(cat, &aulong);
5656 #if LONGSIZE != SIZE32
5662 along = SvIV(fromstr);
5663 sv_catpvn(cat, (char *)&along, sizeof(long));
5671 along = SvIV(fromstr);
5680 auquad = (Uquad_t)SvUV(fromstr);
5681 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
5687 aquad = (Quad_t)SvIV(fromstr);
5688 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
5693 len = 1; /* assume SV is correct length */
5698 if (fromstr == &PL_sv_undef)
5702 /* XXX better yet, could spirit away the string to
5703 * a safe spot and hang on to it until the result
5704 * of pack() (and all copies of the result) are
5707 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5708 || (SvPADTMP(fromstr)
5709 && !SvREADONLY(fromstr))))
5711 Perl_warner(aTHX_ WARN_PACK,
5712 "Attempt to pack pointer to temporary value");
5714 if (SvPOK(fromstr) || SvNIOK(fromstr))
5715 aptr = SvPV(fromstr,n_a);
5717 aptr = SvPV_force(fromstr,n_a);
5719 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5724 aptr = SvPV(fromstr, fromlen);
5725 SvGROW(cat, fromlen * 4 / 3);
5730 while (fromlen > 0) {
5737 doencodes(cat, aptr, todo);
5756 register IV limit = POPi; /* note, negative is forever */
5759 register char *s = SvPV(sv, len);
5760 bool do_utf8 = DO_UTF8(sv);
5761 char *strend = s + len;
5763 register REGEXP *rx;
5767 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5768 I32 maxiters = slen + 10;
5771 I32 origlimit = limit;
5774 AV *oldstack = PL_curstack;
5775 I32 gimme = GIMME_V;
5776 I32 oldsave = PL_savestack_ix;
5777 I32 make_mortal = 1;
5778 MAGIC *mg = (MAGIC *) NULL;
5781 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5786 DIE(aTHX_ "panic: pp_split");
5787 rx = pm->op_pmregexp;
5789 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5790 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5792 if (pm->op_pmreplroot) {
5794 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5796 ary = GvAVn((GV*)pm->op_pmreplroot);
5799 else if (gimme != G_ARRAY)
5801 ary = (AV*)PL_curpad[0];
5803 ary = GvAVn(PL_defgv);
5804 #endif /* USE_THREADS */
5807 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5813 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5815 XPUSHs(SvTIED_obj((SV*)ary, mg));
5821 for (i = AvFILLp(ary); i >= 0; i--)
5822 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5824 /* temporarily switch stacks */
5825 SWITCHSTACK(PL_curstack, ary);
5829 base = SP - PL_stack_base;
5831 if (pm->op_pmflags & PMf_SKIPWHITE) {
5832 if (pm->op_pmflags & PMf_LOCALE) {
5833 while (isSPACE_LC(*s))
5841 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5842 SAVEINT(PL_multiline);
5843 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5847 limit = maxiters + 2;
5848 if (pm->op_pmflags & PMf_WHITE) {
5851 while (m < strend &&
5852 !((pm->op_pmflags & PMf_LOCALE)
5853 ? isSPACE_LC(*m) : isSPACE(*m)))
5858 dstr = NEWSV(30, m-s);
5859 sv_setpvn(dstr, s, m-s);
5863 (void)SvUTF8_on(dstr);
5867 while (s < strend &&
5868 ((pm->op_pmflags & PMf_LOCALE)
5869 ? isSPACE_LC(*s) : isSPACE(*s)))
5873 else if (strEQ("^", rx->precomp)) {
5876 for (m = s; m < strend && *m != '\n'; m++) ;
5880 dstr = NEWSV(30, m-s);
5881 sv_setpvn(dstr, s, m-s);
5885 (void)SvUTF8_on(dstr);
5890 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
5891 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
5892 && (rx->reganch & ROPT_CHECK_ALL)
5893 && !(rx->reganch & ROPT_ANCH)) {
5894 int tail = (rx->reganch & RE_INTUIT_TAIL);
5895 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5898 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
5900 char c = *SvPV(csv, n_a);
5903 for (m = s; m < strend && *m != c; m++) ;
5906 dstr = NEWSV(30, m-s);
5907 sv_setpvn(dstr, s, m-s);
5911 (void)SvUTF8_on(dstr);
5913 /* The rx->minlen is in characters but we want to step
5914 * s ahead by bytes. */
5916 s = (char*)utf8_hop((U8*)m, len);
5918 s = m + len; /* Fake \n at the end */
5923 while (s < strend && --limit &&
5924 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5925 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5928 dstr = NEWSV(31, m-s);
5929 sv_setpvn(dstr, s, m-s);
5933 (void)SvUTF8_on(dstr);
5935 /* The rx->minlen is in characters but we want to step
5936 * s ahead by bytes. */
5938 s = (char*)utf8_hop((U8*)m, len);
5940 s = m + len; /* Fake \n at the end */
5945 maxiters += slen * rx->nparens;
5946 while (s < strend && --limit
5947 /* && (!rx->check_substr
5948 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5950 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5951 1 /* minend */, sv, NULL, 0))
5953 TAINT_IF(RX_MATCH_TAINTED(rx));
5954 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5959 strend = s + (strend - m);
5961 m = rx->startp[0] + orig;
5962 dstr = NEWSV(32, m-s);
5963 sv_setpvn(dstr, s, m-s);
5967 (void)SvUTF8_on(dstr);
5970 for (i = 1; i <= rx->nparens; i++) {
5971 s = rx->startp[i] + orig;
5972 m = rx->endp[i] + orig;
5974 dstr = NEWSV(33, m-s);
5975 sv_setpvn(dstr, s, m-s);
5978 dstr = NEWSV(33, 0);
5982 (void)SvUTF8_on(dstr);
5986 s = rx->endp[0] + orig;
5990 LEAVE_SCOPE(oldsave);
5991 iters = (SP - PL_stack_base) - base;
5992 if (iters > maxiters)
5993 DIE(aTHX_ "Split loop");
5995 /* keep field after final delim? */
5996 if (s < strend || (iters && origlimit)) {
5997 STRLEN l = strend - s;
5998 dstr = NEWSV(34, l);
5999 sv_setpvn(dstr, s, l);
6003 (void)SvUTF8_on(dstr);
6007 else if (!origlimit) {
6008 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
6014 SWITCHSTACK(ary, oldstack);
6015 if (SvSMAGICAL(ary)) {
6020 if (gimme == G_ARRAY) {
6022 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6030 call_method("PUSH",G_SCALAR|G_DISCARD);
6033 if (gimme == G_ARRAY) {
6034 /* EXTEND should not be needed - we just popped them */
6036 for (i=0; i < iters; i++) {
6037 SV **svp = av_fetch(ary, i, FALSE);
6038 PUSHs((svp) ? *svp : &PL_sv_undef);
6045 if (gimme == G_ARRAY)
6048 if (iters || !pm->op_pmreplroot) {
6058 Perl_unlock_condpair(pTHX_ void *svv)
6060 MAGIC *mg = mg_find((SV*)svv, 'm');
6063 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
6064 MUTEX_LOCK(MgMUTEXP(mg));
6065 if (MgOWNER(mg) != thr)
6066 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
6068 COND_SIGNAL(MgOWNERCONDP(mg));
6069 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
6070 PTR2UV(thr), PTR2UV(svv));)
6071 MUTEX_UNLOCK(MgMUTEXP(mg));
6073 #endif /* USE_THREADS */
6082 #endif /* USE_THREADS */
6083 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6084 || SvTYPE(retsv) == SVt_PVCV) {
6085 retsv = refto(retsv);
6096 if (PL_op->op_private & OPpLVAL_INTRO)
6097 PUSHs(*save_threadsv(PL_op->op_targ));
6099 PUSHs(THREADSV(PL_op->op_targ));
6102 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
6103 #endif /* USE_THREADS */