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
1564 # define my_rand rand
1567 # define my_srand srand
1580 if (!srand_called) {
1581 (void)my_srand((unsigned)seed());
1582 srand_called = TRUE;
1585 value = my_rand() * value / 2147483648.0;
1588 value = my_rand() * value / 65536.0;
1591 value = my_rand() * value / 32768.0;
1593 value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
1609 (void)my_srand((unsigned)anum);
1610 srand_called = TRUE;
1619 * This is really just a quick hack which grabs various garbage
1620 * values. It really should be a real hash algorithm which
1621 * spreads the effect of every input bit onto every output bit,
1622 * if someone who knows about such tings would bother to write it.
1623 * Might be a good idea to add that function to CORE as well.
1624 * No numbers below come from careful analysis or anyting here,
1625 * except they are primes and SEED_C1 > 1E6 to get a full-width
1626 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1627 * probably be bigger too.
1630 # define SEED_C1 1000003
1631 #define SEED_C4 73819
1633 # define SEED_C1 25747
1634 #define SEED_C4 20639
1638 #define SEED_C5 26107
1641 #ifndef PERL_NO_DEV_RANDOM
1646 # include <starlet.h>
1647 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1648 * in 100-ns units, typically incremented ever 10 ms. */
1649 unsigned int when[2];
1651 # ifdef HAS_GETTIMEOFDAY
1652 struct timeval when;
1658 /* This test is an escape hatch, this symbol isn't set by Configure. */
1659 #ifndef PERL_NO_DEV_RANDOM
1660 #ifndef PERL_RANDOM_DEVICE
1661 /* /dev/random isn't used by default because reads from it will block
1662 * if there isn't enough entropy available. You can compile with
1663 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1664 * is enough real entropy to fill the seed. */
1665 # define PERL_RANDOM_DEVICE "/dev/urandom"
1667 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1669 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1678 _ckvmssts(sys$gettim(when));
1679 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1681 # ifdef HAS_GETTIMEOFDAY
1682 gettimeofday(&when,(struct timezone *) 0);
1683 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1686 u = (U32)SEED_C1 * when;
1689 u += SEED_C3 * (U32)getpid();
1690 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1691 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1692 u += SEED_C5 * (U32)(UV)&when;
1699 djSP; dTARGET; tryAMAGICun(exp);
1711 djSP; dTARGET; tryAMAGICun(log);
1716 SET_NUMERIC_STANDARD();
1717 DIE("Can't take log of %g", value);
1727 djSP; dTARGET; tryAMAGICun(sqrt);
1732 SET_NUMERIC_STANDARD();
1733 DIE("Can't take sqrt of %g", value);
1735 value = sqrt(value);
1745 double value = TOPn;
1748 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1754 (void)modf(value, &value);
1756 (void)modf(-value, &value);
1771 djSP; dTARGET; tryAMAGICun(abs);
1773 double value = TOPn;
1776 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1777 (iv = SvIVX(TOPs)) != IV_MIN) {
1798 XPUSHu(scan_hex(tmps, 99, &argtype));
1810 while (*tmps && isSPACE(*tmps))
1815 value = scan_hex(++tmps, 99, &argtype);
1817 value = scan_oct(tmps, 99, &argtype);
1829 SETi( sv_len_utf8(TOPs) );
1833 SETi( sv_len(TOPs) );
1847 I32 lvalue = PL_op->op_flags & OPf_MOD;
1849 I32 arybase = PL_curcop->cop_arybase;
1853 SvTAINTED_off(TARG); /* decontaminate */
1857 repl = SvPV(sv, repl_len);
1864 tmps = SvPV(sv, curlen);
1866 utfcurlen = sv_len_utf8(sv);
1867 if (utfcurlen == curlen)
1875 if (pos >= arybase) {
1893 else if (len >= 0) {
1895 if (rem > (I32)curlen)
1909 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1910 warner(WARN_SUBSTR, "substr outside of string");
1915 sv_pos_u2b(sv, &pos, &rem);
1917 sv_setpvn(TARG, tmps, rem);
1918 if (lvalue) { /* it's an lvalue! */
1919 if (!SvGMAGICAL(sv)) {
1921 SvPV_force(sv,PL_na);
1922 if (ckWARN(WARN_SUBSTR))
1924 "Attempt to use reference as lvalue in substr");
1926 if (SvOK(sv)) /* is it defined ? */
1927 (void)SvPOK_only(sv);
1929 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1932 if (SvTYPE(TARG) < SVt_PVLV) {
1933 sv_upgrade(TARG, SVt_PVLV);
1934 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1938 if (LvTARG(TARG) != sv) {
1940 SvREFCNT_dec(LvTARG(TARG));
1941 LvTARG(TARG) = SvREFCNT_inc(sv);
1943 LvTARGOFF(TARG) = pos;
1944 LvTARGLEN(TARG) = rem;
1947 sv_insert(sv, pos, rem, repl, repl_len);
1950 PUSHs(TARG); /* avoid SvSETMAGIC here */
1957 register I32 size = POPi;
1958 register I32 offset = POPi;
1959 register SV *src = POPs;
1960 I32 lvalue = PL_op->op_flags & OPf_MOD;
1962 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1963 unsigned long retnum;
1966 SvTAINTED_off(TARG); /* decontaminate */
1967 offset *= size; /* turn into bit offset */
1968 len = (offset + size + 7) / 8;
1969 if (offset < 0 || size < 1)
1972 if (lvalue) { /* it's an lvalue! */
1973 if (SvTYPE(TARG) < SVt_PVLV) {
1974 sv_upgrade(TARG, SVt_PVLV);
1975 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1979 if (LvTARG(TARG) != src) {
1981 SvREFCNT_dec(LvTARG(TARG));
1982 LvTARG(TARG) = SvREFCNT_inc(src);
1984 LvTARGOFF(TARG) = offset;
1985 LvTARGLEN(TARG) = size;
1993 if (offset >= srclen)
1996 retnum = (unsigned long) s[offset] << 8;
1998 else if (size == 32) {
1999 if (offset >= srclen)
2001 else if (offset + 1 >= srclen)
2002 retnum = (unsigned long) s[offset] << 24;
2003 else if (offset + 2 >= srclen)
2004 retnum = ((unsigned long) s[offset] << 24) +
2005 ((unsigned long) s[offset + 1] << 16);
2007 retnum = ((unsigned long) s[offset] << 24) +
2008 ((unsigned long) s[offset + 1] << 16) +
2009 (s[offset + 2] << 8);
2014 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2019 else if (size == 16)
2020 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2021 else if (size == 32)
2022 retnum = ((unsigned long) s[offset] << 24) +
2023 ((unsigned long) s[offset + 1] << 16) +
2024 (s[offset + 2] << 8) + s[offset+3];
2028 sv_setuv(TARG, (UV)retnum);
2043 I32 arybase = PL_curcop->cop_arybase;
2048 offset = POPi - arybase;
2051 tmps = SvPV(big, biglen);
2052 if (IN_UTF8 && offset > 0)
2053 sv_pos_u2b(big, &offset, 0);
2056 else if (offset > biglen)
2058 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2059 (unsigned char*)tmps + biglen, little, 0)))
2062 retval = tmps2 - tmps;
2063 if (IN_UTF8 && retval > 0)
2064 sv_pos_b2u(big, &retval);
2065 PUSHi(retval + arybase);
2080 I32 arybase = PL_curcop->cop_arybase;
2086 tmps2 = SvPV(little, llen);
2087 tmps = SvPV(big, blen);
2091 if (IN_UTF8 && offset > 0)
2092 sv_pos_u2b(big, &offset, 0);
2093 offset = offset - arybase + llen;
2097 else if (offset > blen)
2099 if (!(tmps2 = rninstr(tmps, tmps + offset,
2100 tmps2, tmps2 + llen)))
2103 retval = tmps2 - tmps;
2104 if (IN_UTF8 && retval > 0)
2105 sv_pos_b2u(big, &retval);
2106 PUSHi(retval + arybase);
2112 djSP; dMARK; dORIGMARK; dTARGET;
2113 #ifdef USE_LOCALE_NUMERIC
2114 if (PL_op->op_private & OPpLOCALE)
2115 SET_NUMERIC_LOCAL();
2117 SET_NUMERIC_STANDARD();
2119 do_sprintf(TARG, SP-MARK, MARK+1);
2120 TAINT_IF(SvTAINTED(TARG));
2130 U8 *tmps = (U8*)POPp;
2133 if (IN_UTF8 && (*tmps & 0x80))
2134 value = (I32) utf8_to_uv(tmps, &retlen);
2136 value = (I32) (*tmps & 255);
2147 (void)SvUPGRADE(TARG,SVt_PV);
2149 if (IN_UTF8 && value >= 128) {
2152 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2153 SvCUR_set(TARG, tmps - SvPVX(TARG));
2155 (void)SvPOK_only(TARG);
2165 (void)SvPOK_only(TARG);
2172 djSP; dTARGET; dPOPTOPssrl;
2174 char *tmps = SvPV(left, PL_na);
2176 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2178 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2182 "The crypt() function is unimplemented due to excessive paranoia.");
2195 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2199 UV uv = utf8_to_uv(s, &ulen);
2201 if (PL_op->op_private & OPpLOCALE) {
2204 uv = toTITLE_LC_uni(uv);
2207 uv = toTITLE_utf8(s);
2209 tend = uv_to_utf8(tmpbuf, uv);
2211 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2213 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2214 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2218 s = (U8*)SvPV_force(sv, slen);
2219 Copy(tmpbuf, s, ulen, U8);
2224 if (!SvPADTMP(sv)) {
2230 s = (U8*)SvPV_force(sv, PL_na);
2232 if (PL_op->op_private & OPpLOCALE) {
2235 *s = toUPPER_LC(*s);
2251 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2255 UV uv = utf8_to_uv(s, &ulen);
2257 if (PL_op->op_private & OPpLOCALE) {
2260 uv = toLOWER_LC_uni(uv);
2263 uv = toLOWER_utf8(s);
2265 tend = uv_to_utf8(tmpbuf, uv);
2267 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2269 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2270 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2274 s = (U8*)SvPV_force(sv, slen);
2275 Copy(tmpbuf, s, ulen, U8);
2280 if (!SvPADTMP(sv)) {
2286 s = (U8*)SvPV_force(sv, PL_na);
2288 if (PL_op->op_private & OPpLOCALE) {
2291 *s = toLOWER_LC(*s);
2314 s = (U8*)SvPV(sv,len);
2316 sv_setpvn(TARG, "", 0);
2321 (void)SvUPGRADE(TARG, SVt_PV);
2322 SvGROW(TARG, (len * 2) + 1);
2323 (void)SvPOK_only(TARG);
2324 d = (U8*)SvPVX(TARG);
2326 if (PL_op->op_private & OPpLOCALE) {
2330 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2336 d = uv_to_utf8(d, toUPPER_utf8( s ));
2341 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2346 if (!SvPADTMP(sv)) {
2353 s = (U8*)SvPV_force(sv, len);
2355 register U8 *send = s + len;
2357 if (PL_op->op_private & OPpLOCALE) {
2360 for (; s < send; s++)
2361 *s = toUPPER_LC(*s);
2364 for (; s < send; s++)
2384 s = (U8*)SvPV(sv,len);
2386 sv_setpvn(TARG, "", 0);
2391 (void)SvUPGRADE(TARG, SVt_PV);
2392 SvGROW(TARG, (len * 2) + 1);
2393 (void)SvPOK_only(TARG);
2394 d = (U8*)SvPVX(TARG);
2396 if (PL_op->op_private & OPpLOCALE) {
2400 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2406 d = uv_to_utf8(d, toLOWER_utf8(s));
2411 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2416 if (!SvPADTMP(sv)) {
2423 s = (U8*)SvPV_force(sv, len);
2425 register U8 *send = s + len;
2427 if (PL_op->op_private & OPpLOCALE) {
2430 for (; s < send; s++)
2431 *s = toLOWER_LC(*s);
2434 for (; s < send; s++)
2446 register char *s = SvPV(sv,len);
2450 (void)SvUPGRADE(TARG, SVt_PV);
2451 SvGROW(TARG, (len * 2) + 1);
2454 if (!(*s & 0x80) && !isALNUM(*s))
2459 SvCUR_set(TARG, d - SvPVX(TARG));
2460 (void)SvPOK_only(TARG);
2463 sv_setpvn(TARG, s, len);
2472 djSP; dMARK; dORIGMARK;
2474 register AV* av = (AV*)POPs;
2475 register I32 lval = PL_op->op_flags & OPf_MOD;
2476 I32 arybase = PL_curcop->cop_arybase;
2479 if (SvTYPE(av) == SVt_PVAV) {
2480 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2482 for (svp = MARK + 1; svp <= SP; svp++) {
2487 if (max > AvMAX(av))
2490 while (++MARK <= SP) {
2491 elem = SvIVx(*MARK);
2495 svp = av_fetch(av, elem, lval);
2497 if (!svp || *svp == &PL_sv_undef)
2498 DIE(no_aelem, elem);
2499 if (PL_op->op_private & OPpLVAL_INTRO)
2500 save_aelem(av, elem, svp);
2502 *MARK = svp ? *svp : &PL_sv_undef;
2505 if (GIMME != G_ARRAY) {
2513 /* Associative arrays. */
2518 HV *hash = (HV*)POPs;
2520 I32 gimme = GIMME_V;
2521 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2524 /* might clobber stack_sp */
2525 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2530 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2531 if (gimme == G_ARRAY) {
2533 /* might clobber stack_sp */
2534 sv_setsv(TARG, realhv ?
2535 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2540 else if (gimme == G_SCALAR)
2559 I32 gimme = GIMME_V;
2560 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2564 if (PL_op->op_private & OPpSLICE) {
2568 hvtype = SvTYPE(hv);
2569 while (++MARK <= SP) {
2570 if (hvtype == SVt_PVHV)
2571 sv = hv_delete_ent(hv, *MARK, discard, 0);
2573 DIE("Not a HASH reference");
2574 *MARK = sv ? sv : &PL_sv_undef;
2578 else if (gimme == G_SCALAR) {
2587 if (SvTYPE(hv) == SVt_PVHV)
2588 sv = hv_delete_ent(hv, keysv, discard, 0);
2590 DIE("Not a HASH reference");
2604 if (SvTYPE(hv) == SVt_PVHV) {
2605 if (hv_exists_ent(hv, tmpsv, 0))
2607 } else if (SvTYPE(hv) == SVt_PVAV) {
2608 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2611 DIE("Not a HASH reference");
2618 djSP; dMARK; dORIGMARK;
2619 register HV *hv = (HV*)POPs;
2620 register I32 lval = PL_op->op_flags & OPf_MOD;
2621 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2623 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2624 DIE("Can't localize pseudo-hash element");
2626 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2627 while (++MARK <= SP) {
2631 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2632 svp = he ? &HeVAL(he) : 0;
2634 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2637 if (!svp || *svp == &PL_sv_undef)
2638 DIE(no_helem, SvPV(keysv, PL_na));
2639 if (PL_op->op_private & OPpLVAL_INTRO)
2640 save_helem(hv, keysv, svp);
2642 *MARK = svp ? *svp : &PL_sv_undef;
2645 if (GIMME != G_ARRAY) {
2653 /* List operators. */
2658 if (GIMME != G_ARRAY) {
2660 *MARK = *SP; /* unwanted list, return last item */
2662 *MARK = &PL_sv_undef;
2671 SV **lastrelem = PL_stack_sp;
2672 SV **lastlelem = PL_stack_base + POPMARK;
2673 SV **firstlelem = PL_stack_base + POPMARK + 1;
2674 register SV **firstrelem = lastlelem + 1;
2675 I32 arybase = PL_curcop->cop_arybase;
2676 I32 lval = PL_op->op_flags & OPf_MOD;
2677 I32 is_something_there = lval;
2679 register I32 max = lastrelem - lastlelem;
2680 register SV **lelem;
2683 if (GIMME != G_ARRAY) {
2684 ix = SvIVx(*lastlelem);
2689 if (ix < 0 || ix >= max)
2690 *firstlelem = &PL_sv_undef;
2692 *firstlelem = firstrelem[ix];
2698 SP = firstlelem - 1;
2702 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2707 *lelem = &PL_sv_undef;
2708 else if (!(*lelem = firstrelem[ix]))
2709 *lelem = &PL_sv_undef;
2713 if (ix >= max || !(*lelem = firstrelem[ix]))
2714 *lelem = &PL_sv_undef;
2716 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2717 is_something_there = TRUE;
2719 if (is_something_there)
2722 SP = firstlelem - 1;
2728 djSP; dMARK; dORIGMARK;
2729 I32 items = SP - MARK;
2730 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2731 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2738 djSP; dMARK; dORIGMARK;
2739 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2743 SV *val = NEWSV(46, 0);
2745 sv_setsv(val, *++MARK);
2746 else if (ckWARN(WARN_UNSAFE))
2747 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2748 (void)hv_store_ent(hv,key,val,0);
2757 djSP; dMARK; dORIGMARK;
2758 register AV *ary = (AV*)*++MARK;
2762 register I32 offset;
2763 register I32 length;
2770 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2771 *MARK-- = mg->mg_obj;
2775 perl_call_method("SPLICE",GIMME_V);
2784 offset = i = SvIVx(*MARK);
2786 offset += AvFILLp(ary) + 1;
2788 offset -= PL_curcop->cop_arybase;
2792 length = SvIVx(*MARK++);
2794 length += AvFILLp(ary) - offset + 1;
2800 length = AvMAX(ary) + 1; /* close enough to infinity */
2804 length = AvMAX(ary) + 1;
2806 if (offset > AvFILLp(ary) + 1)
2807 offset = AvFILLp(ary) + 1;
2808 after = AvFILLp(ary) + 1 - (offset + length);
2809 if (after < 0) { /* not that much array */
2810 length += after; /* offset+length now in array */
2816 /* At this point, MARK .. SP-1 is our new LIST */
2819 diff = newlen - length;
2820 if (newlen && !AvREAL(ary)) {
2824 assert(AvREAL(ary)); /* would leak, so croak */
2827 if (diff < 0) { /* shrinking the area */
2829 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2830 Copy(MARK, tmparyval, newlen, SV*);
2833 MARK = ORIGMARK + 1;
2834 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2835 MEXTEND(MARK, length);
2836 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2838 EXTEND_MORTAL(length);
2839 for (i = length, dst = MARK; i; i--) {
2840 sv_2mortal(*dst); /* free them eventualy */
2847 *MARK = AvARRAY(ary)[offset+length-1];
2850 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2851 SvREFCNT_dec(*dst++); /* free them now */
2854 AvFILLp(ary) += diff;
2856 /* pull up or down? */
2858 if (offset < after) { /* easier to pull up */
2859 if (offset) { /* esp. if nothing to pull */
2860 src = &AvARRAY(ary)[offset-1];
2861 dst = src - diff; /* diff is negative */
2862 for (i = offset; i > 0; i--) /* can't trust Copy */
2866 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2870 if (after) { /* anything to pull down? */
2871 src = AvARRAY(ary) + offset + length;
2872 dst = src + diff; /* diff is negative */
2873 Move(src, dst, after, SV*);
2875 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2876 /* avoid later double free */
2880 dst[--i] = &PL_sv_undef;
2883 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2885 *dst = NEWSV(46, 0);
2886 sv_setsv(*dst++, *src++);
2888 Safefree(tmparyval);
2891 else { /* no, expanding (or same) */
2893 New(452, tmparyval, length, SV*); /* so remember deletion */
2894 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2897 if (diff > 0) { /* expanding */
2899 /* push up or down? */
2901 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2905 Move(src, dst, offset, SV*);
2907 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2909 AvFILLp(ary) += diff;
2912 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2913 av_extend(ary, AvFILLp(ary) + diff);
2914 AvFILLp(ary) += diff;
2917 dst = AvARRAY(ary) + AvFILLp(ary);
2919 for (i = after; i; i--) {
2926 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2927 *dst = NEWSV(46, 0);
2928 sv_setsv(*dst++, *src++);
2930 MARK = ORIGMARK + 1;
2931 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2933 Copy(tmparyval, MARK, length, SV*);
2935 EXTEND_MORTAL(length);
2936 for (i = length, dst = MARK; i; i--) {
2937 sv_2mortal(*dst); /* free them eventualy */
2941 Safefree(tmparyval);
2945 else if (length--) {
2946 *MARK = tmparyval[length];
2949 while (length-- > 0)
2950 SvREFCNT_dec(tmparyval[length]);
2952 Safefree(tmparyval);
2955 *MARK = &PL_sv_undef;
2963 djSP; dMARK; dORIGMARK; dTARGET;
2964 register AV *ary = (AV*)*++MARK;
2965 register SV *sv = &PL_sv_undef;
2968 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2969 *MARK-- = mg->mg_obj;
2973 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2978 /* Why no pre-extend of ary here ? */
2979 for (++MARK; MARK <= SP; MARK++) {
2982 sv_setsv(sv, *MARK);
2987 PUSHi( AvFILL(ary) + 1 );
2995 SV *sv = av_pop(av);
2997 (void)sv_2mortal(sv);
3006 SV *sv = av_shift(av);
3011 (void)sv_2mortal(sv);
3018 djSP; dMARK; dORIGMARK; dTARGET;
3019 register AV *ary = (AV*)*++MARK;
3024 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
3025 *MARK-- = mg->mg_obj;
3029 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3034 av_unshift(ary, SP - MARK);
3037 sv_setsv(sv, *++MARK);
3038 (void)av_store(ary, i++, sv);
3042 PUSHi( AvFILL(ary) + 1 );
3052 if (GIMME == G_ARRAY) {
3063 register char *down;
3069 do_join(TARG, &PL_sv_no, MARK, SP);
3071 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3072 up = SvPV_force(TARG, len);
3074 if (IN_UTF8) { /* first reverse each character */
3075 U8* s = (U8*)SvPVX(TARG);
3076 U8* send = (U8*)(s + len);
3085 down = (char*)(s - 1);
3086 if (s > send || !((*down & 0xc0) == 0x80)) {
3087 warn("Malformed UTF-8 character");
3099 down = SvPVX(TARG) + len - 1;
3105 (void)SvPOK_only(TARG);
3114 mul128(SV *sv, U8 m)
3117 char *s = SvPV(sv, len);
3121 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3122 SV *tmpNew = newSVpv("0000000000", 10);
3124 sv_catsv(tmpNew, sv);
3125 SvREFCNT_dec(sv); /* free old sv */
3130 while (!*t) /* trailing '\0'? */
3133 i = ((*t - '0') << 7) + m;
3134 *(t--) = '0' + (i % 10);
3140 /* Explosives and implosives. */
3142 static const char uuemap[] =
3143 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3144 static char uudmap[256]; /* Initialised on first use */
3145 #if 'I' == 73 && 'J' == 74
3146 /* On an ASCII/ISO kind of system */
3147 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3150 Some other sort of character set - use memchr() so we don't match
3153 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3161 I32 gimme = GIMME_V;
3165 register char *pat = SvPV(left, llen);
3166 register char *s = SvPV(right, rlen);
3167 char *strend = s + rlen;
3169 register char *patend = pat + llen;
3174 /* These must not be in registers: */
3185 unsigned Quad_t auquad;
3191 register U32 culong;
3193 static char* bitcount = 0;
3196 if (gimme != G_ARRAY) { /* arrange to do first one only */
3198 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3199 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3201 while (isDIGIT(*patend) || *patend == '*')
3207 while (pat < patend) {
3209 datumtype = *pat++ & 0xFF;
3210 if (isSPACE(datumtype))
3214 else if (*pat == '*') {
3215 len = strend - strbeg; /* long enough */
3218 else if (isDIGIT(*pat)) {
3220 while (isDIGIT(*pat))
3221 len = (len * 10) + (*pat++ - '0');
3224 len = (datumtype != '@');
3227 croak("Invalid type in unpack: '%c'", (int)datumtype);
3228 case ',': /* grandfather in commas but with a warning */
3229 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3230 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3233 if (len == 1 && pat[-1] != '1')
3242 if (len > strend - strbeg)
3243 DIE("@ outside of string");
3247 if (len > s - strbeg)
3248 DIE("X outside of string");
3252 if (len > strend - s)
3253 DIE("x outside of string");
3258 if (len > strend - s)
3261 goto uchar_checksum;
3262 sv = NEWSV(35, len);
3263 sv_setpvn(sv, s, len);
3265 if (datumtype == 'A') {
3266 aptr = s; /* borrow register */
3267 s = SvPVX(sv) + len - 1;
3268 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3271 SvCUR_set(sv, s - SvPVX(sv));
3272 s = aptr; /* unborrow register */
3274 XPUSHs(sv_2mortal(sv));
3278 if (pat[-1] == '*' || len > (strend - s) * 8)
3279 len = (strend - s) * 8;
3282 Newz(601, bitcount, 256, char);
3283 for (bits = 1; bits < 256; bits++) {
3284 if (bits & 1) bitcount[bits]++;
3285 if (bits & 2) bitcount[bits]++;
3286 if (bits & 4) bitcount[bits]++;
3287 if (bits & 8) bitcount[bits]++;
3288 if (bits & 16) bitcount[bits]++;
3289 if (bits & 32) bitcount[bits]++;
3290 if (bits & 64) bitcount[bits]++;
3291 if (bits & 128) bitcount[bits]++;
3295 culong += bitcount[*(unsigned char*)s++];
3300 if (datumtype == 'b') {
3302 if (bits & 1) culong++;
3308 if (bits & 128) culong++;
3315 sv = NEWSV(35, len + 1);
3318 aptr = pat; /* borrow register */
3320 if (datumtype == 'b') {
3322 for (len = 0; len < aint; len++) {
3323 if (len & 7) /*SUPPRESS 595*/
3327 *pat++ = '0' + (bits & 1);
3332 for (len = 0; len < aint; len++) {
3337 *pat++ = '0' + ((bits & 128) != 0);
3341 pat = aptr; /* unborrow register */
3342 XPUSHs(sv_2mortal(sv));
3346 if (pat[-1] == '*' || len > (strend - s) * 2)
3347 len = (strend - s) * 2;
3348 sv = NEWSV(35, len + 1);
3351 aptr = pat; /* borrow register */
3353 if (datumtype == 'h') {
3355 for (len = 0; len < aint; len++) {
3360 *pat++ = PL_hexdigit[bits & 15];
3365 for (len = 0; len < aint; len++) {
3370 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3374 pat = aptr; /* unborrow register */
3375 XPUSHs(sv_2mortal(sv));
3378 if (len > strend - s)
3383 if (aint >= 128) /* fake up signed chars */
3393 if (aint >= 128) /* fake up signed chars */
3396 sv_setiv(sv, (IV)aint);
3397 PUSHs(sv_2mortal(sv));
3402 if (len > strend - s)
3417 sv_setiv(sv, (IV)auint);
3418 PUSHs(sv_2mortal(sv));
3423 if (len > strend - s)
3426 while (len-- > 0 && s < strend) {
3427 auint = utf8_to_uv((U8*)s, &along);
3435 while (len-- > 0 && s < strend) {
3436 auint = utf8_to_uv((U8*)s, &along);
3439 sv_setiv(sv, (IV)auint);
3440 PUSHs(sv_2mortal(sv));
3445 along = (strend - s) / SIZE16;
3462 sv_setiv(sv, (IV)ashort);
3463 PUSHs(sv_2mortal(sv));
3470 along = (strend - s) / SIZE16;
3475 COPY16(s, &aushort);
3478 if (datumtype == 'n')
3479 aushort = PerlSock_ntohs(aushort);
3482 if (datumtype == 'v')
3483 aushort = vtohs(aushort);
3492 COPY16(s, &aushort);
3496 if (datumtype == 'n')
3497 aushort = PerlSock_ntohs(aushort);
3500 if (datumtype == 'v')
3501 aushort = vtohs(aushort);
3503 sv_setiv(sv, (IV)aushort);
3504 PUSHs(sv_2mortal(sv));
3509 along = (strend - s) / sizeof(int);
3514 Copy(s, &aint, 1, int);
3517 cdouble += (double)aint;
3526 Copy(s, &aint, 1, int);
3530 /* Without the dummy below unpack("i", pack("i",-1))
3531 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3532 * cc with optimization turned on */
3534 sv_setiv(sv, (IV)aint) :
3536 sv_setiv(sv, (IV)aint);
3537 PUSHs(sv_2mortal(sv));
3542 along = (strend - s) / sizeof(unsigned int);
3547 Copy(s, &auint, 1, unsigned int);
3548 s += sizeof(unsigned int);
3550 cdouble += (double)auint;
3559 Copy(s, &auint, 1, unsigned int);
3560 s += sizeof(unsigned int);
3562 sv_setuv(sv, (UV)auint);
3563 PUSHs(sv_2mortal(sv));
3568 along = (strend - s) / SIZE32;
3576 cdouble += (double)along;
3588 sv_setiv(sv, (IV)along);
3589 PUSHs(sv_2mortal(sv));
3596 along = (strend - s) / SIZE32;
3604 if (datumtype == 'N')
3605 aulong = PerlSock_ntohl(aulong);
3608 if (datumtype == 'V')
3609 aulong = vtohl(aulong);
3612 cdouble += (double)aulong;
3624 if (datumtype == 'N')
3625 aulong = PerlSock_ntohl(aulong);
3628 if (datumtype == 'V')
3629 aulong = vtohl(aulong);
3632 sv_setuv(sv, (UV)aulong);
3633 PUSHs(sv_2mortal(sv));
3638 along = (strend - s) / sizeof(char*);
3644 if (sizeof(char*) > strend - s)
3647 Copy(s, &aptr, 1, char*);
3653 PUSHs(sv_2mortal(sv));
3663 while ((len > 0) && (s < strend)) {
3664 auv = (auv << 7) | (*s & 0x7f);
3665 if (!(*s++ & 0x80)) {
3669 PUSHs(sv_2mortal(sv));
3673 else if (++bytes >= sizeof(UV)) { /* promote to string */
3676 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3677 while (s < strend) {
3678 sv = mul128(sv, *s & 0x7f);
3679 if (!(*s++ & 0x80)) {
3684 t = SvPV(sv, PL_na);
3688 PUSHs(sv_2mortal(sv));
3693 if ((s >= strend) && bytes)
3694 croak("Unterminated compressed integer");
3699 if (sizeof(char*) > strend - s)
3702 Copy(s, &aptr, 1, char*);
3707 sv_setpvn(sv, aptr, len);
3708 PUSHs(sv_2mortal(sv));
3712 along = (strend - s) / sizeof(Quad_t);
3718 if (s + sizeof(Quad_t) > strend)
3721 Copy(s, &aquad, 1, Quad_t);
3722 s += sizeof(Quad_t);
3725 if (aquad >= IV_MIN && aquad <= IV_MAX)
3726 sv_setiv(sv, (IV)aquad);
3728 sv_setnv(sv, (double)aquad);
3729 PUSHs(sv_2mortal(sv));
3733 along = (strend - s) / sizeof(Quad_t);
3739 if (s + sizeof(unsigned Quad_t) > strend)
3742 Copy(s, &auquad, 1, unsigned Quad_t);
3743 s += sizeof(unsigned Quad_t);
3746 if (auquad <= UV_MAX)
3747 sv_setuv(sv, (UV)auquad);
3749 sv_setnv(sv, (double)auquad);
3750 PUSHs(sv_2mortal(sv));
3754 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3757 along = (strend - s) / sizeof(float);
3762 Copy(s, &afloat, 1, float);
3771 Copy(s, &afloat, 1, float);
3774 sv_setnv(sv, (double)afloat);
3775 PUSHs(sv_2mortal(sv));
3781 along = (strend - s) / sizeof(double);
3786 Copy(s, &adouble, 1, double);
3787 s += sizeof(double);
3795 Copy(s, &adouble, 1, double);
3796 s += sizeof(double);
3798 sv_setnv(sv, (double)adouble);
3799 PUSHs(sv_2mortal(sv));
3805 * Initialise the decode mapping. By using a table driven
3806 * algorithm, the code will be character-set independent
3807 * (and just as fast as doing character arithmetic)
3809 if (uudmap['M'] == 0) {
3812 for (i = 0; i < sizeof(uuemap); i += 1)
3813 uudmap[uuemap[i]] = i;
3815 * Because ' ' and '`' map to the same value,
3816 * we need to decode them both the same.
3821 along = (strend - s) * 3 / 4;
3822 sv = NEWSV(42, along);
3825 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3830 len = uudmap[*s++] & 077;
3832 if (s < strend && ISUUCHAR(*s))
3833 a = uudmap[*s++] & 077;
3836 if (s < strend && ISUUCHAR(*s))
3837 b = uudmap[*s++] & 077;
3840 if (s < strend && ISUUCHAR(*s))
3841 c = uudmap[*s++] & 077;
3844 if (s < strend && ISUUCHAR(*s))
3845 d = uudmap[*s++] & 077;
3848 hunk[0] = (a << 2) | (b >> 4);
3849 hunk[1] = (b << 4) | (c >> 2);
3850 hunk[2] = (c << 6) | d;
3851 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3856 else if (s[1] == '\n') /* possible checksum byte */
3859 XPUSHs(sv_2mortal(sv));
3864 if (strchr("fFdD", datumtype) ||
3865 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3869 while (checksum >= 16) {
3873 while (checksum >= 4) {
3879 along = (1 << checksum) - 1;
3880 while (cdouble < 0.0)
3882 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3883 sv_setnv(sv, cdouble);
3886 if (checksum < 32) {
3887 aulong = (1 << checksum) - 1;
3890 sv_setuv(sv, (UV)culong);
3892 XPUSHs(sv_2mortal(sv));
3896 if (SP == oldsp && gimme == G_SCALAR)
3897 PUSHs(&PL_sv_undef);
3902 doencodes(register SV *sv, register char *s, register I32 len)
3906 *hunk = uuemap[len];
3907 sv_catpvn(sv, hunk, 1);
3910 hunk[0] = uuemap[(077 & (*s >> 2))];
3911 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3912 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3913 hunk[3] = uuemap[(077 & (s[2] & 077))];
3914 sv_catpvn(sv, hunk, 4);
3919 char r = (len > 1 ? s[1] : '\0');
3920 hunk[0] = uuemap[(077 & (*s >> 2))];
3921 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3922 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3923 hunk[3] = uuemap[0];
3924 sv_catpvn(sv, hunk, 4);
3926 sv_catpvn(sv, "\n", 1);
3930 is_an_int(char *s, STRLEN l)
3932 SV *result = newSVpv("", l);
3933 char *result_c = SvPV(result, PL_na); /* convenience */
3934 char *out = result_c;
3944 SvREFCNT_dec(result);
3967 SvREFCNT_dec(result);
3973 SvCUR_set(result, out - result_c);
3978 div128(SV *pnum, bool *done)
3979 /* must be '\0' terminated */
3983 char *s = SvPV(pnum, len);
3992 i = m * 10 + (*t - '0');
3994 r = (i >> 7); /* r < 10 */
4001 SvCUR_set(pnum, (STRLEN) (t - s));
4008 djSP; dMARK; dORIGMARK; dTARGET;
4009 register SV *cat = TARG;
4012 register char *pat = SvPVx(*++MARK, fromlen);
4013 register char *patend = pat + fromlen;
4018 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4019 static char *space10 = " ";
4021 /* These must not be in registers: */
4030 unsigned Quad_t auquad;
4039 sv_setpvn(cat, "", 0);
4040 while (pat < patend) {
4041 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4042 datumtype = *pat++ & 0xFF;
4043 if (isSPACE(datumtype))
4046 len = strchr("@Xxu", datumtype) ? 0 : items;
4049 else if (isDIGIT(*pat)) {
4051 while (isDIGIT(*pat))
4052 len = (len * 10) + (*pat++ - '0');
4058 croak("Invalid type in pack: '%c'", (int)datumtype);
4059 case ',': /* grandfather in commas but with a warning */
4060 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4061 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4064 DIE("%% may only be used in unpack");
4075 if (SvCUR(cat) < len)
4076 DIE("X outside of string");
4083 sv_catpvn(cat, null10, 10);
4086 sv_catpvn(cat, null10, len);
4091 aptr = SvPV(fromstr, fromlen);
4095 sv_catpvn(cat, aptr, len);
4097 sv_catpvn(cat, aptr, fromlen);
4099 if (datumtype == 'A') {
4101 sv_catpvn(cat, space10, 10);
4104 sv_catpvn(cat, space10, len);
4108 sv_catpvn(cat, null10, 10);
4111 sv_catpvn(cat, null10, len);
4118 char *savepat = pat;
4123 aptr = SvPV(fromstr, fromlen);
4128 SvCUR(cat) += (len+7)/8;
4129 SvGROW(cat, SvCUR(cat) + 1);
4130 aptr = SvPVX(cat) + aint;
4135 if (datumtype == 'B') {
4136 for (len = 0; len++ < aint;) {
4137 items |= *pat++ & 1;
4141 *aptr++ = items & 0xff;
4147 for (len = 0; len++ < aint;) {
4153 *aptr++ = items & 0xff;
4159 if (datumtype == 'B')
4160 items <<= 7 - (aint & 7);
4162 items >>= 7 - (aint & 7);
4163 *aptr++ = items & 0xff;
4165 pat = SvPVX(cat) + SvCUR(cat);
4176 char *savepat = pat;
4181 aptr = SvPV(fromstr, fromlen);
4186 SvCUR(cat) += (len+1)/2;
4187 SvGROW(cat, SvCUR(cat) + 1);
4188 aptr = SvPVX(cat) + aint;
4193 if (datumtype == 'H') {
4194 for (len = 0; len++ < aint;) {
4196 items |= ((*pat++ & 15) + 9) & 15;
4198 items |= *pat++ & 15;
4202 *aptr++ = items & 0xff;
4208 for (len = 0; len++ < aint;) {
4210 items |= (((*pat++ & 15) + 9) & 15) << 4;
4212 items |= (*pat++ & 15) << 4;
4216 *aptr++ = items & 0xff;
4222 *aptr++ = items & 0xff;
4223 pat = SvPVX(cat) + SvCUR(cat);
4235 aint = SvIV(fromstr);
4237 sv_catpvn(cat, &achar, sizeof(char));
4243 auint = SvUV(fromstr);
4244 SvGROW(cat, SvCUR(cat) + 10);
4245 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4250 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4255 afloat = (float)SvNV(fromstr);
4256 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4263 adouble = (double)SvNV(fromstr);
4264 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4270 ashort = (I16)SvIV(fromstr);
4272 ashort = PerlSock_htons(ashort);
4274 CAT16(cat, &ashort);
4280 ashort = (I16)SvIV(fromstr);
4282 ashort = htovs(ashort);
4284 CAT16(cat, &ashort);
4291 ashort = (I16)SvIV(fromstr);
4292 CAT16(cat, &ashort);
4298 auint = SvUV(fromstr);
4299 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4305 adouble = floor(SvNV(fromstr));
4308 croak("Cannot compress negative numbers");
4314 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4315 adouble <= UV_MAX_cxux
4322 char buf[1 + sizeof(UV)];
4323 char *in = buf + sizeof(buf);
4324 UV auv = U_V(adouble);;
4327 *--in = (auv & 0x7f) | 0x80;
4330 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4331 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4333 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4334 char *from, *result, *in;
4339 /* Copy string and check for compliance */
4340 from = SvPV(fromstr, len);
4341 if ((norm = is_an_int(from, len)) == NULL)
4342 croak("can compress only unsigned integer");
4344 New('w', result, len, char);
4348 *--in = div128(norm, &done) | 0x80;
4349 result[len - 1] &= 0x7F; /* clear continue bit */
4350 sv_catpvn(cat, in, (result + len) - in);
4352 SvREFCNT_dec(norm); /* free norm */
4354 else if (SvNOKp(fromstr)) {
4355 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4356 char *in = buf + sizeof(buf);
4359 double next = floor(adouble / 128);
4360 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4361 if (--in < buf) /* this cannot happen ;-) */
4362 croak ("Cannot compress integer");
4364 } while (adouble > 0);
4365 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4366 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4369 croak("Cannot compress non integer");
4375 aint = SvIV(fromstr);
4376 sv_catpvn(cat, (char*)&aint, sizeof(int));
4382 aulong = SvUV(fromstr);
4384 aulong = PerlSock_htonl(aulong);
4386 CAT32(cat, &aulong);
4392 aulong = SvUV(fromstr);
4394 aulong = htovl(aulong);
4396 CAT32(cat, &aulong);
4402 aulong = SvUV(fromstr);
4403 CAT32(cat, &aulong);
4409 along = SvIV(fromstr);
4417 auquad = (unsigned Quad_t)SvIV(fromstr);
4418 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4424 aquad = (Quad_t)SvIV(fromstr);
4425 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4428 #endif /* HAS_QUAD */
4430 len = 1; /* assume SV is correct length */
4435 if (fromstr == &PL_sv_undef)
4438 /* XXX better yet, could spirit away the string to
4439 * a safe spot and hang on to it until the result
4440 * of pack() (and all copies of the result) are
4443 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4445 "Attempt to pack pointer to temporary value");
4446 if (SvPOK(fromstr) || SvNIOK(fromstr))
4447 aptr = SvPV(fromstr,PL_na);
4449 aptr = SvPV_force(fromstr,PL_na);
4451 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4456 aptr = SvPV(fromstr, fromlen);
4457 SvGROW(cat, fromlen * 4 / 3);
4462 while (fromlen > 0) {
4469 doencodes(cat, aptr, todo);
4488 register I32 limit = POPi; /* note, negative is forever */
4491 register char *s = SvPV(sv, len);
4492 char *strend = s + len;
4494 register REGEXP *rx;
4498 I32 maxiters = (strend - s) + 10;
4501 I32 origlimit = limit;
4504 AV *oldstack = PL_curstack;
4505 I32 gimme = GIMME_V;
4506 I32 oldsave = PL_savestack_ix;
4507 I32 make_mortal = 1;
4508 MAGIC *mg = (MAGIC *) NULL;
4511 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4516 DIE("panic: do_split");
4517 rx = pm->op_pmregexp;
4519 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4520 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4522 if (pm->op_pmreplroot)
4523 ary = GvAVn((GV*)pm->op_pmreplroot);
4524 else if (gimme != G_ARRAY)
4526 ary = (AV*)PL_curpad[0];
4528 ary = GvAVn(PL_defgv);
4529 #endif /* USE_THREADS */
4532 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4538 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4545 for (i = AvFILLp(ary); i >= 0; i--)
4546 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4548 /* temporarily switch stacks */
4549 SWITCHSTACK(PL_curstack, ary);
4553 base = SP - PL_stack_base;
4555 if (pm->op_pmflags & PMf_SKIPWHITE) {
4556 if (pm->op_pmflags & PMf_LOCALE) {
4557 while (isSPACE_LC(*s))
4565 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4566 SAVEINT(PL_multiline);
4567 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4571 limit = maxiters + 2;
4572 if (pm->op_pmflags & PMf_WHITE) {
4575 while (m < strend &&
4576 !((pm->op_pmflags & PMf_LOCALE)
4577 ? isSPACE_LC(*m) : isSPACE(*m)))
4582 dstr = NEWSV(30, m-s);
4583 sv_setpvn(dstr, s, m-s);
4589 while (s < strend &&
4590 ((pm->op_pmflags & PMf_LOCALE)
4591 ? isSPACE_LC(*s) : isSPACE(*s)))
4595 else if (strEQ("^", rx->precomp)) {
4598 for (m = s; m < strend && *m != '\n'; m++) ;
4602 dstr = NEWSV(30, m-s);
4603 sv_setpvn(dstr, s, m-s);
4610 else if (rx->check_substr && !rx->nparens
4611 && (rx->reganch & ROPT_CHECK_ALL)
4612 && !(rx->reganch & ROPT_ANCH)) {
4613 i = SvCUR(rx->check_substr);
4614 if (i == 1 && !SvTAIL(rx->check_substr)) {
4615 i = *SvPVX(rx->check_substr);
4618 for (m = s; m < strend && *m != i; m++) ;
4621 dstr = NEWSV(30, m-s);
4622 sv_setpvn(dstr, s, m-s);
4631 while (s < strend && --limit &&
4632 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4633 rx->check_substr, 0)) )
4636 dstr = NEWSV(31, m-s);
4637 sv_setpvn(dstr, s, m-s);
4646 maxiters += (strend - s) * rx->nparens;
4647 while (s < strend && --limit &&
4648 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4650 TAINT_IF(RX_MATCH_TAINTED(rx));
4652 && rx->subbase != orig) {
4657 strend = s + (strend - m);
4660 dstr = NEWSV(32, m-s);
4661 sv_setpvn(dstr, s, m-s);
4666 for (i = 1; i <= rx->nparens; i++) {
4670 dstr = NEWSV(33, m-s);
4671 sv_setpvn(dstr, s, m-s);
4674 dstr = NEWSV(33, 0);
4684 LEAVE_SCOPE(oldsave);
4685 iters = (SP - PL_stack_base) - base;
4686 if (iters > maxiters)
4689 /* keep field after final delim? */
4690 if (s < strend || (iters && origlimit)) {
4691 dstr = NEWSV(34, strend-s);
4692 sv_setpvn(dstr, s, strend-s);
4698 else if (!origlimit) {
4699 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4705 SWITCHSTACK(ary, oldstack);
4706 if (SvSMAGICAL(ary)) {
4711 if (gimme == G_ARRAY) {
4713 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4721 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4724 if (gimme == G_ARRAY) {
4725 /* EXTEND should not be needed - we just popped them */
4727 for (i=0; i < iters; i++) {
4728 SV **svp = av_fetch(ary, i, FALSE);
4729 PUSHs((svp) ? *svp : &PL_sv_undef);
4736 if (gimme == G_ARRAY)
4739 if (iters || !pm->op_pmreplroot) {
4749 unlock_condpair(void *svv)
4752 MAGIC *mg = mg_find((SV*)svv, 'm');
4755 croak("panic: unlock_condpair unlocking non-mutex");
4756 MUTEX_LOCK(MgMUTEXP(mg));
4757 if (MgOWNER(mg) != thr)
4758 croak("panic: unlock_condpair unlocking mutex that we don't own");
4760 COND_SIGNAL(MgOWNERCONDP(mg));
4761 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4762 (unsigned long)thr, (unsigned long)svv);)
4763 MUTEX_UNLOCK(MgMUTEXP(mg));
4765 #endif /* USE_THREADS */
4778 mg = condpair_magic(sv);
4779 MUTEX_LOCK(MgMUTEXP(mg));
4780 if (MgOWNER(mg) == thr)
4781 MUTEX_UNLOCK(MgMUTEXP(mg));
4784 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4786 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4787 (unsigned long)thr, (unsigned long)sv);)
4788 MUTEX_UNLOCK(MgMUTEXP(mg));
4789 SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
4790 save_destructor(unlock_condpair, sv);
4792 #endif /* USE_THREADS */
4793 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4794 || SvTYPE(retsv) == SVt_PVCV) {
4795 retsv = refto(retsv);
4806 if (PL_op->op_private & OPpLVAL_INTRO)
4807 PUSHs(*save_threadsv(PL_op->op_targ));
4809 PUSHs(THREADSV(PL_op->op_targ));
4812 DIE("tried to access per-thread data in non-threaded perl");
4813 #endif /* USE_THREADS */