3 * Copyright (c) 1991-1997, 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
19 * The compiler on Concurrent CX/UX systems has a subtle bug which only
20 * seems to show up when compiling pp.c - it generates the wrong double
21 * precision constant value for (double)UV_MAX when used inline in the body
22 * of the code below, so this makes a static variable up front (which the
23 * compiler seems to get correct) and uses it in place of UV_MAX below.
25 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
26 static double UV_MAX_cxux = ((double)UV_MAX);
30 * Types used in bitwise operations.
32 * Normally we'd just use IV and UV. However, some hardware and
33 * software combinations (e.g. Alpha and current OSF/1) don't have a
34 * floating-point type to use for NV that has adequate bits to fully
35 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
37 * It just so happens that "int" is the right size almost everywhere.
43 * Mask used after bitwise operations.
45 * There is at least one realm (Cray word machines) that doesn't
46 * have an integral type (except char) small enough to be represented
47 * in a double without loss; that is, it has no 32-bit type.
49 #if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
51 # define BW_MASK ((1 << BW_BITS) - 1)
52 # define BW_SIGN (1 << (BW_BITS - 1))
53 # define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
54 # define BWu(u) ((u) & BW_MASK)
61 * Offset for integer pack/unpack.
63 * On architectures where I16 and I32 aren't really 16 and 32 bits,
64 * which for now are all Crays, pack and unpack have to play games.
68 * These values are required for portability of pack() output.
69 * If they're not right on your machine, then pack() and unpack()
70 * wouldn't work right anyway; you'll need to apply the Cray hack.
71 * (I'd like to check them with #if, but you can't use sizeof() in
72 * the preprocessor.) --???
75 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
76 defines are now in config.h. --Andy Dougherty April 1998
81 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
82 # if BYTEORDER == 0x12345678
83 # define OFF16(p) (char*)(p)
84 # define OFF32(p) (char*)(p)
86 # if BYTEORDER == 0x87654321
87 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
88 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
90 }}}} bad cray byte order
93 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
94 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
95 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
96 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
98 # define COPY16(s,p) Copy(s, p, SIZE16, char)
99 # define COPY32(s,p) Copy(s, p, SIZE32, char)
100 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
101 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
105 static void doencodes _((SV* sv, char* s, I32 len));
106 static SV* refto _((SV* sv));
107 static U32 seed _((void));
110 static bool srand_called = FALSE;
112 /* variations on pp_null */
118 /* XXX I can't imagine anyone who doesn't have this actually _needs_
119 it, since pid_t is an integral type.
122 #ifdef NEED_GETPID_PROTO
123 extern Pid_t getpid (void);
129 if (GIMME_V == G_SCALAR)
130 XPUSHs(&PL_sv_undef);
144 if (PL_op->op_private & OPpLVAL_INTRO)
145 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
147 if (PL_op->op_flags & OPf_REF) {
151 if (GIMME == G_ARRAY) {
152 I32 maxarg = AvFILL((AV*)TARG) + 1;
154 if (SvMAGICAL(TARG)) {
156 for (i=0; i < maxarg; i++) {
157 SV **svp = av_fetch((AV*)TARG, i, FALSE);
158 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
162 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
167 SV* sv = sv_newmortal();
168 I32 maxarg = AvFILL((AV*)TARG) + 1;
169 sv_setiv(sv, maxarg);
181 if (PL_op->op_private & OPpLVAL_INTRO)
182 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
183 if (PL_op->op_flags & OPf_REF)
186 if (gimme == G_ARRAY) {
187 RETURNOP(do_kv(ARGS));
189 else if (gimme == G_SCALAR) {
190 SV* sv = sv_newmortal();
191 if (HvFILL((HV*)TARG))
192 sv_setpvf(sv, "%ld/%ld",
193 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
203 DIE("NOT IMPL LINE %d",__LINE__);
215 if (SvTYPE(sv) == SVt_PVIO) {
216 GV *gv = (GV*) sv_newmortal();
217 gv_init(gv, 0, "", 0, 0);
218 GvIOp(gv) = (IO *)sv;
219 (void)SvREFCNT_inc(sv);
221 } else if (SvTYPE(sv) != SVt_PVGV)
222 DIE("Not a GLOB reference");
225 if (SvTYPE(sv) != SVt_PVGV) {
228 if (SvGMAGICAL(sv)) {
234 if (PL_op->op_flags & OPf_REF ||
235 PL_op->op_private & HINT_STRICT_REFS)
236 DIE(no_usym, "a symbol");
237 if (ckWARN(WARN_UNINITIALIZED))
238 warner(WARN_UNINITIALIZED, warn_uninit);
241 sym = SvPV(sv, PL_na);
242 if (PL_op->op_private & HINT_STRICT_REFS)
243 DIE(no_symref, sym, "a symbol");
244 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
247 if (PL_op->op_private & OPpLVAL_INTRO)
248 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
260 switch (SvTYPE(sv)) {
264 DIE("Not a SCALAR reference");
271 if (SvTYPE(gv) != SVt_PVGV) {
272 if (SvGMAGICAL(sv)) {
278 if (PL_op->op_flags & OPf_REF ||
279 PL_op->op_private & HINT_STRICT_REFS)
280 DIE(no_usym, "a SCALAR");
281 if (ckWARN(WARN_UNINITIALIZED))
282 warner(WARN_UNINITIALIZED, warn_uninit);
285 sym = SvPV(sv, PL_na);
286 if (PL_op->op_private & HINT_STRICT_REFS)
287 DIE(no_symref, sym, "a SCALAR");
288 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
292 if (PL_op->op_flags & OPf_MOD) {
293 if (PL_op->op_private & OPpLVAL_INTRO)
294 sv = save_scalar((GV*)TOPs);
295 else if (PL_op->op_private & OPpDEREF)
296 vivify_ref(sv, PL_op->op_private & OPpDEREF);
306 SV *sv = AvARYLEN(av);
308 AvARYLEN(av) = sv = NEWSV(0,0);
309 sv_upgrade(sv, SVt_IV);
310 sv_magic(sv, (SV*)av, '#', Nullch, 0);
318 djSP; dTARGET; dPOPss;
320 if (PL_op->op_flags & OPf_MOD) {
321 if (SvTYPE(TARG) < SVt_PVLV) {
322 sv_upgrade(TARG, SVt_PVLV);
323 sv_magic(TARG, Nullsv, '.', Nullch, 0);
327 if (LvTARG(TARG) != sv) {
329 SvREFCNT_dec(LvTARG(TARG));
330 LvTARG(TARG) = SvREFCNT_inc(sv);
332 PUSHs(TARG); /* no SvSETMAGIC */
338 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
339 mg = mg_find(sv, 'g');
340 if (mg && mg->mg_len >= 0) {
344 PUSHi(i + PL_curcop->cop_arybase);
358 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
359 /* (But not in defined().) */
360 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
363 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
366 cv = (CV*)&PL_sv_undef;
380 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
381 char *s = SvPVX(TOPs);
382 if (strnEQ(s, "CORE::", 6)) {
385 code = keyword(s + 6, SvCUR(TOPs) - 6);
386 if (code < 0) { /* Overridable. */
387 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
388 int i = 0, n = 0, seen_question = 0;
390 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
392 while (i < MAXO) { /* The slow way. */
393 if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
397 goto nonesuch; /* Should not happen... */
399 oa = opargs[i] >> OASHIFT;
401 if (oa & OA_OPTIONAL) {
404 } else if (seen_question)
405 goto set; /* XXXX system, exec */
406 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
407 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
410 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
411 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
415 ret = sv_2mortal(newSVpv(str, n - 1));
416 } else if (code) /* Non-Overridable */
418 else { /* None such */
420 croak("Cannot find an opnumber for \"%s\"", s+6);
424 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
426 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
435 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
437 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
453 if (GIMME != G_ARRAY) {
457 *MARK = &PL_sv_undef;
458 *MARK = refto(*MARK);
462 EXTEND_MORTAL(SP - MARK);
464 *MARK = refto(*MARK);
473 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
476 if (!(sv = LvTARG(sv)))
479 else if (SvPADTMP(sv))
483 (void)SvREFCNT_inc(sv);
486 sv_upgrade(rv, SVt_RV);
500 if (sv && SvGMAGICAL(sv))
503 if (!sv || !SvROK(sv))
507 pv = sv_reftype(sv,TRUE);
508 PUSHp(pv, strlen(pv));
518 stash = PL_curcop->cop_stash;
522 char *ptr = SvPV(ssv,len);
523 if (ckWARN(WARN_UNSAFE) && len == 0)
525 "Explicit blessing to '' (assuming package main)");
526 stash = gv_stashpvn(ptr, len, TRUE);
529 (void)sv_bless(TOPs, stash);
542 elem = SvPV(sv, PL_na);
546 switch (elem ? *elem : '\0')
549 if (strEQ(elem, "ARRAY"))
550 tmpRef = (SV*)GvAV(gv);
553 if (strEQ(elem, "CODE"))
554 tmpRef = (SV*)GvCVu(gv);
557 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
558 tmpRef = (SV*)GvIOp(gv);
561 if (strEQ(elem, "GLOB"))
565 if (strEQ(elem, "HASH"))
566 tmpRef = (SV*)GvHV(gv);
569 if (strEQ(elem, "IO"))
570 tmpRef = (SV*)GvIOp(gv);
573 if (strEQ(elem, "NAME"))
574 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
577 if (strEQ(elem, "PACKAGE"))
578 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
581 if (strEQ(elem, "SCALAR"))
595 /* Pattern matching */
600 register UNOP *unop = cUNOP;
601 register unsigned char *s;
604 register I32 *sfirst;
608 if (sv == PL_lastscream) {
614 SvSCREAM_off(PL_lastscream);
615 SvREFCNT_dec(PL_lastscream);
617 PL_lastscream = SvREFCNT_inc(sv);
620 s = (unsigned char*)(SvPV(sv, len));
624 if (pos > PL_maxscream) {
625 if (PL_maxscream < 0) {
626 PL_maxscream = pos + 80;
627 New(301, PL_screamfirst, 256, I32);
628 New(302, PL_screamnext, PL_maxscream, I32);
631 PL_maxscream = pos + pos / 4;
632 Renew(PL_screamnext, PL_maxscream, I32);
636 sfirst = PL_screamfirst;
637 snext = PL_screamnext;
639 if (!sfirst || !snext)
640 DIE("do_study: out of memory");
642 for (ch = 256; ch; --ch)
649 snext[pos] = sfirst[ch] - pos;
656 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
665 if (PL_op->op_flags & OPf_STACKED)
671 TARG = sv_newmortal();
676 /* Lvalue operators. */
688 djSP; dMARK; dTARGET;
698 SETi(do_chomp(TOPs));
704 djSP; dMARK; dTARGET;
705 register I32 count = 0;
708 count += do_chomp(POPs);
719 if (!sv || !SvANY(sv))
721 switch (SvTYPE(sv)) {
723 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
727 if (HvARRAY(sv) || SvGMAGICAL(sv))
731 if (CvROOT(sv) || CvXSUB(sv))
748 if (!PL_op->op_private) {
757 if (SvTHINKFIRST(sv)) {
764 switch (SvTYPE(sv)) {
774 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
775 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
776 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
779 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
781 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
785 SvSetMagicSV(sv, &PL_sv_undef);
789 Newz(602, gp, 1, GP);
790 GvGP(sv) = gp_ref(gp);
791 GvSV(sv) = NEWSV(72,0);
792 GvLINE(sv) = PL_curcop->cop_line;
798 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
801 SvPV_set(sv, Nullch);
814 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
816 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
817 SvIVX(TOPs) != IV_MIN)
820 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
831 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
833 sv_setsv(TARG, TOPs);
834 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
835 SvIVX(TOPs) != IV_MAX)
838 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
852 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
854 sv_setsv(TARG, TOPs);
855 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
856 SvIVX(TOPs) != IV_MIN)
859 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
868 /* Ordinary operators. */
872 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
875 SETn( pow( left, right) );
882 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
885 SETn( left * right );
892 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
897 DIE("Illegal division by zero");
899 /* insure that 20./5. == 4. */
902 if ((double)I_V(left) == left &&
903 (double)I_V(right) == right &&
904 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
907 value = left / right;
911 value = left / right;
920 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
928 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
930 right = (right_neg = (i < 0)) ? -i : i;
934 right = U_V((right_neg = (n < 0)) ? -n : n);
937 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
939 left = (left_neg = (i < 0)) ? -i : i;
943 left = U_V((left_neg = (n < 0)) ? -n : n);
947 DIE("Illegal modulus zero");
950 if ((left_neg != right_neg) && ans)
953 /* XXX may warn: unary minus operator applied to unsigned type */
954 /* could change -foo to be (~foo)+1 instead */
955 if (ans <= ~((UV)IV_MAX)+1)
956 sv_setiv(TARG, ~ans+1);
958 sv_setnv(TARG, -(double)ans);
969 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
971 register I32 count = POPi;
972 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
974 I32 items = SP - MARK;
986 repeatcpy((char*)(MARK + items), (char*)MARK,
987 items * sizeof(SV*), count - 1);
993 else { /* Note: mark already snarfed by pp_list */
998 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
999 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1000 DIE("Can't x= to readonly value");
1004 SvSetSV(TARG, tmpstr);
1005 SvPV_force(TARG, len);
1010 SvGROW(TARG, (count * len) + 1);
1011 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1012 SvCUR(TARG) *= count;
1014 *SvEND(TARG) = '\0';
1016 (void)SvPOK_only(TARG);
1025 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1028 SETn( left - right );
1035 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1038 if (PL_op->op_private & HINT_INTEGER) {
1040 i = BWi(i) << shift;
1054 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1057 if (PL_op->op_private & HINT_INTEGER) {
1059 i = BWi(i) >> shift;
1073 djSP; tryAMAGICbinSET(lt,0);
1076 SETs(boolSV(TOPn < value));
1083 djSP; tryAMAGICbinSET(gt,0);
1086 SETs(boolSV(TOPn > value));
1093 djSP; tryAMAGICbinSET(le,0);
1096 SETs(boolSV(TOPn <= value));
1103 djSP; tryAMAGICbinSET(ge,0);
1106 SETs(boolSV(TOPn >= value));
1113 djSP; tryAMAGICbinSET(ne,0);
1116 SETs(boolSV(TOPn != value));
1123 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1130 else if (left < right)
1132 else if (left > right)
1145 djSP; tryAMAGICbinSET(slt,0);
1148 int cmp = ((PL_op->op_private & OPpLOCALE)
1149 ? sv_cmp_locale(left, right)
1150 : sv_cmp(left, right));
1151 SETs(boolSV(cmp < 0));
1158 djSP; tryAMAGICbinSET(sgt,0);
1161 int cmp = ((PL_op->op_private & OPpLOCALE)
1162 ? sv_cmp_locale(left, right)
1163 : sv_cmp(left, right));
1164 SETs(boolSV(cmp > 0));
1171 djSP; tryAMAGICbinSET(sle,0);
1174 int cmp = ((PL_op->op_private & OPpLOCALE)
1175 ? sv_cmp_locale(left, right)
1176 : sv_cmp(left, right));
1177 SETs(boolSV(cmp <= 0));
1184 djSP; tryAMAGICbinSET(sge,0);
1187 int cmp = ((PL_op->op_private & OPpLOCALE)
1188 ? sv_cmp_locale(left, right)
1189 : sv_cmp(left, right));
1190 SETs(boolSV(cmp >= 0));
1197 djSP; tryAMAGICbinSET(seq,0);
1200 SETs(boolSV(sv_eq(left, right)));
1207 djSP; tryAMAGICbinSET(sne,0);
1210 SETs(boolSV(!sv_eq(left, right)));
1217 djSP; dTARGET; tryAMAGICbin(scmp,0);
1220 int cmp = ((PL_op->op_private & OPpLOCALE)
1221 ? sv_cmp_locale(left, right)
1222 : sv_cmp(left, right));
1230 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1233 if (SvNIOKp(left) || SvNIOKp(right)) {
1234 if (PL_op->op_private & HINT_INTEGER) {
1235 IBW value = SvIV(left) & SvIV(right);
1239 UBW value = SvUV(left) & SvUV(right);
1244 do_vop(PL_op->op_type, TARG, left, right);
1253 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1256 if (SvNIOKp(left) || SvNIOKp(right)) {
1257 if (PL_op->op_private & HINT_INTEGER) {
1258 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1262 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1267 do_vop(PL_op->op_type, TARG, left, right);
1276 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1279 if (SvNIOKp(left) || SvNIOKp(right)) {
1280 if (PL_op->op_private & HINT_INTEGER) {
1281 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1285 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1290 do_vop(PL_op->op_type, TARG, left, right);
1299 djSP; dTARGET; tryAMAGICun(neg);
1304 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1306 else if (SvNIOKp(sv))
1308 else if (SvPOKp(sv)) {
1310 char *s = SvPV(sv, len);
1311 if (isIDFIRST(*s)) {
1312 sv_setpvn(TARG, "-", 1);
1315 else if (*s == '+' || *s == '-') {
1317 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1320 sv_setnv(TARG, -SvNV(sv));
1332 djSP; tryAMAGICunSET(not);
1333 #endif /* OVERLOAD */
1334 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1340 djSP; dTARGET; tryAMAGICun(compl);
1344 if (PL_op->op_private & HINT_INTEGER) {
1345 IBW value = ~SvIV(sv);
1349 UBW value = ~SvUV(sv);
1354 register char *tmps;
1355 register long *tmpl;
1360 tmps = SvPV_force(TARG, len);
1363 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1366 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1370 for ( ; anum > 0; anum--, tmps++)
1379 /* integer versions of some of the above */
1383 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1386 SETi( left * right );
1393 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1397 DIE("Illegal division by zero");
1398 value = POPi / value;
1406 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1410 DIE("Illegal modulus zero");
1411 SETi( left % right );
1418 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1421 SETi( left + right );
1428 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1431 SETi( left - right );
1438 djSP; tryAMAGICbinSET(lt,0);
1441 SETs(boolSV(left < right));
1448 djSP; tryAMAGICbinSET(gt,0);
1451 SETs(boolSV(left > right));
1458 djSP; tryAMAGICbinSET(le,0);
1461 SETs(boolSV(left <= right));
1468 djSP; tryAMAGICbinSET(ge,0);
1471 SETs(boolSV(left >= right));
1478 djSP; tryAMAGICbinSET(eq,0);
1481 SETs(boolSV(left == right));
1488 djSP; tryAMAGICbinSET(ne,0);
1491 SETs(boolSV(left != right));
1498 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1505 else if (left < right)
1516 djSP; dTARGET; tryAMAGICun(neg);
1521 /* High falutin' math. */
1525 djSP; dTARGET; tryAMAGICbin(atan2,0);
1528 SETn(atan2(left, right));
1535 djSP; dTARGET; tryAMAGICun(sin);
1547 djSP; dTARGET; tryAMAGICun(cos);
1557 /* Support Configure command-line overrides for rand() functions.
1558 After 5.005, perhaps we should replace this by Configure support
1559 for drand48(), random(), or rand(). For 5.005, though, maintain
1560 compatibility by calling rand() but allow the user to override it.
1561 See INSTALL for details. --Andy Dougherty 15 July 1998
1563 /* Now it's after 5.005, and Configure supports drand48() and random(),
1564 in addition to rand(). So the overrides should not be needed any more.
1565 --Jarkko Hietaniemi 27 September 1998
1568 #ifndef HAS_DRAND48_PROTO
1569 extern double drand48 _((void));
1582 if (!srand_called) {
1583 (void)seedDrand01((Rand_seed_t)seed());
1584 srand_called = TRUE;
1599 (void)seedDrand01((Rand_seed_t)anum);
1600 srand_called = TRUE;
1609 * This is really just a quick hack which grabs various garbage
1610 * values. It really should be a real hash algorithm which
1611 * spreads the effect of every input bit onto every output bit,
1612 * if someone who knows about such things would bother to write it.
1613 * Might be a good idea to add that function to CORE as well.
1614 * No numbers below come from careful analysis or anything here,
1615 * except they are primes and SEED_C1 > 1E6 to get a full-width
1616 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1617 * probably be bigger too.
1620 # define SEED_C1 1000003
1621 #define SEED_C4 73819
1623 # define SEED_C1 25747
1624 #define SEED_C4 20639
1628 #define SEED_C5 26107
1631 #ifndef PERL_NO_DEV_RANDOM
1636 # include <starlet.h>
1637 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1638 * in 100-ns units, typically incremented ever 10 ms. */
1639 unsigned int when[2];
1641 # ifdef HAS_GETTIMEOFDAY
1642 struct timeval when;
1648 /* This test is an escape hatch, this symbol isn't set by Configure. */
1649 #ifndef PERL_NO_DEV_RANDOM
1650 #ifndef PERL_RANDOM_DEVICE
1651 /* /dev/random isn't used by default because reads from it will block
1652 * if there isn't enough entropy available. You can compile with
1653 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1654 * is enough real entropy to fill the seed. */
1655 # define PERL_RANDOM_DEVICE "/dev/urandom"
1657 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1659 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1668 _ckvmssts(sys$gettim(when));
1669 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1671 # ifdef HAS_GETTIMEOFDAY
1672 gettimeofday(&when,(struct timezone *) 0);
1673 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1676 u = (U32)SEED_C1 * when;
1679 u += SEED_C3 * (U32)getpid();
1680 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1681 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1682 u += SEED_C5 * (U32)(UV)&when;
1689 djSP; dTARGET; tryAMAGICun(exp);
1701 djSP; dTARGET; tryAMAGICun(log);
1706 SET_NUMERIC_STANDARD();
1707 DIE("Can't take log of %g", value);
1717 djSP; dTARGET; tryAMAGICun(sqrt);
1722 SET_NUMERIC_STANDARD();
1723 DIE("Can't take sqrt of %g", value);
1725 value = sqrt(value);
1735 double value = TOPn;
1738 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1744 (void)modf(value, &value);
1746 (void)modf(-value, &value);
1761 djSP; dTARGET; tryAMAGICun(abs);
1763 double value = TOPn;
1766 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1767 (iv = SvIVX(TOPs)) != IV_MIN) {
1788 XPUSHu(scan_hex(tmps, 99, &argtype));
1800 while (*tmps && isSPACE(*tmps))
1805 value = scan_hex(++tmps, 99, &argtype);
1807 value = scan_oct(tmps, 99, &argtype);
1819 SETi( sv_len_utf8(TOPs) );
1823 SETi( sv_len(TOPs) );
1837 I32 lvalue = PL_op->op_flags & OPf_MOD;
1839 I32 arybase = PL_curcop->cop_arybase;
1843 SvTAINTED_off(TARG); /* decontaminate */
1847 repl = SvPV(sv, repl_len);
1854 tmps = SvPV(sv, curlen);
1856 utfcurlen = sv_len_utf8(sv);
1857 if (utfcurlen == curlen)
1865 if (pos >= arybase) {
1883 else if (len >= 0) {
1885 if (rem > (I32)curlen)
1899 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1900 warner(WARN_SUBSTR, "substr outside of string");
1905 sv_pos_u2b(sv, &pos, &rem);
1907 sv_setpvn(TARG, tmps, rem);
1908 if (lvalue) { /* it's an lvalue! */
1909 if (!SvGMAGICAL(sv)) {
1911 SvPV_force(sv,PL_na);
1912 if (ckWARN(WARN_SUBSTR))
1914 "Attempt to use reference as lvalue in substr");
1916 if (SvOK(sv)) /* is it defined ? */
1917 (void)SvPOK_only(sv);
1919 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1922 if (SvTYPE(TARG) < SVt_PVLV) {
1923 sv_upgrade(TARG, SVt_PVLV);
1924 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1928 if (LvTARG(TARG) != sv) {
1930 SvREFCNT_dec(LvTARG(TARG));
1931 LvTARG(TARG) = SvREFCNT_inc(sv);
1933 LvTARGOFF(TARG) = pos;
1934 LvTARGLEN(TARG) = rem;
1937 sv_insert(sv, pos, rem, repl, repl_len);
1940 PUSHs(TARG); /* avoid SvSETMAGIC here */
1947 register I32 size = POPi;
1948 register I32 offset = POPi;
1949 register SV *src = POPs;
1950 I32 lvalue = PL_op->op_flags & OPf_MOD;
1952 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1953 unsigned long retnum;
1956 SvTAINTED_off(TARG); /* decontaminate */
1957 offset *= size; /* turn into bit offset */
1958 len = (offset + size + 7) / 8;
1959 if (offset < 0 || size < 1)
1962 if (lvalue) { /* it's an lvalue! */
1963 if (SvTYPE(TARG) < SVt_PVLV) {
1964 sv_upgrade(TARG, SVt_PVLV);
1965 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1969 if (LvTARG(TARG) != src) {
1971 SvREFCNT_dec(LvTARG(TARG));
1972 LvTARG(TARG) = SvREFCNT_inc(src);
1974 LvTARGOFF(TARG) = offset;
1975 LvTARGLEN(TARG) = size;
1983 if (offset >= srclen)
1986 retnum = (unsigned long) s[offset] << 8;
1988 else if (size == 32) {
1989 if (offset >= srclen)
1991 else if (offset + 1 >= srclen)
1992 retnum = (unsigned long) s[offset] << 24;
1993 else if (offset + 2 >= srclen)
1994 retnum = ((unsigned long) s[offset] << 24) +
1995 ((unsigned long) s[offset + 1] << 16);
1997 retnum = ((unsigned long) s[offset] << 24) +
1998 ((unsigned long) s[offset + 1] << 16) +
1999 (s[offset + 2] << 8);
2004 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2009 else if (size == 16)
2010 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2011 else if (size == 32)
2012 retnum = ((unsigned long) s[offset] << 24) +
2013 ((unsigned long) s[offset + 1] << 16) +
2014 (s[offset + 2] << 8) + s[offset+3];
2018 sv_setuv(TARG, (UV)retnum);
2033 I32 arybase = PL_curcop->cop_arybase;
2038 offset = POPi - arybase;
2041 tmps = SvPV(big, biglen);
2042 if (IN_UTF8 && offset > 0)
2043 sv_pos_u2b(big, &offset, 0);
2046 else if (offset > biglen)
2048 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2049 (unsigned char*)tmps + biglen, little, 0)))
2052 retval = tmps2 - tmps;
2053 if (IN_UTF8 && retval > 0)
2054 sv_pos_b2u(big, &retval);
2055 PUSHi(retval + arybase);
2070 I32 arybase = PL_curcop->cop_arybase;
2076 tmps2 = SvPV(little, llen);
2077 tmps = SvPV(big, blen);
2081 if (IN_UTF8 && offset > 0)
2082 sv_pos_u2b(big, &offset, 0);
2083 offset = offset - arybase + llen;
2087 else if (offset > blen)
2089 if (!(tmps2 = rninstr(tmps, tmps + offset,
2090 tmps2, tmps2 + llen)))
2093 retval = tmps2 - tmps;
2094 if (IN_UTF8 && retval > 0)
2095 sv_pos_b2u(big, &retval);
2096 PUSHi(retval + arybase);
2102 djSP; dMARK; dORIGMARK; dTARGET;
2103 #ifdef USE_LOCALE_NUMERIC
2104 if (PL_op->op_private & OPpLOCALE)
2105 SET_NUMERIC_LOCAL();
2107 SET_NUMERIC_STANDARD();
2109 do_sprintf(TARG, SP-MARK, MARK+1);
2110 TAINT_IF(SvTAINTED(TARG));
2120 U8 *tmps = (U8*)POPp;
2123 if (IN_UTF8 && (*tmps & 0x80))
2124 value = (I32) utf8_to_uv(tmps, &retlen);
2126 value = (I32) (*tmps & 255);
2137 (void)SvUPGRADE(TARG,SVt_PV);
2139 if (IN_UTF8 && value >= 128) {
2142 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2143 SvCUR_set(TARG, tmps - SvPVX(TARG));
2145 (void)SvPOK_only(TARG);
2155 (void)SvPOK_only(TARG);
2162 djSP; dTARGET; dPOPTOPssrl;
2164 char *tmps = SvPV(left, PL_na);
2166 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2168 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2172 "The crypt() function is unimplemented due to excessive paranoia.");
2185 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2189 UV uv = utf8_to_uv(s, &ulen);
2191 if (PL_op->op_private & OPpLOCALE) {
2194 uv = toTITLE_LC_uni(uv);
2197 uv = toTITLE_utf8(s);
2199 tend = uv_to_utf8(tmpbuf, uv);
2201 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2203 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2204 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2208 s = (U8*)SvPV_force(sv, slen);
2209 Copy(tmpbuf, s, ulen, U8);
2214 if (!SvPADTMP(sv)) {
2220 s = (U8*)SvPV_force(sv, PL_na);
2222 if (PL_op->op_private & OPpLOCALE) {
2225 *s = toUPPER_LC(*s);
2241 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2245 UV uv = utf8_to_uv(s, &ulen);
2247 if (PL_op->op_private & OPpLOCALE) {
2250 uv = toLOWER_LC_uni(uv);
2253 uv = toLOWER_utf8(s);
2255 tend = uv_to_utf8(tmpbuf, uv);
2257 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2259 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2260 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2264 s = (U8*)SvPV_force(sv, slen);
2265 Copy(tmpbuf, s, ulen, U8);
2270 if (!SvPADTMP(sv)) {
2276 s = (U8*)SvPV_force(sv, PL_na);
2278 if (PL_op->op_private & OPpLOCALE) {
2281 *s = toLOWER_LC(*s);
2304 s = (U8*)SvPV(sv,len);
2306 sv_setpvn(TARG, "", 0);
2311 (void)SvUPGRADE(TARG, SVt_PV);
2312 SvGROW(TARG, (len * 2) + 1);
2313 (void)SvPOK_only(TARG);
2314 d = (U8*)SvPVX(TARG);
2316 if (PL_op->op_private & OPpLOCALE) {
2320 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2326 d = uv_to_utf8(d, toUPPER_utf8( s ));
2331 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2336 if (!SvPADTMP(sv)) {
2343 s = (U8*)SvPV_force(sv, len);
2345 register U8 *send = s + len;
2347 if (PL_op->op_private & OPpLOCALE) {
2350 for (; s < send; s++)
2351 *s = toUPPER_LC(*s);
2354 for (; s < send; s++)
2374 s = (U8*)SvPV(sv,len);
2376 sv_setpvn(TARG, "", 0);
2381 (void)SvUPGRADE(TARG, SVt_PV);
2382 SvGROW(TARG, (len * 2) + 1);
2383 (void)SvPOK_only(TARG);
2384 d = (U8*)SvPVX(TARG);
2386 if (PL_op->op_private & OPpLOCALE) {
2390 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2396 d = uv_to_utf8(d, toLOWER_utf8(s));
2401 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2406 if (!SvPADTMP(sv)) {
2413 s = (U8*)SvPV_force(sv, len);
2415 register U8 *send = s + len;
2417 if (PL_op->op_private & OPpLOCALE) {
2420 for (; s < send; s++)
2421 *s = toLOWER_LC(*s);
2424 for (; s < send; s++)
2436 register char *s = SvPV(sv,len);
2440 (void)SvUPGRADE(TARG, SVt_PV);
2441 SvGROW(TARG, (len * 2) + 1);
2444 if (!(*s & 0x80) && !isALNUM(*s))
2449 SvCUR_set(TARG, d - SvPVX(TARG));
2450 (void)SvPOK_only(TARG);
2453 sv_setpvn(TARG, s, len);
2462 djSP; dMARK; dORIGMARK;
2464 register AV* av = (AV*)POPs;
2465 register I32 lval = PL_op->op_flags & OPf_MOD;
2466 I32 arybase = PL_curcop->cop_arybase;
2469 if (SvTYPE(av) == SVt_PVAV) {
2470 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2472 for (svp = MARK + 1; svp <= SP; svp++) {
2477 if (max > AvMAX(av))
2480 while (++MARK <= SP) {
2481 elem = SvIVx(*MARK);
2485 svp = av_fetch(av, elem, lval);
2487 if (!svp || *svp == &PL_sv_undef)
2488 DIE(no_aelem, elem);
2489 if (PL_op->op_private & OPpLVAL_INTRO)
2490 save_aelem(av, elem, svp);
2492 *MARK = svp ? *svp : &PL_sv_undef;
2495 if (GIMME != G_ARRAY) {
2503 /* Associative arrays. */
2508 HV *hash = (HV*)POPs;
2510 I32 gimme = GIMME_V;
2511 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2514 /* might clobber stack_sp */
2515 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2520 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2521 if (gimme == G_ARRAY) {
2523 /* might clobber stack_sp */
2524 sv_setsv(TARG, realhv ?
2525 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2530 else if (gimme == G_SCALAR)
2549 I32 gimme = GIMME_V;
2550 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2554 if (PL_op->op_private & OPpSLICE) {
2558 hvtype = SvTYPE(hv);
2559 while (++MARK <= SP) {
2560 if (hvtype == SVt_PVHV)
2561 sv = hv_delete_ent(hv, *MARK, discard, 0);
2563 DIE("Not a HASH reference");
2564 *MARK = sv ? sv : &PL_sv_undef;
2568 else if (gimme == G_SCALAR) {
2577 if (SvTYPE(hv) == SVt_PVHV)
2578 sv = hv_delete_ent(hv, keysv, discard, 0);
2580 DIE("Not a HASH reference");
2594 if (SvTYPE(hv) == SVt_PVHV) {
2595 if (hv_exists_ent(hv, tmpsv, 0))
2597 } else if (SvTYPE(hv) == SVt_PVAV) {
2598 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2601 DIE("Not a HASH reference");
2608 djSP; dMARK; dORIGMARK;
2609 register HV *hv = (HV*)POPs;
2610 register I32 lval = PL_op->op_flags & OPf_MOD;
2611 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2613 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2614 DIE("Can't localize pseudo-hash element");
2616 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2617 while (++MARK <= SP) {
2621 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2622 svp = he ? &HeVAL(he) : 0;
2624 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2627 if (!svp || *svp == &PL_sv_undef)
2628 DIE(no_helem, SvPV(keysv, PL_na));
2629 if (PL_op->op_private & OPpLVAL_INTRO)
2630 save_helem(hv, keysv, svp);
2632 *MARK = svp ? *svp : &PL_sv_undef;
2635 if (GIMME != G_ARRAY) {
2643 /* List operators. */
2648 if (GIMME != G_ARRAY) {
2650 *MARK = *SP; /* unwanted list, return last item */
2652 *MARK = &PL_sv_undef;
2661 SV **lastrelem = PL_stack_sp;
2662 SV **lastlelem = PL_stack_base + POPMARK;
2663 SV **firstlelem = PL_stack_base + POPMARK + 1;
2664 register SV **firstrelem = lastlelem + 1;
2665 I32 arybase = PL_curcop->cop_arybase;
2666 I32 lval = PL_op->op_flags & OPf_MOD;
2667 I32 is_something_there = lval;
2669 register I32 max = lastrelem - lastlelem;
2670 register SV **lelem;
2673 if (GIMME != G_ARRAY) {
2674 ix = SvIVx(*lastlelem);
2679 if (ix < 0 || ix >= max)
2680 *firstlelem = &PL_sv_undef;
2682 *firstlelem = firstrelem[ix];
2688 SP = firstlelem - 1;
2692 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2697 *lelem = &PL_sv_undef;
2698 else if (!(*lelem = firstrelem[ix]))
2699 *lelem = &PL_sv_undef;
2703 if (ix >= max || !(*lelem = firstrelem[ix]))
2704 *lelem = &PL_sv_undef;
2706 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2707 is_something_there = TRUE;
2709 if (is_something_there)
2712 SP = firstlelem - 1;
2718 djSP; dMARK; dORIGMARK;
2719 I32 items = SP - MARK;
2720 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2721 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2728 djSP; dMARK; dORIGMARK;
2729 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2733 SV *val = NEWSV(46, 0);
2735 sv_setsv(val, *++MARK);
2736 else if (ckWARN(WARN_UNSAFE))
2737 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2738 (void)hv_store_ent(hv,key,val,0);
2747 djSP; dMARK; dORIGMARK;
2748 register AV *ary = (AV*)*++MARK;
2752 register I32 offset;
2753 register I32 length;
2760 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2761 *MARK-- = mg->mg_obj;
2765 perl_call_method("SPLICE",GIMME_V);
2774 offset = i = SvIVx(*MARK);
2776 offset += AvFILLp(ary) + 1;
2778 offset -= PL_curcop->cop_arybase;
2782 length = SvIVx(*MARK++);
2784 length += AvFILLp(ary) - offset + 1;
2790 length = AvMAX(ary) + 1; /* close enough to infinity */
2794 length = AvMAX(ary) + 1;
2796 if (offset > AvFILLp(ary) + 1)
2797 offset = AvFILLp(ary) + 1;
2798 after = AvFILLp(ary) + 1 - (offset + length);
2799 if (after < 0) { /* not that much array */
2800 length += after; /* offset+length now in array */
2806 /* At this point, MARK .. SP-1 is our new LIST */
2809 diff = newlen - length;
2810 if (newlen && !AvREAL(ary)) {
2814 assert(AvREAL(ary)); /* would leak, so croak */
2817 if (diff < 0) { /* shrinking the area */
2819 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2820 Copy(MARK, tmparyval, newlen, SV*);
2823 MARK = ORIGMARK + 1;
2824 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2825 MEXTEND(MARK, length);
2826 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2828 EXTEND_MORTAL(length);
2829 for (i = length, dst = MARK; i; i--) {
2830 sv_2mortal(*dst); /* free them eventualy */
2837 *MARK = AvARRAY(ary)[offset+length-1];
2840 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2841 SvREFCNT_dec(*dst++); /* free them now */
2844 AvFILLp(ary) += diff;
2846 /* pull up or down? */
2848 if (offset < after) { /* easier to pull up */
2849 if (offset) { /* esp. if nothing to pull */
2850 src = &AvARRAY(ary)[offset-1];
2851 dst = src - diff; /* diff is negative */
2852 for (i = offset; i > 0; i--) /* can't trust Copy */
2856 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2860 if (after) { /* anything to pull down? */
2861 src = AvARRAY(ary) + offset + length;
2862 dst = src + diff; /* diff is negative */
2863 Move(src, dst, after, SV*);
2865 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2866 /* avoid later double free */
2870 dst[--i] = &PL_sv_undef;
2873 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2875 *dst = NEWSV(46, 0);
2876 sv_setsv(*dst++, *src++);
2878 Safefree(tmparyval);
2881 else { /* no, expanding (or same) */
2883 New(452, tmparyval, length, SV*); /* so remember deletion */
2884 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2887 if (diff > 0) { /* expanding */
2889 /* push up or down? */
2891 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2895 Move(src, dst, offset, SV*);
2897 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2899 AvFILLp(ary) += diff;
2902 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2903 av_extend(ary, AvFILLp(ary) + diff);
2904 AvFILLp(ary) += diff;
2907 dst = AvARRAY(ary) + AvFILLp(ary);
2909 for (i = after; i; i--) {
2916 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2917 *dst = NEWSV(46, 0);
2918 sv_setsv(*dst++, *src++);
2920 MARK = ORIGMARK + 1;
2921 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2923 Copy(tmparyval, MARK, length, SV*);
2925 EXTEND_MORTAL(length);
2926 for (i = length, dst = MARK; i; i--) {
2927 sv_2mortal(*dst); /* free them eventualy */
2931 Safefree(tmparyval);
2935 else if (length--) {
2936 *MARK = tmparyval[length];
2939 while (length-- > 0)
2940 SvREFCNT_dec(tmparyval[length]);
2942 Safefree(tmparyval);
2945 *MARK = &PL_sv_undef;
2953 djSP; dMARK; dORIGMARK; dTARGET;
2954 register AV *ary = (AV*)*++MARK;
2955 register SV *sv = &PL_sv_undef;
2958 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2959 *MARK-- = mg->mg_obj;
2963 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2968 /* Why no pre-extend of ary here ? */
2969 for (++MARK; MARK <= SP; MARK++) {
2972 sv_setsv(sv, *MARK);
2977 PUSHi( AvFILL(ary) + 1 );
2985 SV *sv = av_pop(av);
2987 (void)sv_2mortal(sv);
2996 SV *sv = av_shift(av);
3001 (void)sv_2mortal(sv);
3008 djSP; dMARK; dORIGMARK; dTARGET;
3009 register AV *ary = (AV*)*++MARK;
3014 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
3015 *MARK-- = mg->mg_obj;
3019 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3024 av_unshift(ary, SP - MARK);
3027 sv_setsv(sv, *++MARK);
3028 (void)av_store(ary, i++, sv);
3032 PUSHi( AvFILL(ary) + 1 );
3042 if (GIMME == G_ARRAY) {
3053 register char *down;
3059 do_join(TARG, &PL_sv_no, MARK, SP);
3061 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3062 up = SvPV_force(TARG, len);
3064 if (IN_UTF8) { /* first reverse each character */
3065 U8* s = (U8*)SvPVX(TARG);
3066 U8* send = (U8*)(s + len);
3075 down = (char*)(s - 1);
3076 if (s > send || !((*down & 0xc0) == 0x80)) {
3077 warn("Malformed UTF-8 character");
3089 down = SvPVX(TARG) + len - 1;
3095 (void)SvPOK_only(TARG);
3104 mul128(SV *sv, U8 m)
3107 char *s = SvPV(sv, len);
3111 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3112 SV *tmpNew = newSVpv("0000000000", 10);
3114 sv_catsv(tmpNew, sv);
3115 SvREFCNT_dec(sv); /* free old sv */
3120 while (!*t) /* trailing '\0'? */
3123 i = ((*t - '0') << 7) + m;
3124 *(t--) = '0' + (i % 10);
3130 /* Explosives and implosives. */
3132 static const char uuemap[] =
3133 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3134 static char uudmap[256]; /* Initialised on first use */
3135 #if 'I' == 73 && 'J' == 74
3136 /* On an ASCII/ISO kind of system */
3137 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3140 Some other sort of character set - use memchr() so we don't match
3143 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3151 I32 gimme = GIMME_V;
3155 register char *pat = SvPV(left, llen);
3156 register char *s = SvPV(right, rlen);
3157 char *strend = s + rlen;
3159 register char *patend = pat + llen;
3164 /* These must not be in registers: */
3175 unsigned Quad_t auquad;
3181 register U32 culong;
3183 static char* bitcount = 0;
3186 if (gimme != G_ARRAY) { /* arrange to do first one only */
3188 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3189 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3191 while (isDIGIT(*patend) || *patend == '*')
3197 while (pat < patend) {
3199 datumtype = *pat++ & 0xFF;
3200 if (isSPACE(datumtype))
3204 else if (*pat == '*') {
3205 len = strend - strbeg; /* long enough */
3208 else if (isDIGIT(*pat)) {
3210 while (isDIGIT(*pat))
3211 len = (len * 10) + (*pat++ - '0');
3214 len = (datumtype != '@');
3217 croak("Invalid type in unpack: '%c'", (int)datumtype);
3218 case ',': /* grandfather in commas but with a warning */
3219 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3220 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3223 if (len == 1 && pat[-1] != '1')
3232 if (len > strend - strbeg)
3233 DIE("@ outside of string");
3237 if (len > s - strbeg)
3238 DIE("X outside of string");
3242 if (len > strend - s)
3243 DIE("x outside of string");
3248 if (len > strend - s)
3251 goto uchar_checksum;
3252 sv = NEWSV(35, len);
3253 sv_setpvn(sv, s, len);
3255 if (datumtype == 'A') {
3256 aptr = s; /* borrow register */
3257 s = SvPVX(sv) + len - 1;
3258 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3261 SvCUR_set(sv, s - SvPVX(sv));
3262 s = aptr; /* unborrow register */
3264 XPUSHs(sv_2mortal(sv));
3268 if (pat[-1] == '*' || len > (strend - s) * 8)
3269 len = (strend - s) * 8;
3272 Newz(601, bitcount, 256, char);
3273 for (bits = 1; bits < 256; bits++) {
3274 if (bits & 1) bitcount[bits]++;
3275 if (bits & 2) bitcount[bits]++;
3276 if (bits & 4) bitcount[bits]++;
3277 if (bits & 8) bitcount[bits]++;
3278 if (bits & 16) bitcount[bits]++;
3279 if (bits & 32) bitcount[bits]++;
3280 if (bits & 64) bitcount[bits]++;
3281 if (bits & 128) bitcount[bits]++;
3285 culong += bitcount[*(unsigned char*)s++];
3290 if (datumtype == 'b') {
3292 if (bits & 1) culong++;
3298 if (bits & 128) culong++;
3305 sv = NEWSV(35, len + 1);
3308 aptr = pat; /* borrow register */
3310 if (datumtype == 'b') {
3312 for (len = 0; len < aint; len++) {
3313 if (len & 7) /*SUPPRESS 595*/
3317 *pat++ = '0' + (bits & 1);
3322 for (len = 0; len < aint; len++) {
3327 *pat++ = '0' + ((bits & 128) != 0);
3331 pat = aptr; /* unborrow register */
3332 XPUSHs(sv_2mortal(sv));
3336 if (pat[-1] == '*' || len > (strend - s) * 2)
3337 len = (strend - s) * 2;
3338 sv = NEWSV(35, len + 1);
3341 aptr = pat; /* borrow register */
3343 if (datumtype == 'h') {
3345 for (len = 0; len < aint; len++) {
3350 *pat++ = PL_hexdigit[bits & 15];
3355 for (len = 0; len < aint; len++) {
3360 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3364 pat = aptr; /* unborrow register */
3365 XPUSHs(sv_2mortal(sv));
3368 if (len > strend - s)
3373 if (aint >= 128) /* fake up signed chars */
3383 if (aint >= 128) /* fake up signed chars */
3386 sv_setiv(sv, (IV)aint);
3387 PUSHs(sv_2mortal(sv));
3392 if (len > strend - s)
3407 sv_setiv(sv, (IV)auint);
3408 PUSHs(sv_2mortal(sv));
3413 if (len > strend - s)
3416 while (len-- > 0 && s < strend) {
3417 auint = utf8_to_uv((U8*)s, &along);
3420 cdouble += (double)auint;
3428 while (len-- > 0 && s < strend) {
3429 auint = utf8_to_uv((U8*)s, &along);
3432 sv_setiv(sv, (IV)auint);
3433 PUSHs(sv_2mortal(sv));
3438 along = (strend - s) / SIZE16;
3455 sv_setiv(sv, (IV)ashort);
3456 PUSHs(sv_2mortal(sv));
3463 along = (strend - s) / SIZE16;
3468 COPY16(s, &aushort);
3471 if (datumtype == 'n')
3472 aushort = PerlSock_ntohs(aushort);
3475 if (datumtype == 'v')
3476 aushort = vtohs(aushort);
3485 COPY16(s, &aushort);
3489 if (datumtype == 'n')
3490 aushort = PerlSock_ntohs(aushort);
3493 if (datumtype == 'v')
3494 aushort = vtohs(aushort);
3496 sv_setiv(sv, (IV)aushort);
3497 PUSHs(sv_2mortal(sv));
3502 along = (strend - s) / sizeof(int);
3507 Copy(s, &aint, 1, int);
3510 cdouble += (double)aint;
3519 Copy(s, &aint, 1, int);
3523 /* Without the dummy below unpack("i", pack("i",-1))
3524 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3525 * cc with optimization turned on */
3527 sv_setiv(sv, (IV)aint) :
3529 sv_setiv(sv, (IV)aint);
3530 PUSHs(sv_2mortal(sv));
3535 along = (strend - s) / sizeof(unsigned int);
3540 Copy(s, &auint, 1, unsigned int);
3541 s += sizeof(unsigned int);
3543 cdouble += (double)auint;
3552 Copy(s, &auint, 1, unsigned int);
3553 s += sizeof(unsigned int);
3555 sv_setuv(sv, (UV)auint);
3556 PUSHs(sv_2mortal(sv));
3561 along = (strend - s) / SIZE32;
3569 cdouble += (double)along;
3581 sv_setiv(sv, (IV)along);
3582 PUSHs(sv_2mortal(sv));
3589 along = (strend - s) / SIZE32;
3597 if (datumtype == 'N')
3598 aulong = PerlSock_ntohl(aulong);
3601 if (datumtype == 'V')
3602 aulong = vtohl(aulong);
3605 cdouble += (double)aulong;
3617 if (datumtype == 'N')
3618 aulong = PerlSock_ntohl(aulong);
3621 if (datumtype == 'V')
3622 aulong = vtohl(aulong);
3625 sv_setuv(sv, (UV)aulong);
3626 PUSHs(sv_2mortal(sv));
3631 along = (strend - s) / sizeof(char*);
3637 if (sizeof(char*) > strend - s)
3640 Copy(s, &aptr, 1, char*);
3646 PUSHs(sv_2mortal(sv));
3656 while ((len > 0) && (s < strend)) {
3657 auv = (auv << 7) | (*s & 0x7f);
3658 if (!(*s++ & 0x80)) {
3662 PUSHs(sv_2mortal(sv));
3666 else if (++bytes >= sizeof(UV)) { /* promote to string */
3669 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3670 while (s < strend) {
3671 sv = mul128(sv, *s & 0x7f);
3672 if (!(*s++ & 0x80)) {
3677 t = SvPV(sv, PL_na);
3681 PUSHs(sv_2mortal(sv));
3686 if ((s >= strend) && bytes)
3687 croak("Unterminated compressed integer");
3692 if (sizeof(char*) > strend - s)
3695 Copy(s, &aptr, 1, char*);
3700 sv_setpvn(sv, aptr, len);
3701 PUSHs(sv_2mortal(sv));
3705 along = (strend - s) / sizeof(Quad_t);
3711 if (s + sizeof(Quad_t) > strend)
3714 Copy(s, &aquad, 1, Quad_t);
3715 s += sizeof(Quad_t);
3718 if (aquad >= IV_MIN && aquad <= IV_MAX)
3719 sv_setiv(sv, (IV)aquad);
3721 sv_setnv(sv, (double)aquad);
3722 PUSHs(sv_2mortal(sv));
3726 along = (strend - s) / sizeof(Quad_t);
3732 if (s + sizeof(unsigned Quad_t) > strend)
3735 Copy(s, &auquad, 1, unsigned Quad_t);
3736 s += sizeof(unsigned Quad_t);
3739 if (auquad <= UV_MAX)
3740 sv_setuv(sv, (UV)auquad);
3742 sv_setnv(sv, (double)auquad);
3743 PUSHs(sv_2mortal(sv));
3747 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3750 along = (strend - s) / sizeof(float);
3755 Copy(s, &afloat, 1, float);
3764 Copy(s, &afloat, 1, float);
3767 sv_setnv(sv, (double)afloat);
3768 PUSHs(sv_2mortal(sv));
3774 along = (strend - s) / sizeof(double);
3779 Copy(s, &adouble, 1, double);
3780 s += sizeof(double);
3788 Copy(s, &adouble, 1, double);
3789 s += sizeof(double);
3791 sv_setnv(sv, (double)adouble);
3792 PUSHs(sv_2mortal(sv));
3798 * Initialise the decode mapping. By using a table driven
3799 * algorithm, the code will be character-set independent
3800 * (and just as fast as doing character arithmetic)
3802 if (uudmap['M'] == 0) {
3805 for (i = 0; i < sizeof(uuemap); i += 1)
3806 uudmap[uuemap[i]] = i;
3808 * Because ' ' and '`' map to the same value,
3809 * we need to decode them both the same.
3814 along = (strend - s) * 3 / 4;
3815 sv = NEWSV(42, along);
3818 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3823 len = uudmap[*s++] & 077;
3825 if (s < strend && ISUUCHAR(*s))
3826 a = uudmap[*s++] & 077;
3829 if (s < strend && ISUUCHAR(*s))
3830 b = uudmap[*s++] & 077;
3833 if (s < strend && ISUUCHAR(*s))
3834 c = uudmap[*s++] & 077;
3837 if (s < strend && ISUUCHAR(*s))
3838 d = uudmap[*s++] & 077;
3841 hunk[0] = (a << 2) | (b >> 4);
3842 hunk[1] = (b << 4) | (c >> 2);
3843 hunk[2] = (c << 6) | d;
3844 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3849 else if (s[1] == '\n') /* possible checksum byte */
3852 XPUSHs(sv_2mortal(sv));
3857 if (strchr("fFdD", datumtype) ||
3858 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3862 while (checksum >= 16) {
3866 while (checksum >= 4) {
3872 along = (1 << checksum) - 1;
3873 while (cdouble < 0.0)
3875 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3876 sv_setnv(sv, cdouble);
3879 if (checksum < 32) {
3880 aulong = (1 << checksum) - 1;
3883 sv_setuv(sv, (UV)culong);
3885 XPUSHs(sv_2mortal(sv));
3889 if (SP == oldsp && gimme == G_SCALAR)
3890 PUSHs(&PL_sv_undef);
3895 doencodes(register SV *sv, register char *s, register I32 len)
3899 *hunk = uuemap[len];
3900 sv_catpvn(sv, hunk, 1);
3903 hunk[0] = uuemap[(077 & (*s >> 2))];
3904 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3905 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3906 hunk[3] = uuemap[(077 & (s[2] & 077))];
3907 sv_catpvn(sv, hunk, 4);
3912 char r = (len > 1 ? s[1] : '\0');
3913 hunk[0] = uuemap[(077 & (*s >> 2))];
3914 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3915 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3916 hunk[3] = uuemap[0];
3917 sv_catpvn(sv, hunk, 4);
3919 sv_catpvn(sv, "\n", 1);
3923 is_an_int(char *s, STRLEN l)
3925 SV *result = newSVpv("", l);
3926 char *result_c = SvPV(result, PL_na); /* convenience */
3927 char *out = result_c;
3937 SvREFCNT_dec(result);
3960 SvREFCNT_dec(result);
3966 SvCUR_set(result, out - result_c);
3971 div128(SV *pnum, bool *done)
3972 /* must be '\0' terminated */
3976 char *s = SvPV(pnum, len);
3985 i = m * 10 + (*t - '0');
3987 r = (i >> 7); /* r < 10 */
3994 SvCUR_set(pnum, (STRLEN) (t - s));
4001 djSP; dMARK; dORIGMARK; dTARGET;
4002 register SV *cat = TARG;
4005 register char *pat = SvPVx(*++MARK, fromlen);
4006 register char *patend = pat + fromlen;
4011 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4012 static char *space10 = " ";
4014 /* These must not be in registers: */
4023 unsigned Quad_t auquad;
4032 sv_setpvn(cat, "", 0);
4033 while (pat < patend) {
4034 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4035 datumtype = *pat++ & 0xFF;
4036 if (isSPACE(datumtype))
4039 len = strchr("@Xxu", datumtype) ? 0 : items;
4042 else if (isDIGIT(*pat)) {
4044 while (isDIGIT(*pat))
4045 len = (len * 10) + (*pat++ - '0');
4051 croak("Invalid type in pack: '%c'", (int)datumtype);
4052 case ',': /* grandfather in commas but with a warning */
4053 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4054 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4057 DIE("%% may only be used in unpack");
4068 if (SvCUR(cat) < len)
4069 DIE("X outside of string");
4076 sv_catpvn(cat, null10, 10);
4079 sv_catpvn(cat, null10, len);
4084 aptr = SvPV(fromstr, fromlen);
4088 sv_catpvn(cat, aptr, len);
4090 sv_catpvn(cat, aptr, fromlen);
4092 if (datumtype == 'A') {
4094 sv_catpvn(cat, space10, 10);
4097 sv_catpvn(cat, space10, len);
4101 sv_catpvn(cat, null10, 10);
4104 sv_catpvn(cat, null10, len);
4111 char *savepat = pat;
4116 aptr = SvPV(fromstr, fromlen);
4121 SvCUR(cat) += (len+7)/8;
4122 SvGROW(cat, SvCUR(cat) + 1);
4123 aptr = SvPVX(cat) + aint;
4128 if (datumtype == 'B') {
4129 for (len = 0; len++ < aint;) {
4130 items |= *pat++ & 1;
4134 *aptr++ = items & 0xff;
4140 for (len = 0; len++ < aint;) {
4146 *aptr++ = items & 0xff;
4152 if (datumtype == 'B')
4153 items <<= 7 - (aint & 7);
4155 items >>= 7 - (aint & 7);
4156 *aptr++ = items & 0xff;
4158 pat = SvPVX(cat) + SvCUR(cat);
4169 char *savepat = pat;
4174 aptr = SvPV(fromstr, fromlen);
4179 SvCUR(cat) += (len+1)/2;
4180 SvGROW(cat, SvCUR(cat) + 1);
4181 aptr = SvPVX(cat) + aint;
4186 if (datumtype == 'H') {
4187 for (len = 0; len++ < aint;) {
4189 items |= ((*pat++ & 15) + 9) & 15;
4191 items |= *pat++ & 15;
4195 *aptr++ = items & 0xff;
4201 for (len = 0; len++ < aint;) {
4203 items |= (((*pat++ & 15) + 9) & 15) << 4;
4205 items |= (*pat++ & 15) << 4;
4209 *aptr++ = items & 0xff;
4215 *aptr++ = items & 0xff;
4216 pat = SvPVX(cat) + SvCUR(cat);
4228 aint = SvIV(fromstr);
4230 sv_catpvn(cat, &achar, sizeof(char));
4236 auint = SvUV(fromstr);
4237 SvGROW(cat, SvCUR(cat) + 10);
4238 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4243 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4248 afloat = (float)SvNV(fromstr);
4249 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4256 adouble = (double)SvNV(fromstr);
4257 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4263 ashort = (I16)SvIV(fromstr);
4265 ashort = PerlSock_htons(ashort);
4267 CAT16(cat, &ashort);
4273 ashort = (I16)SvIV(fromstr);
4275 ashort = htovs(ashort);
4277 CAT16(cat, &ashort);
4284 ashort = (I16)SvIV(fromstr);
4285 CAT16(cat, &ashort);
4291 auint = SvUV(fromstr);
4292 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4298 adouble = floor(SvNV(fromstr));
4301 croak("Cannot compress negative numbers");
4307 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4308 adouble <= UV_MAX_cxux
4315 char buf[1 + sizeof(UV)];
4316 char *in = buf + sizeof(buf);
4317 UV auv = U_V(adouble);;
4320 *--in = (auv & 0x7f) | 0x80;
4323 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4324 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4326 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4327 char *from, *result, *in;
4332 /* Copy string and check for compliance */
4333 from = SvPV(fromstr, len);
4334 if ((norm = is_an_int(from, len)) == NULL)
4335 croak("can compress only unsigned integer");
4337 New('w', result, len, char);
4341 *--in = div128(norm, &done) | 0x80;
4342 result[len - 1] &= 0x7F; /* clear continue bit */
4343 sv_catpvn(cat, in, (result + len) - in);
4345 SvREFCNT_dec(norm); /* free norm */
4347 else if (SvNOKp(fromstr)) {
4348 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4349 char *in = buf + sizeof(buf);
4352 double next = floor(adouble / 128);
4353 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4354 if (--in < buf) /* this cannot happen ;-) */
4355 croak ("Cannot compress integer");
4357 } while (adouble > 0);
4358 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4359 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4362 croak("Cannot compress non integer");
4368 aint = SvIV(fromstr);
4369 sv_catpvn(cat, (char*)&aint, sizeof(int));
4375 aulong = SvUV(fromstr);
4377 aulong = PerlSock_htonl(aulong);
4379 CAT32(cat, &aulong);
4385 aulong = SvUV(fromstr);
4387 aulong = htovl(aulong);
4389 CAT32(cat, &aulong);
4395 aulong = SvUV(fromstr);
4396 CAT32(cat, &aulong);
4402 along = SvIV(fromstr);
4410 auquad = (unsigned Quad_t)SvIV(fromstr);
4411 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4417 aquad = (Quad_t)SvIV(fromstr);
4418 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4421 #endif /* HAS_QUAD */
4423 len = 1; /* assume SV is correct length */
4428 if (fromstr == &PL_sv_undef)
4431 /* XXX better yet, could spirit away the string to
4432 * a safe spot and hang on to it until the result
4433 * of pack() (and all copies of the result) are
4436 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4438 "Attempt to pack pointer to temporary value");
4439 if (SvPOK(fromstr) || SvNIOK(fromstr))
4440 aptr = SvPV(fromstr,PL_na);
4442 aptr = SvPV_force(fromstr,PL_na);
4444 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4449 aptr = SvPV(fromstr, fromlen);
4450 SvGROW(cat, fromlen * 4 / 3);
4455 while (fromlen > 0) {
4462 doencodes(cat, aptr, todo);
4481 register I32 limit = POPi; /* note, negative is forever */
4484 register char *s = SvPV(sv, len);
4485 char *strend = s + len;
4487 register REGEXP *rx;
4491 I32 maxiters = (strend - s) + 10;
4494 I32 origlimit = limit;
4497 AV *oldstack = PL_curstack;
4498 I32 gimme = GIMME_V;
4499 I32 oldsave = PL_savestack_ix;
4500 I32 make_mortal = 1;
4501 MAGIC *mg = (MAGIC *) NULL;
4504 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4509 DIE("panic: do_split");
4510 rx = pm->op_pmregexp;
4512 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4513 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4515 if (pm->op_pmreplroot)
4516 ary = GvAVn((GV*)pm->op_pmreplroot);
4517 else if (gimme != G_ARRAY)
4519 ary = (AV*)PL_curpad[0];
4521 ary = GvAVn(PL_defgv);
4522 #endif /* USE_THREADS */
4525 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4531 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4538 for (i = AvFILLp(ary); i >= 0; i--)
4539 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4541 /* temporarily switch stacks */
4542 SWITCHSTACK(PL_curstack, ary);
4546 base = SP - PL_stack_base;
4548 if (pm->op_pmflags & PMf_SKIPWHITE) {
4549 if (pm->op_pmflags & PMf_LOCALE) {
4550 while (isSPACE_LC(*s))
4558 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4559 SAVEINT(PL_multiline);
4560 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4564 limit = maxiters + 2;
4565 if (pm->op_pmflags & PMf_WHITE) {
4568 while (m < strend &&
4569 !((pm->op_pmflags & PMf_LOCALE)
4570 ? isSPACE_LC(*m) : isSPACE(*m)))
4575 dstr = NEWSV(30, m-s);
4576 sv_setpvn(dstr, s, m-s);
4582 while (s < strend &&
4583 ((pm->op_pmflags & PMf_LOCALE)
4584 ? isSPACE_LC(*s) : isSPACE(*s)))
4588 else if (strEQ("^", rx->precomp)) {
4591 for (m = s; m < strend && *m != '\n'; m++) ;
4595 dstr = NEWSV(30, m-s);
4596 sv_setpvn(dstr, s, m-s);
4603 else if (rx->check_substr && !rx->nparens
4604 && (rx->reganch & ROPT_CHECK_ALL)
4605 && !(rx->reganch & ROPT_ANCH)) {
4606 i = SvCUR(rx->check_substr);
4607 if (i == 1 && !SvTAIL(rx->check_substr)) {
4608 i = *SvPVX(rx->check_substr);
4611 for (m = s; m < strend && *m != i; m++) ;
4614 dstr = NEWSV(30, m-s);
4615 sv_setpvn(dstr, s, m-s);
4624 while (s < strend && --limit &&
4625 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4626 rx->check_substr, 0)) )
4629 dstr = NEWSV(31, m-s);
4630 sv_setpvn(dstr, s, m-s);
4639 maxiters += (strend - s) * rx->nparens;
4640 while (s < strend && --limit &&
4641 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4643 TAINT_IF(RX_MATCH_TAINTED(rx));
4645 && rx->subbase != orig) {
4650 strend = s + (strend - m);
4653 dstr = NEWSV(32, m-s);
4654 sv_setpvn(dstr, s, m-s);
4659 for (i = 1; i <= rx->nparens; i++) {
4663 dstr = NEWSV(33, m-s);
4664 sv_setpvn(dstr, s, m-s);
4667 dstr = NEWSV(33, 0);
4677 LEAVE_SCOPE(oldsave);
4678 iters = (SP - PL_stack_base) - base;
4679 if (iters > maxiters)
4682 /* keep field after final delim? */
4683 if (s < strend || (iters && origlimit)) {
4684 dstr = NEWSV(34, strend-s);
4685 sv_setpvn(dstr, s, strend-s);
4691 else if (!origlimit) {
4692 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4698 SWITCHSTACK(ary, oldstack);
4699 if (SvSMAGICAL(ary)) {
4704 if (gimme == G_ARRAY) {
4706 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4714 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4717 if (gimme == G_ARRAY) {
4718 /* EXTEND should not be needed - we just popped them */
4720 for (i=0; i < iters; i++) {
4721 SV **svp = av_fetch(ary, i, FALSE);
4722 PUSHs((svp) ? *svp : &PL_sv_undef);
4729 if (gimme == G_ARRAY)
4732 if (iters || !pm->op_pmreplroot) {
4742 unlock_condpair(void *svv)
4745 MAGIC *mg = mg_find((SV*)svv, 'm');
4748 croak("panic: unlock_condpair unlocking non-mutex");
4749 MUTEX_LOCK(MgMUTEXP(mg));
4750 if (MgOWNER(mg) != thr)
4751 croak("panic: unlock_condpair unlocking mutex that we don't own");
4753 COND_SIGNAL(MgOWNERCONDP(mg));
4754 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4755 (unsigned long)thr, (unsigned long)svv);)
4756 MUTEX_UNLOCK(MgMUTEXP(mg));
4758 #endif /* USE_THREADS */
4771 mg = condpair_magic(sv);
4772 MUTEX_LOCK(MgMUTEXP(mg));
4773 if (MgOWNER(mg) == thr)
4774 MUTEX_UNLOCK(MgMUTEXP(mg));
4777 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4779 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4780 (unsigned long)thr, (unsigned long)sv);)
4781 MUTEX_UNLOCK(MgMUTEXP(mg));
4782 SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
4783 save_destructor(unlock_condpair, sv);
4785 #endif /* USE_THREADS */
4786 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4787 || SvTYPE(retsv) == SVt_PVCV) {
4788 retsv = refto(retsv);
4799 if (PL_op->op_private & OPpLVAL_INTRO)
4800 PUSHs(*save_threadsv(PL_op->op_targ));
4802 PUSHs(THREADSV(PL_op->op_targ));
4805 DIE("tried to access per-thread data in non-threaded perl");
4806 #endif /* USE_THREADS */