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 == '-' ? '+' : '-';
1319 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8(s)) {
1320 sv_setpvn(TARG, "-", 1);
1324 sv_setnv(TARG, -SvNV(sv));
1336 djSP; tryAMAGICunSET(not);
1337 #endif /* OVERLOAD */
1338 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1344 djSP; dTARGET; tryAMAGICun(compl);
1348 if (PL_op->op_private & HINT_INTEGER) {
1349 IBW value = ~SvIV(sv);
1353 UBW value = ~SvUV(sv);
1358 register char *tmps;
1359 register long *tmpl;
1364 tmps = SvPV_force(TARG, len);
1367 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1370 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1374 for ( ; anum > 0; anum--, tmps++)
1383 /* integer versions of some of the above */
1387 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1390 SETi( left * right );
1397 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1401 DIE("Illegal division by zero");
1402 value = POPi / value;
1410 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1414 DIE("Illegal modulus zero");
1415 SETi( left % right );
1422 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1425 SETi( left + right );
1432 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1435 SETi( left - right );
1442 djSP; tryAMAGICbinSET(lt,0);
1445 SETs(boolSV(left < right));
1452 djSP; tryAMAGICbinSET(gt,0);
1455 SETs(boolSV(left > right));
1462 djSP; tryAMAGICbinSET(le,0);
1465 SETs(boolSV(left <= right));
1472 djSP; tryAMAGICbinSET(ge,0);
1475 SETs(boolSV(left >= right));
1482 djSP; tryAMAGICbinSET(eq,0);
1485 SETs(boolSV(left == right));
1492 djSP; tryAMAGICbinSET(ne,0);
1495 SETs(boolSV(left != right));
1502 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1509 else if (left < right)
1520 djSP; dTARGET; tryAMAGICun(neg);
1525 /* High falutin' math. */
1529 djSP; dTARGET; tryAMAGICbin(atan2,0);
1532 SETn(atan2(left, right));
1539 djSP; dTARGET; tryAMAGICun(sin);
1551 djSP; dTARGET; tryAMAGICun(cos);
1561 /* Support Configure command-line overrides for rand() functions.
1562 After 5.005, perhaps we should replace this by Configure support
1563 for drand48(), random(), or rand(). For 5.005, though, maintain
1564 compatibility by calling rand() but allow the user to override it.
1565 See INSTALL for details. --Andy Dougherty 15 July 1998
1567 /* Now it's after 5.005, and Configure supports drand48() and random(),
1568 in addition to rand(). So the overrides should not be needed any more.
1569 --Jarkko Hietaniemi 27 September 1998
1572 #ifndef HAS_DRAND48_PROTO
1573 extern double drand48 _((void));
1586 if (!srand_called) {
1587 (void)seedDrand01((Rand_seed_t)seed());
1588 srand_called = TRUE;
1603 (void)seedDrand01((Rand_seed_t)anum);
1604 srand_called = TRUE;
1613 * This is really just a quick hack which grabs various garbage
1614 * values. It really should be a real hash algorithm which
1615 * spreads the effect of every input bit onto every output bit,
1616 * if someone who knows about such things would bother to write it.
1617 * Might be a good idea to add that function to CORE as well.
1618 * No numbers below come from careful analysis or anything here,
1619 * except they are primes and SEED_C1 > 1E6 to get a full-width
1620 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1621 * probably be bigger too.
1624 # define SEED_C1 1000003
1625 #define SEED_C4 73819
1627 # define SEED_C1 25747
1628 #define SEED_C4 20639
1632 #define SEED_C5 26107
1635 #ifndef PERL_NO_DEV_RANDOM
1640 # include <starlet.h>
1641 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1642 * in 100-ns units, typically incremented ever 10 ms. */
1643 unsigned int when[2];
1645 # ifdef HAS_GETTIMEOFDAY
1646 struct timeval when;
1652 /* This test is an escape hatch, this symbol isn't set by Configure. */
1653 #ifndef PERL_NO_DEV_RANDOM
1654 #ifndef PERL_RANDOM_DEVICE
1655 /* /dev/random isn't used by default because reads from it will block
1656 * if there isn't enough entropy available. You can compile with
1657 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1658 * is enough real entropy to fill the seed. */
1659 # define PERL_RANDOM_DEVICE "/dev/urandom"
1661 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1663 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1672 _ckvmssts(sys$gettim(when));
1673 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1675 # ifdef HAS_GETTIMEOFDAY
1676 gettimeofday(&when,(struct timezone *) 0);
1677 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1680 u = (U32)SEED_C1 * when;
1683 u += SEED_C3 * (U32)getpid();
1684 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1685 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1686 u += SEED_C5 * (U32)(UV)&when;
1693 djSP; dTARGET; tryAMAGICun(exp);
1705 djSP; dTARGET; tryAMAGICun(log);
1710 SET_NUMERIC_STANDARD();
1711 DIE("Can't take log of %g", value);
1721 djSP; dTARGET; tryAMAGICun(sqrt);
1726 SET_NUMERIC_STANDARD();
1727 DIE("Can't take sqrt of %g", value);
1729 value = sqrt(value);
1739 double value = TOPn;
1742 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1748 (void)modf(value, &value);
1750 (void)modf(-value, &value);
1765 djSP; dTARGET; tryAMAGICun(abs);
1767 double value = TOPn;
1770 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1771 (iv = SvIVX(TOPs)) != IV_MIN) {
1792 XPUSHu(scan_hex(tmps, 99, &argtype));
1804 while (*tmps && isSPACE(*tmps))
1809 value = scan_hex(++tmps, 99, &argtype);
1811 value = scan_oct(tmps, 99, &argtype);
1823 SETi( sv_len_utf8(TOPs) );
1827 SETi( sv_len(TOPs) );
1841 I32 lvalue = PL_op->op_flags & OPf_MOD;
1843 I32 arybase = PL_curcop->cop_arybase;
1847 SvTAINTED_off(TARG); /* decontaminate */
1851 repl = SvPV(sv, repl_len);
1858 tmps = SvPV(sv, curlen);
1860 utfcurlen = sv_len_utf8(sv);
1861 if (utfcurlen == curlen)
1869 if (pos >= arybase) {
1887 else if (len >= 0) {
1889 if (rem > (I32)curlen)
1903 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1904 warner(WARN_SUBSTR, "substr outside of string");
1909 sv_pos_u2b(sv, &pos, &rem);
1911 sv_setpvn(TARG, tmps, rem);
1912 if (lvalue) { /* it's an lvalue! */
1913 if (!SvGMAGICAL(sv)) {
1915 SvPV_force(sv,PL_na);
1916 if (ckWARN(WARN_SUBSTR))
1918 "Attempt to use reference as lvalue in substr");
1920 if (SvOK(sv)) /* is it defined ? */
1921 (void)SvPOK_only(sv);
1923 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1926 if (SvTYPE(TARG) < SVt_PVLV) {
1927 sv_upgrade(TARG, SVt_PVLV);
1928 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1932 if (LvTARG(TARG) != sv) {
1934 SvREFCNT_dec(LvTARG(TARG));
1935 LvTARG(TARG) = SvREFCNT_inc(sv);
1937 LvTARGOFF(TARG) = pos;
1938 LvTARGLEN(TARG) = rem;
1941 sv_insert(sv, pos, rem, repl, repl_len);
1944 PUSHs(TARG); /* avoid SvSETMAGIC here */
1951 register I32 size = POPi;
1952 register I32 offset = POPi;
1953 register SV *src = POPs;
1954 I32 lvalue = PL_op->op_flags & OPf_MOD;
1956 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1957 unsigned long retnum;
1960 SvTAINTED_off(TARG); /* decontaminate */
1961 offset *= size; /* turn into bit offset */
1962 len = (offset + size + 7) / 8;
1963 if (offset < 0 || size < 1)
1966 if (lvalue) { /* it's an lvalue! */
1967 if (SvTYPE(TARG) < SVt_PVLV) {
1968 sv_upgrade(TARG, SVt_PVLV);
1969 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1973 if (LvTARG(TARG) != src) {
1975 SvREFCNT_dec(LvTARG(TARG));
1976 LvTARG(TARG) = SvREFCNT_inc(src);
1978 LvTARGOFF(TARG) = offset;
1979 LvTARGLEN(TARG) = size;
1987 if (offset >= srclen)
1990 retnum = (unsigned long) s[offset] << 8;
1992 else if (size == 32) {
1993 if (offset >= srclen)
1995 else if (offset + 1 >= srclen)
1996 retnum = (unsigned long) s[offset] << 24;
1997 else if (offset + 2 >= srclen)
1998 retnum = ((unsigned long) s[offset] << 24) +
1999 ((unsigned long) s[offset + 1] << 16);
2001 retnum = ((unsigned long) s[offset] << 24) +
2002 ((unsigned long) s[offset + 1] << 16) +
2003 (s[offset + 2] << 8);
2008 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2013 else if (size == 16)
2014 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2015 else if (size == 32)
2016 retnum = ((unsigned long) s[offset] << 24) +
2017 ((unsigned long) s[offset + 1] << 16) +
2018 (s[offset + 2] << 8) + s[offset+3];
2022 sv_setuv(TARG, (UV)retnum);
2037 I32 arybase = PL_curcop->cop_arybase;
2042 offset = POPi - arybase;
2045 tmps = SvPV(big, biglen);
2046 if (IN_UTF8 && offset > 0)
2047 sv_pos_u2b(big, &offset, 0);
2050 else if (offset > biglen)
2052 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2053 (unsigned char*)tmps + biglen, little, 0)))
2056 retval = tmps2 - tmps;
2057 if (IN_UTF8 && retval > 0)
2058 sv_pos_b2u(big, &retval);
2059 PUSHi(retval + arybase);
2074 I32 arybase = PL_curcop->cop_arybase;
2080 tmps2 = SvPV(little, llen);
2081 tmps = SvPV(big, blen);
2085 if (IN_UTF8 && offset > 0)
2086 sv_pos_u2b(big, &offset, 0);
2087 offset = offset - arybase + llen;
2091 else if (offset > blen)
2093 if (!(tmps2 = rninstr(tmps, tmps + offset,
2094 tmps2, tmps2 + llen)))
2097 retval = tmps2 - tmps;
2098 if (IN_UTF8 && retval > 0)
2099 sv_pos_b2u(big, &retval);
2100 PUSHi(retval + arybase);
2106 djSP; dMARK; dORIGMARK; dTARGET;
2107 #ifdef USE_LOCALE_NUMERIC
2108 if (PL_op->op_private & OPpLOCALE)
2109 SET_NUMERIC_LOCAL();
2111 SET_NUMERIC_STANDARD();
2113 do_sprintf(TARG, SP-MARK, MARK+1);
2114 TAINT_IF(SvTAINTED(TARG));
2124 U8 *tmps = (U8*)POPp;
2127 if (IN_UTF8 && (*tmps & 0x80))
2128 value = (I32) utf8_to_uv(tmps, &retlen);
2130 value = (I32) (*tmps & 255);
2141 (void)SvUPGRADE(TARG,SVt_PV);
2143 if (IN_UTF8 && value >= 128) {
2146 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2147 SvCUR_set(TARG, tmps - SvPVX(TARG));
2149 (void)SvPOK_only(TARG);
2159 (void)SvPOK_only(TARG);
2166 djSP; dTARGET; dPOPTOPssrl;
2168 char *tmps = SvPV(left, PL_na);
2170 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2172 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2176 "The crypt() function is unimplemented due to excessive paranoia.");
2189 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2193 UV uv = utf8_to_uv(s, &ulen);
2195 if (PL_op->op_private & OPpLOCALE) {
2198 uv = toTITLE_LC_uni(uv);
2201 uv = toTITLE_utf8(s);
2203 tend = uv_to_utf8(tmpbuf, uv);
2205 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2207 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2208 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2212 s = (U8*)SvPV_force(sv, slen);
2213 Copy(tmpbuf, s, ulen, U8);
2218 if (!SvPADTMP(sv)) {
2224 s = (U8*)SvPV_force(sv, PL_na);
2226 if (PL_op->op_private & OPpLOCALE) {
2229 *s = toUPPER_LC(*s);
2245 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2249 UV uv = utf8_to_uv(s, &ulen);
2251 if (PL_op->op_private & OPpLOCALE) {
2254 uv = toLOWER_LC_uni(uv);
2257 uv = toLOWER_utf8(s);
2259 tend = uv_to_utf8(tmpbuf, uv);
2261 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2263 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2264 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2268 s = (U8*)SvPV_force(sv, slen);
2269 Copy(tmpbuf, s, ulen, U8);
2274 if (!SvPADTMP(sv)) {
2280 s = (U8*)SvPV_force(sv, PL_na);
2282 if (PL_op->op_private & OPpLOCALE) {
2285 *s = toLOWER_LC(*s);
2308 s = (U8*)SvPV(sv,len);
2310 sv_setpvn(TARG, "", 0);
2315 (void)SvUPGRADE(TARG, SVt_PV);
2316 SvGROW(TARG, (len * 2) + 1);
2317 (void)SvPOK_only(TARG);
2318 d = (U8*)SvPVX(TARG);
2320 if (PL_op->op_private & OPpLOCALE) {
2324 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2330 d = uv_to_utf8(d, toUPPER_utf8( s ));
2335 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2340 if (!SvPADTMP(sv)) {
2347 s = (U8*)SvPV_force(sv, len);
2349 register U8 *send = s + len;
2351 if (PL_op->op_private & OPpLOCALE) {
2354 for (; s < send; s++)
2355 *s = toUPPER_LC(*s);
2358 for (; s < send; s++)
2378 s = (U8*)SvPV(sv,len);
2380 sv_setpvn(TARG, "", 0);
2385 (void)SvUPGRADE(TARG, SVt_PV);
2386 SvGROW(TARG, (len * 2) + 1);
2387 (void)SvPOK_only(TARG);
2388 d = (U8*)SvPVX(TARG);
2390 if (PL_op->op_private & OPpLOCALE) {
2394 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2400 d = uv_to_utf8(d, toLOWER_utf8(s));
2405 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2410 if (!SvPADTMP(sv)) {
2417 s = (U8*)SvPV_force(sv, len);
2419 register U8 *send = s + len;
2421 if (PL_op->op_private & OPpLOCALE) {
2424 for (; s < send; s++)
2425 *s = toLOWER_LC(*s);
2428 for (; s < send; s++)
2440 register char *s = SvPV(sv,len);
2444 (void)SvUPGRADE(TARG, SVt_PV);
2445 SvGROW(TARG, (len * 2) + 1);
2448 if (!(*s & 0x80) && !isALNUM(*s))
2453 SvCUR_set(TARG, d - SvPVX(TARG));
2454 (void)SvPOK_only(TARG);
2457 sv_setpvn(TARG, s, len);
2466 djSP; dMARK; dORIGMARK;
2468 register AV* av = (AV*)POPs;
2469 register I32 lval = PL_op->op_flags & OPf_MOD;
2470 I32 arybase = PL_curcop->cop_arybase;
2473 if (SvTYPE(av) == SVt_PVAV) {
2474 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2476 for (svp = MARK + 1; svp <= SP; svp++) {
2481 if (max > AvMAX(av))
2484 while (++MARK <= SP) {
2485 elem = SvIVx(*MARK);
2489 svp = av_fetch(av, elem, lval);
2491 if (!svp || *svp == &PL_sv_undef)
2492 DIE(no_aelem, elem);
2493 if (PL_op->op_private & OPpLVAL_INTRO)
2494 save_aelem(av, elem, svp);
2496 *MARK = svp ? *svp : &PL_sv_undef;
2499 if (GIMME != G_ARRAY) {
2507 /* Associative arrays. */
2512 HV *hash = (HV*)POPs;
2514 I32 gimme = GIMME_V;
2515 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2518 /* might clobber stack_sp */
2519 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2524 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2525 if (gimme == G_ARRAY) {
2527 /* might clobber stack_sp */
2528 sv_setsv(TARG, realhv ?
2529 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2534 else if (gimme == G_SCALAR)
2553 I32 gimme = GIMME_V;
2554 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2558 if (PL_op->op_private & OPpSLICE) {
2562 hvtype = SvTYPE(hv);
2563 while (++MARK <= SP) {
2564 if (hvtype == SVt_PVHV)
2565 sv = hv_delete_ent(hv, *MARK, discard, 0);
2567 DIE("Not a HASH reference");
2568 *MARK = sv ? sv : &PL_sv_undef;
2572 else if (gimme == G_SCALAR) {
2581 if (SvTYPE(hv) == SVt_PVHV)
2582 sv = hv_delete_ent(hv, keysv, discard, 0);
2584 DIE("Not a HASH reference");
2598 if (SvTYPE(hv) == SVt_PVHV) {
2599 if (hv_exists_ent(hv, tmpsv, 0))
2601 } else if (SvTYPE(hv) == SVt_PVAV) {
2602 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2605 DIE("Not a HASH reference");
2612 djSP; dMARK; dORIGMARK;
2613 register HV *hv = (HV*)POPs;
2614 register I32 lval = PL_op->op_flags & OPf_MOD;
2615 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2617 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2618 DIE("Can't localize pseudo-hash element");
2620 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2621 while (++MARK <= SP) {
2625 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2626 svp = he ? &HeVAL(he) : 0;
2628 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2631 if (!svp || *svp == &PL_sv_undef)
2632 DIE(no_helem, SvPV(keysv, PL_na));
2633 if (PL_op->op_private & OPpLVAL_INTRO)
2634 save_helem(hv, keysv, svp);
2636 *MARK = svp ? *svp : &PL_sv_undef;
2639 if (GIMME != G_ARRAY) {
2647 /* List operators. */
2652 if (GIMME != G_ARRAY) {
2654 *MARK = *SP; /* unwanted list, return last item */
2656 *MARK = &PL_sv_undef;
2665 SV **lastrelem = PL_stack_sp;
2666 SV **lastlelem = PL_stack_base + POPMARK;
2667 SV **firstlelem = PL_stack_base + POPMARK + 1;
2668 register SV **firstrelem = lastlelem + 1;
2669 I32 arybase = PL_curcop->cop_arybase;
2670 I32 lval = PL_op->op_flags & OPf_MOD;
2671 I32 is_something_there = lval;
2673 register I32 max = lastrelem - lastlelem;
2674 register SV **lelem;
2677 if (GIMME != G_ARRAY) {
2678 ix = SvIVx(*lastlelem);
2683 if (ix < 0 || ix >= max)
2684 *firstlelem = &PL_sv_undef;
2686 *firstlelem = firstrelem[ix];
2692 SP = firstlelem - 1;
2696 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2701 *lelem = &PL_sv_undef;
2702 else if (!(*lelem = firstrelem[ix]))
2703 *lelem = &PL_sv_undef;
2707 if (ix >= max || !(*lelem = firstrelem[ix]))
2708 *lelem = &PL_sv_undef;
2710 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2711 is_something_there = TRUE;
2713 if (is_something_there)
2716 SP = firstlelem - 1;
2722 djSP; dMARK; dORIGMARK;
2723 I32 items = SP - MARK;
2724 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2725 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2732 djSP; dMARK; dORIGMARK;
2733 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2737 SV *val = NEWSV(46, 0);
2739 sv_setsv(val, *++MARK);
2740 else if (ckWARN(WARN_UNSAFE))
2741 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2742 (void)hv_store_ent(hv,key,val,0);
2751 djSP; dMARK; dORIGMARK;
2752 register AV *ary = (AV*)*++MARK;
2756 register I32 offset;
2757 register I32 length;
2764 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2765 *MARK-- = mg->mg_obj;
2769 perl_call_method("SPLICE",GIMME_V);
2778 offset = i = SvIVx(*MARK);
2780 offset += AvFILLp(ary) + 1;
2782 offset -= PL_curcop->cop_arybase;
2786 length = SvIVx(*MARK++);
2788 length += AvFILLp(ary) - offset + 1;
2794 length = AvMAX(ary) + 1; /* close enough to infinity */
2798 length = AvMAX(ary) + 1;
2800 if (offset > AvFILLp(ary) + 1)
2801 offset = AvFILLp(ary) + 1;
2802 after = AvFILLp(ary) + 1 - (offset + length);
2803 if (after < 0) { /* not that much array */
2804 length += after; /* offset+length now in array */
2810 /* At this point, MARK .. SP-1 is our new LIST */
2813 diff = newlen - length;
2814 if (newlen && !AvREAL(ary)) {
2818 assert(AvREAL(ary)); /* would leak, so croak */
2821 if (diff < 0) { /* shrinking the area */
2823 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2824 Copy(MARK, tmparyval, newlen, SV*);
2827 MARK = ORIGMARK + 1;
2828 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2829 MEXTEND(MARK, length);
2830 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2832 EXTEND_MORTAL(length);
2833 for (i = length, dst = MARK; i; i--) {
2834 sv_2mortal(*dst); /* free them eventualy */
2841 *MARK = AvARRAY(ary)[offset+length-1];
2844 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2845 SvREFCNT_dec(*dst++); /* free them now */
2848 AvFILLp(ary) += diff;
2850 /* pull up or down? */
2852 if (offset < after) { /* easier to pull up */
2853 if (offset) { /* esp. if nothing to pull */
2854 src = &AvARRAY(ary)[offset-1];
2855 dst = src - diff; /* diff is negative */
2856 for (i = offset; i > 0; i--) /* can't trust Copy */
2860 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2864 if (after) { /* anything to pull down? */
2865 src = AvARRAY(ary) + offset + length;
2866 dst = src + diff; /* diff is negative */
2867 Move(src, dst, after, SV*);
2869 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2870 /* avoid later double free */
2874 dst[--i] = &PL_sv_undef;
2877 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2879 *dst = NEWSV(46, 0);
2880 sv_setsv(*dst++, *src++);
2882 Safefree(tmparyval);
2885 else { /* no, expanding (or same) */
2887 New(452, tmparyval, length, SV*); /* so remember deletion */
2888 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2891 if (diff > 0) { /* expanding */
2893 /* push up or down? */
2895 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2899 Move(src, dst, offset, SV*);
2901 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2903 AvFILLp(ary) += diff;
2906 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2907 av_extend(ary, AvFILLp(ary) + diff);
2908 AvFILLp(ary) += diff;
2911 dst = AvARRAY(ary) + AvFILLp(ary);
2913 for (i = after; i; i--) {
2920 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2921 *dst = NEWSV(46, 0);
2922 sv_setsv(*dst++, *src++);
2924 MARK = ORIGMARK + 1;
2925 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2927 Copy(tmparyval, MARK, length, SV*);
2929 EXTEND_MORTAL(length);
2930 for (i = length, dst = MARK; i; i--) {
2931 sv_2mortal(*dst); /* free them eventualy */
2935 Safefree(tmparyval);
2939 else if (length--) {
2940 *MARK = tmparyval[length];
2943 while (length-- > 0)
2944 SvREFCNT_dec(tmparyval[length]);
2946 Safefree(tmparyval);
2949 *MARK = &PL_sv_undef;
2957 djSP; dMARK; dORIGMARK; dTARGET;
2958 register AV *ary = (AV*)*++MARK;
2959 register SV *sv = &PL_sv_undef;
2962 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2963 *MARK-- = mg->mg_obj;
2967 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2972 /* Why no pre-extend of ary here ? */
2973 for (++MARK; MARK <= SP; MARK++) {
2976 sv_setsv(sv, *MARK);
2981 PUSHi( AvFILL(ary) + 1 );
2989 SV *sv = av_pop(av);
2991 (void)sv_2mortal(sv);
3000 SV *sv = av_shift(av);
3005 (void)sv_2mortal(sv);
3012 djSP; dMARK; dORIGMARK; dTARGET;
3013 register AV *ary = (AV*)*++MARK;
3018 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
3019 *MARK-- = mg->mg_obj;
3023 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3028 av_unshift(ary, SP - MARK);
3031 sv_setsv(sv, *++MARK);
3032 (void)av_store(ary, i++, sv);
3036 PUSHi( AvFILL(ary) + 1 );
3046 if (GIMME == G_ARRAY) {
3057 register char *down;
3063 do_join(TARG, &PL_sv_no, MARK, SP);
3065 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3066 up = SvPV_force(TARG, len);
3068 if (IN_UTF8) { /* first reverse each character */
3069 U8* s = (U8*)SvPVX(TARG);
3070 U8* send = (U8*)(s + len);
3079 down = (char*)(s - 1);
3080 if (s > send || !((*down & 0xc0) == 0x80)) {
3081 warn("Malformed UTF-8 character");
3093 down = SvPVX(TARG) + len - 1;
3099 (void)SvPOK_only(TARG);
3108 mul128(SV *sv, U8 m)
3111 char *s = SvPV(sv, len);
3115 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3116 SV *tmpNew = newSVpv("0000000000", 10);
3118 sv_catsv(tmpNew, sv);
3119 SvREFCNT_dec(sv); /* free old sv */
3124 while (!*t) /* trailing '\0'? */
3127 i = ((*t - '0') << 7) + m;
3128 *(t--) = '0' + (i % 10);
3134 /* Explosives and implosives. */
3136 static const char uuemap[] =
3137 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3138 static char uudmap[256]; /* Initialised on first use */
3139 #if 'I' == 73 && 'J' == 74
3140 /* On an ASCII/ISO kind of system */
3141 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3144 Some other sort of character set - use memchr() so we don't match
3147 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3155 I32 gimme = GIMME_V;
3159 register char *pat = SvPV(left, llen);
3160 register char *s = SvPV(right, rlen);
3161 char *strend = s + rlen;
3163 register char *patend = pat + llen;
3168 /* These must not be in registers: */
3179 unsigned Quad_t auquad;
3185 register U32 culong;
3187 static char* bitcount = 0;
3190 if (gimme != G_ARRAY) { /* arrange to do first one only */
3192 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3193 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3195 while (isDIGIT(*patend) || *patend == '*')
3201 while (pat < patend) {
3203 datumtype = *pat++ & 0xFF;
3204 if (isSPACE(datumtype))
3208 else if (*pat == '*') {
3209 len = strend - strbeg; /* long enough */
3212 else if (isDIGIT(*pat)) {
3214 while (isDIGIT(*pat))
3215 len = (len * 10) + (*pat++ - '0');
3218 len = (datumtype != '@');
3221 croak("Invalid type in unpack: '%c'", (int)datumtype);
3222 case ',': /* grandfather in commas but with a warning */
3223 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3224 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3227 if (len == 1 && pat[-1] != '1')
3236 if (len > strend - strbeg)
3237 DIE("@ outside of string");
3241 if (len > s - strbeg)
3242 DIE("X outside of string");
3246 if (len > strend - s)
3247 DIE("x outside of string");
3252 if (len > strend - s)
3255 goto uchar_checksum;
3256 sv = NEWSV(35, len);
3257 sv_setpvn(sv, s, len);
3259 if (datumtype == 'A') {
3260 aptr = s; /* borrow register */
3261 s = SvPVX(sv) + len - 1;
3262 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3265 SvCUR_set(sv, s - SvPVX(sv));
3266 s = aptr; /* unborrow register */
3268 XPUSHs(sv_2mortal(sv));
3272 if (pat[-1] == '*' || len > (strend - s) * 8)
3273 len = (strend - s) * 8;
3276 Newz(601, bitcount, 256, char);
3277 for (bits = 1; bits < 256; bits++) {
3278 if (bits & 1) bitcount[bits]++;
3279 if (bits & 2) bitcount[bits]++;
3280 if (bits & 4) bitcount[bits]++;
3281 if (bits & 8) bitcount[bits]++;
3282 if (bits & 16) bitcount[bits]++;
3283 if (bits & 32) bitcount[bits]++;
3284 if (bits & 64) bitcount[bits]++;
3285 if (bits & 128) bitcount[bits]++;
3289 culong += bitcount[*(unsigned char*)s++];
3294 if (datumtype == 'b') {
3296 if (bits & 1) culong++;
3302 if (bits & 128) culong++;
3309 sv = NEWSV(35, len + 1);
3312 aptr = pat; /* borrow register */
3314 if (datumtype == 'b') {
3316 for (len = 0; len < aint; len++) {
3317 if (len & 7) /*SUPPRESS 595*/
3321 *pat++ = '0' + (bits & 1);
3326 for (len = 0; len < aint; len++) {
3331 *pat++ = '0' + ((bits & 128) != 0);
3335 pat = aptr; /* unborrow register */
3336 XPUSHs(sv_2mortal(sv));
3340 if (pat[-1] == '*' || len > (strend - s) * 2)
3341 len = (strend - s) * 2;
3342 sv = NEWSV(35, len + 1);
3345 aptr = pat; /* borrow register */
3347 if (datumtype == 'h') {
3349 for (len = 0; len < aint; len++) {
3354 *pat++ = PL_hexdigit[bits & 15];
3359 for (len = 0; len < aint; len++) {
3364 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3368 pat = aptr; /* unborrow register */
3369 XPUSHs(sv_2mortal(sv));
3372 if (len > strend - s)
3377 if (aint >= 128) /* fake up signed chars */
3387 if (aint >= 128) /* fake up signed chars */
3390 sv_setiv(sv, (IV)aint);
3391 PUSHs(sv_2mortal(sv));
3396 if (len > strend - s)
3411 sv_setiv(sv, (IV)auint);
3412 PUSHs(sv_2mortal(sv));
3417 if (len > strend - s)
3420 while (len-- > 0 && s < strend) {
3421 auint = utf8_to_uv((U8*)s, &along);
3424 cdouble += (double)auint;
3432 while (len-- > 0 && s < strend) {
3433 auint = utf8_to_uv((U8*)s, &along);
3436 sv_setiv(sv, (IV)auint);
3437 PUSHs(sv_2mortal(sv));
3442 along = (strend - s) / SIZE16;
3459 sv_setiv(sv, (IV)ashort);
3460 PUSHs(sv_2mortal(sv));
3467 along = (strend - s) / SIZE16;
3472 COPY16(s, &aushort);
3475 if (datumtype == 'n')
3476 aushort = PerlSock_ntohs(aushort);
3479 if (datumtype == 'v')
3480 aushort = vtohs(aushort);
3489 COPY16(s, &aushort);
3493 if (datumtype == 'n')
3494 aushort = PerlSock_ntohs(aushort);
3497 if (datumtype == 'v')
3498 aushort = vtohs(aushort);
3500 sv_setiv(sv, (IV)aushort);
3501 PUSHs(sv_2mortal(sv));
3506 along = (strend - s) / sizeof(int);
3511 Copy(s, &aint, 1, int);
3514 cdouble += (double)aint;
3523 Copy(s, &aint, 1, int);
3527 /* Without the dummy below unpack("i", pack("i",-1))
3528 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3529 * cc with optimization turned on */
3531 sv_setiv(sv, (IV)aint) :
3533 sv_setiv(sv, (IV)aint);
3534 PUSHs(sv_2mortal(sv));
3539 along = (strend - s) / sizeof(unsigned int);
3544 Copy(s, &auint, 1, unsigned int);
3545 s += sizeof(unsigned int);
3547 cdouble += (double)auint;
3556 Copy(s, &auint, 1, unsigned int);
3557 s += sizeof(unsigned int);
3559 sv_setuv(sv, (UV)auint);
3560 PUSHs(sv_2mortal(sv));
3565 along = (strend - s) / SIZE32;
3573 cdouble += (double)along;
3585 sv_setiv(sv, (IV)along);
3586 PUSHs(sv_2mortal(sv));
3593 along = (strend - s) / SIZE32;
3601 if (datumtype == 'N')
3602 aulong = PerlSock_ntohl(aulong);
3605 if (datumtype == 'V')
3606 aulong = vtohl(aulong);
3609 cdouble += (double)aulong;
3621 if (datumtype == 'N')
3622 aulong = PerlSock_ntohl(aulong);
3625 if (datumtype == 'V')
3626 aulong = vtohl(aulong);
3629 sv_setuv(sv, (UV)aulong);
3630 PUSHs(sv_2mortal(sv));
3635 along = (strend - s) / sizeof(char*);
3641 if (sizeof(char*) > strend - s)
3644 Copy(s, &aptr, 1, char*);
3650 PUSHs(sv_2mortal(sv));
3660 while ((len > 0) && (s < strend)) {
3661 auv = (auv << 7) | (*s & 0x7f);
3662 if (!(*s++ & 0x80)) {
3666 PUSHs(sv_2mortal(sv));
3670 else if (++bytes >= sizeof(UV)) { /* promote to string */
3673 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3674 while (s < strend) {
3675 sv = mul128(sv, *s & 0x7f);
3676 if (!(*s++ & 0x80)) {
3681 t = SvPV(sv, PL_na);
3685 PUSHs(sv_2mortal(sv));
3690 if ((s >= strend) && bytes)
3691 croak("Unterminated compressed integer");
3696 if (sizeof(char*) > strend - s)
3699 Copy(s, &aptr, 1, char*);
3704 sv_setpvn(sv, aptr, len);
3705 PUSHs(sv_2mortal(sv));
3709 along = (strend - s) / sizeof(Quad_t);
3715 if (s + sizeof(Quad_t) > strend)
3718 Copy(s, &aquad, 1, Quad_t);
3719 s += sizeof(Quad_t);
3722 if (aquad >= IV_MIN && aquad <= IV_MAX)
3723 sv_setiv(sv, (IV)aquad);
3725 sv_setnv(sv, (double)aquad);
3726 PUSHs(sv_2mortal(sv));
3730 along = (strend - s) / sizeof(Quad_t);
3736 if (s + sizeof(unsigned Quad_t) > strend)
3739 Copy(s, &auquad, 1, unsigned Quad_t);
3740 s += sizeof(unsigned Quad_t);
3743 if (auquad <= UV_MAX)
3744 sv_setuv(sv, (UV)auquad);
3746 sv_setnv(sv, (double)auquad);
3747 PUSHs(sv_2mortal(sv));
3751 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3754 along = (strend - s) / sizeof(float);
3759 Copy(s, &afloat, 1, float);
3768 Copy(s, &afloat, 1, float);
3771 sv_setnv(sv, (double)afloat);
3772 PUSHs(sv_2mortal(sv));
3778 along = (strend - s) / sizeof(double);
3783 Copy(s, &adouble, 1, double);
3784 s += sizeof(double);
3792 Copy(s, &adouble, 1, double);
3793 s += sizeof(double);
3795 sv_setnv(sv, (double)adouble);
3796 PUSHs(sv_2mortal(sv));
3802 * Initialise the decode mapping. By using a table driven
3803 * algorithm, the code will be character-set independent
3804 * (and just as fast as doing character arithmetic)
3806 if (uudmap['M'] == 0) {
3809 for (i = 0; i < sizeof(uuemap); i += 1)
3810 uudmap[uuemap[i]] = i;
3812 * Because ' ' and '`' map to the same value,
3813 * we need to decode them both the same.
3818 along = (strend - s) * 3 / 4;
3819 sv = NEWSV(42, along);
3822 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3827 len = uudmap[*s++] & 077;
3829 if (s < strend && ISUUCHAR(*s))
3830 a = uudmap[*s++] & 077;
3833 if (s < strend && ISUUCHAR(*s))
3834 b = uudmap[*s++] & 077;
3837 if (s < strend && ISUUCHAR(*s))
3838 c = uudmap[*s++] & 077;
3841 if (s < strend && ISUUCHAR(*s))
3842 d = uudmap[*s++] & 077;
3845 hunk[0] = (a << 2) | (b >> 4);
3846 hunk[1] = (b << 4) | (c >> 2);
3847 hunk[2] = (c << 6) | d;
3848 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3853 else if (s[1] == '\n') /* possible checksum byte */
3856 XPUSHs(sv_2mortal(sv));
3861 if (strchr("fFdD", datumtype) ||
3862 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3866 while (checksum >= 16) {
3870 while (checksum >= 4) {
3876 along = (1 << checksum) - 1;
3877 while (cdouble < 0.0)
3879 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3880 sv_setnv(sv, cdouble);
3883 if (checksum < 32) {
3884 aulong = (1 << checksum) - 1;
3887 sv_setuv(sv, (UV)culong);
3889 XPUSHs(sv_2mortal(sv));
3893 if (SP == oldsp && gimme == G_SCALAR)
3894 PUSHs(&PL_sv_undef);
3899 doencodes(register SV *sv, register char *s, register I32 len)
3903 *hunk = uuemap[len];
3904 sv_catpvn(sv, hunk, 1);
3907 hunk[0] = uuemap[(077 & (*s >> 2))];
3908 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3909 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3910 hunk[3] = uuemap[(077 & (s[2] & 077))];
3911 sv_catpvn(sv, hunk, 4);
3916 char r = (len > 1 ? s[1] : '\0');
3917 hunk[0] = uuemap[(077 & (*s >> 2))];
3918 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3919 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3920 hunk[3] = uuemap[0];
3921 sv_catpvn(sv, hunk, 4);
3923 sv_catpvn(sv, "\n", 1);
3927 is_an_int(char *s, STRLEN l)
3929 SV *result = newSVpv("", l);
3930 char *result_c = SvPV(result, PL_na); /* convenience */
3931 char *out = result_c;
3941 SvREFCNT_dec(result);
3964 SvREFCNT_dec(result);
3970 SvCUR_set(result, out - result_c);
3975 div128(SV *pnum, bool *done)
3976 /* must be '\0' terminated */
3980 char *s = SvPV(pnum, len);
3989 i = m * 10 + (*t - '0');
3991 r = (i >> 7); /* r < 10 */
3998 SvCUR_set(pnum, (STRLEN) (t - s));
4005 djSP; dMARK; dORIGMARK; dTARGET;
4006 register SV *cat = TARG;
4009 register char *pat = SvPVx(*++MARK, fromlen);
4010 register char *patend = pat + fromlen;
4015 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4016 static char *space10 = " ";
4018 /* These must not be in registers: */
4027 unsigned Quad_t auquad;
4036 sv_setpvn(cat, "", 0);
4037 while (pat < patend) {
4038 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4039 datumtype = *pat++ & 0xFF;
4040 if (isSPACE(datumtype))
4043 len = strchr("@Xxu", datumtype) ? 0 : items;
4046 else if (isDIGIT(*pat)) {
4048 while (isDIGIT(*pat))
4049 len = (len * 10) + (*pat++ - '0');
4055 croak("Invalid type in pack: '%c'", (int)datumtype);
4056 case ',': /* grandfather in commas but with a warning */
4057 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4058 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4061 DIE("%% may only be used in unpack");
4072 if (SvCUR(cat) < len)
4073 DIE("X outside of string");
4080 sv_catpvn(cat, null10, 10);
4083 sv_catpvn(cat, null10, len);
4088 aptr = SvPV(fromstr, fromlen);
4092 sv_catpvn(cat, aptr, len);
4094 sv_catpvn(cat, aptr, fromlen);
4096 if (datumtype == 'A') {
4098 sv_catpvn(cat, space10, 10);
4101 sv_catpvn(cat, space10, len);
4105 sv_catpvn(cat, null10, 10);
4108 sv_catpvn(cat, null10, len);
4115 char *savepat = pat;
4120 aptr = SvPV(fromstr, fromlen);
4125 SvCUR(cat) += (len+7)/8;
4126 SvGROW(cat, SvCUR(cat) + 1);
4127 aptr = SvPVX(cat) + aint;
4132 if (datumtype == 'B') {
4133 for (len = 0; len++ < aint;) {
4134 items |= *pat++ & 1;
4138 *aptr++ = items & 0xff;
4144 for (len = 0; len++ < aint;) {
4150 *aptr++ = items & 0xff;
4156 if (datumtype == 'B')
4157 items <<= 7 - (aint & 7);
4159 items >>= 7 - (aint & 7);
4160 *aptr++ = items & 0xff;
4162 pat = SvPVX(cat) + SvCUR(cat);
4173 char *savepat = pat;
4178 aptr = SvPV(fromstr, fromlen);
4183 SvCUR(cat) += (len+1)/2;
4184 SvGROW(cat, SvCUR(cat) + 1);
4185 aptr = SvPVX(cat) + aint;
4190 if (datumtype == 'H') {
4191 for (len = 0; len++ < aint;) {
4193 items |= ((*pat++ & 15) + 9) & 15;
4195 items |= *pat++ & 15;
4199 *aptr++ = items & 0xff;
4205 for (len = 0; len++ < aint;) {
4207 items |= (((*pat++ & 15) + 9) & 15) << 4;
4209 items |= (*pat++ & 15) << 4;
4213 *aptr++ = items & 0xff;
4219 *aptr++ = items & 0xff;
4220 pat = SvPVX(cat) + SvCUR(cat);
4232 aint = SvIV(fromstr);
4234 sv_catpvn(cat, &achar, sizeof(char));
4240 auint = SvUV(fromstr);
4241 SvGROW(cat, SvCUR(cat) + 10);
4242 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4247 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4252 afloat = (float)SvNV(fromstr);
4253 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4260 adouble = (double)SvNV(fromstr);
4261 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4267 ashort = (I16)SvIV(fromstr);
4269 ashort = PerlSock_htons(ashort);
4271 CAT16(cat, &ashort);
4277 ashort = (I16)SvIV(fromstr);
4279 ashort = htovs(ashort);
4281 CAT16(cat, &ashort);
4288 ashort = (I16)SvIV(fromstr);
4289 CAT16(cat, &ashort);
4295 auint = SvUV(fromstr);
4296 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4302 adouble = floor(SvNV(fromstr));
4305 croak("Cannot compress negative numbers");
4311 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4312 adouble <= UV_MAX_cxux
4319 char buf[1 + sizeof(UV)];
4320 char *in = buf + sizeof(buf);
4321 UV auv = U_V(adouble);;
4324 *--in = (auv & 0x7f) | 0x80;
4327 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4328 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4330 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4331 char *from, *result, *in;
4336 /* Copy string and check for compliance */
4337 from = SvPV(fromstr, len);
4338 if ((norm = is_an_int(from, len)) == NULL)
4339 croak("can compress only unsigned integer");
4341 New('w', result, len, char);
4345 *--in = div128(norm, &done) | 0x80;
4346 result[len - 1] &= 0x7F; /* clear continue bit */
4347 sv_catpvn(cat, in, (result + len) - in);
4349 SvREFCNT_dec(norm); /* free norm */
4351 else if (SvNOKp(fromstr)) {
4352 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4353 char *in = buf + sizeof(buf);
4356 double next = floor(adouble / 128);
4357 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4358 if (--in < buf) /* this cannot happen ;-) */
4359 croak ("Cannot compress integer");
4361 } while (adouble > 0);
4362 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4363 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4366 croak("Cannot compress non integer");
4372 aint = SvIV(fromstr);
4373 sv_catpvn(cat, (char*)&aint, sizeof(int));
4379 aulong = SvUV(fromstr);
4381 aulong = PerlSock_htonl(aulong);
4383 CAT32(cat, &aulong);
4389 aulong = SvUV(fromstr);
4391 aulong = htovl(aulong);
4393 CAT32(cat, &aulong);
4399 aulong = SvUV(fromstr);
4400 CAT32(cat, &aulong);
4406 along = SvIV(fromstr);
4414 auquad = (unsigned Quad_t)SvIV(fromstr);
4415 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4421 aquad = (Quad_t)SvIV(fromstr);
4422 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4425 #endif /* HAS_QUAD */
4427 len = 1; /* assume SV is correct length */
4432 if (fromstr == &PL_sv_undef)
4435 /* XXX better yet, could spirit away the string to
4436 * a safe spot and hang on to it until the result
4437 * of pack() (and all copies of the result) are
4440 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4442 "Attempt to pack pointer to temporary value");
4443 if (SvPOK(fromstr) || SvNIOK(fromstr))
4444 aptr = SvPV(fromstr,PL_na);
4446 aptr = SvPV_force(fromstr,PL_na);
4448 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4453 aptr = SvPV(fromstr, fromlen);
4454 SvGROW(cat, fromlen * 4 / 3);
4459 while (fromlen > 0) {
4466 doencodes(cat, aptr, todo);
4485 register I32 limit = POPi; /* note, negative is forever */
4488 register char *s = SvPV(sv, len);
4489 char *strend = s + len;
4491 register REGEXP *rx;
4495 I32 maxiters = (strend - s) + 10;
4498 I32 origlimit = limit;
4501 AV *oldstack = PL_curstack;
4502 I32 gimme = GIMME_V;
4503 I32 oldsave = PL_savestack_ix;
4504 I32 make_mortal = 1;
4505 MAGIC *mg = (MAGIC *) NULL;
4508 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4513 DIE("panic: do_split");
4514 rx = pm->op_pmregexp;
4516 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4517 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4519 if (pm->op_pmreplroot)
4520 ary = GvAVn((GV*)pm->op_pmreplroot);
4521 else if (gimme != G_ARRAY)
4523 ary = (AV*)PL_curpad[0];
4525 ary = GvAVn(PL_defgv);
4526 #endif /* USE_THREADS */
4529 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4535 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4542 for (i = AvFILLp(ary); i >= 0; i--)
4543 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4545 /* temporarily switch stacks */
4546 SWITCHSTACK(PL_curstack, ary);
4550 base = SP - PL_stack_base;
4552 if (pm->op_pmflags & PMf_SKIPWHITE) {
4553 if (pm->op_pmflags & PMf_LOCALE) {
4554 while (isSPACE_LC(*s))
4562 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4563 SAVEINT(PL_multiline);
4564 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4568 limit = maxiters + 2;
4569 if (pm->op_pmflags & PMf_WHITE) {
4572 while (m < strend &&
4573 !((pm->op_pmflags & PMf_LOCALE)
4574 ? isSPACE_LC(*m) : isSPACE(*m)))
4579 dstr = NEWSV(30, m-s);
4580 sv_setpvn(dstr, s, m-s);
4586 while (s < strend &&
4587 ((pm->op_pmflags & PMf_LOCALE)
4588 ? isSPACE_LC(*s) : isSPACE(*s)))
4592 else if (strEQ("^", rx->precomp)) {
4595 for (m = s; m < strend && *m != '\n'; m++) ;
4599 dstr = NEWSV(30, m-s);
4600 sv_setpvn(dstr, s, m-s);
4607 else if (rx->check_substr && !rx->nparens
4608 && (rx->reganch & ROPT_CHECK_ALL)
4609 && !(rx->reganch & ROPT_ANCH)) {
4610 i = SvCUR(rx->check_substr);
4611 if (i == 1 && !SvTAIL(rx->check_substr)) {
4612 i = *SvPVX(rx->check_substr);
4615 for (m = s; m < strend && *m != i; m++) ;
4618 dstr = NEWSV(30, m-s);
4619 sv_setpvn(dstr, s, m-s);
4628 while (s < strend && --limit &&
4629 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4630 rx->check_substr, 0)) )
4633 dstr = NEWSV(31, m-s);
4634 sv_setpvn(dstr, s, m-s);
4643 maxiters += (strend - s) * rx->nparens;
4644 while (s < strend && --limit &&
4645 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4647 TAINT_IF(RX_MATCH_TAINTED(rx));
4649 && rx->subbase != orig) {
4654 strend = s + (strend - m);
4657 dstr = NEWSV(32, m-s);
4658 sv_setpvn(dstr, s, m-s);
4663 for (i = 1; i <= rx->nparens; i++) {
4667 dstr = NEWSV(33, m-s);
4668 sv_setpvn(dstr, s, m-s);
4671 dstr = NEWSV(33, 0);
4681 LEAVE_SCOPE(oldsave);
4682 iters = (SP - PL_stack_base) - base;
4683 if (iters > maxiters)
4686 /* keep field after final delim? */
4687 if (s < strend || (iters && origlimit)) {
4688 dstr = NEWSV(34, strend-s);
4689 sv_setpvn(dstr, s, strend-s);
4695 else if (!origlimit) {
4696 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4702 SWITCHSTACK(ary, oldstack);
4703 if (SvSMAGICAL(ary)) {
4708 if (gimme == G_ARRAY) {
4710 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4718 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4721 if (gimme == G_ARRAY) {
4722 /* EXTEND should not be needed - we just popped them */
4724 for (i=0; i < iters; i++) {
4725 SV **svp = av_fetch(ary, i, FALSE);
4726 PUSHs((svp) ? *svp : &PL_sv_undef);
4733 if (gimme == G_ARRAY)
4736 if (iters || !pm->op_pmreplroot) {
4746 unlock_condpair(void *svv)
4749 MAGIC *mg = mg_find((SV*)svv, 'm');
4752 croak("panic: unlock_condpair unlocking non-mutex");
4753 MUTEX_LOCK(MgMUTEXP(mg));
4754 if (MgOWNER(mg) != thr)
4755 croak("panic: unlock_condpair unlocking mutex that we don't own");
4757 COND_SIGNAL(MgOWNERCONDP(mg));
4758 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4759 (unsigned long)thr, (unsigned long)svv);)
4760 MUTEX_UNLOCK(MgMUTEXP(mg));
4762 #endif /* USE_THREADS */
4775 mg = condpair_magic(sv);
4776 MUTEX_LOCK(MgMUTEXP(mg));
4777 if (MgOWNER(mg) == thr)
4778 MUTEX_UNLOCK(MgMUTEXP(mg));
4781 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4783 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4784 (unsigned long)thr, (unsigned long)sv);)
4785 MUTEX_UNLOCK(MgMUTEXP(mg));
4786 save_destructor(unlock_condpair, sv);
4788 #endif /* USE_THREADS */
4789 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4790 || SvTYPE(retsv) == SVt_PVCV) {
4791 retsv = refto(retsv);
4802 if (PL_op->op_private & OPpLVAL_INTRO)
4803 PUSHs(*save_threadsv(PL_op->op_targ));
4805 PUSHs(THREADSV(PL_op->op_targ));
4808 DIE("tried to access per-thread data in non-threaded perl");
4809 #endif /* USE_THREADS */