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
1643 # include <starlet.h>
1644 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1645 * in 100-ns units, typically incremented ever 10 ms. */
1646 unsigned int when[2];
1647 _ckvmssts(sys$gettim(when));
1648 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1650 # ifdef HAS_GETTIMEOFDAY
1651 struct timeval when;
1652 gettimeofday(&when,(struct timezone *) 0);
1653 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1657 u = (U32)SEED_C1 * when;
1660 u += SEED_C3 * (U32)getpid();
1661 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1662 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1663 u += SEED_C5 * (U32)(UV)&when;
1670 djSP; dTARGET; tryAMAGICun(exp);
1682 djSP; dTARGET; tryAMAGICun(log);
1687 SET_NUMERIC_STANDARD();
1688 DIE("Can't take log of %g", value);
1698 djSP; dTARGET; tryAMAGICun(sqrt);
1703 SET_NUMERIC_STANDARD();
1704 DIE("Can't take sqrt of %g", value);
1706 value = sqrt(value);
1716 double value = TOPn;
1719 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1725 (void)modf(value, &value);
1727 (void)modf(-value, &value);
1742 djSP; dTARGET; tryAMAGICun(abs);
1744 double value = TOPn;
1747 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1748 (iv = SvIVX(TOPs)) != IV_MIN) {
1769 XPUSHu(scan_hex(tmps, 99, &argtype));
1781 while (*tmps && isSPACE(*tmps))
1786 value = scan_hex(++tmps, 99, &argtype);
1788 value = scan_oct(tmps, 99, &argtype);
1800 SETi( sv_len_utf8(TOPs) );
1804 SETi( sv_len(TOPs) );
1818 I32 lvalue = PL_op->op_flags & OPf_MOD;
1820 I32 arybase = PL_curcop->cop_arybase;
1824 SvTAINTED_off(TARG); /* decontaminate */
1828 repl = SvPV(sv, repl_len);
1835 tmps = SvPV(sv, curlen);
1837 utfcurlen = sv_len_utf8(sv);
1838 if (utfcurlen == curlen)
1846 if (pos >= arybase) {
1864 else if (len >= 0) {
1866 if (rem > (I32)curlen)
1880 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1881 warner(WARN_SUBSTR, "substr outside of string");
1886 sv_pos_u2b(sv, &pos, &rem);
1888 sv_setpvn(TARG, tmps, rem);
1889 if (lvalue) { /* it's an lvalue! */
1890 if (!SvGMAGICAL(sv)) {
1892 SvPV_force(sv,PL_na);
1893 if (ckWARN(WARN_SUBSTR))
1895 "Attempt to use reference as lvalue in substr");
1897 if (SvOK(sv)) /* is it defined ? */
1898 (void)SvPOK_only(sv);
1900 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1903 if (SvTYPE(TARG) < SVt_PVLV) {
1904 sv_upgrade(TARG, SVt_PVLV);
1905 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1909 if (LvTARG(TARG) != sv) {
1911 SvREFCNT_dec(LvTARG(TARG));
1912 LvTARG(TARG) = SvREFCNT_inc(sv);
1914 LvTARGOFF(TARG) = pos;
1915 LvTARGLEN(TARG) = rem;
1918 sv_insert(sv, pos, rem, repl, repl_len);
1921 PUSHs(TARG); /* avoid SvSETMAGIC here */
1928 register I32 size = POPi;
1929 register I32 offset = POPi;
1930 register SV *src = POPs;
1931 I32 lvalue = PL_op->op_flags & OPf_MOD;
1933 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1934 unsigned long retnum;
1937 SvTAINTED_off(TARG); /* decontaminate */
1938 offset *= size; /* turn into bit offset */
1939 len = (offset + size + 7) / 8;
1940 if (offset < 0 || size < 1)
1943 if (lvalue) { /* it's an lvalue! */
1944 if (SvTYPE(TARG) < SVt_PVLV) {
1945 sv_upgrade(TARG, SVt_PVLV);
1946 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1950 if (LvTARG(TARG) != src) {
1952 SvREFCNT_dec(LvTARG(TARG));
1953 LvTARG(TARG) = SvREFCNT_inc(src);
1955 LvTARGOFF(TARG) = offset;
1956 LvTARGLEN(TARG) = size;
1964 if (offset >= srclen)
1967 retnum = (unsigned long) s[offset] << 8;
1969 else if (size == 32) {
1970 if (offset >= srclen)
1972 else if (offset + 1 >= srclen)
1973 retnum = (unsigned long) s[offset] << 24;
1974 else if (offset + 2 >= srclen)
1975 retnum = ((unsigned long) s[offset] << 24) +
1976 ((unsigned long) s[offset + 1] << 16);
1978 retnum = ((unsigned long) s[offset] << 24) +
1979 ((unsigned long) s[offset + 1] << 16) +
1980 (s[offset + 2] << 8);
1985 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1990 else if (size == 16)
1991 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1992 else if (size == 32)
1993 retnum = ((unsigned long) s[offset] << 24) +
1994 ((unsigned long) s[offset + 1] << 16) +
1995 (s[offset + 2] << 8) + s[offset+3];
1999 sv_setuv(TARG, (UV)retnum);
2014 I32 arybase = PL_curcop->cop_arybase;
2019 offset = POPi - arybase;
2022 tmps = SvPV(big, biglen);
2023 if (IN_UTF8 && offset > 0)
2024 sv_pos_u2b(big, &offset, 0);
2027 else if (offset > biglen)
2029 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2030 (unsigned char*)tmps + biglen, little, 0)))
2033 retval = tmps2 - tmps;
2034 if (IN_UTF8 && retval > 0)
2035 sv_pos_b2u(big, &retval);
2036 PUSHi(retval + arybase);
2051 I32 arybase = PL_curcop->cop_arybase;
2057 tmps2 = SvPV(little, llen);
2058 tmps = SvPV(big, blen);
2062 if (IN_UTF8 && offset > 0)
2063 sv_pos_u2b(big, &offset, 0);
2064 offset = offset - arybase + llen;
2068 else if (offset > blen)
2070 if (!(tmps2 = rninstr(tmps, tmps + offset,
2071 tmps2, tmps2 + llen)))
2074 retval = tmps2 - tmps;
2075 if (IN_UTF8 && retval > 0)
2076 sv_pos_b2u(big, &retval);
2077 PUSHi(retval + arybase);
2083 djSP; dMARK; dORIGMARK; dTARGET;
2084 #ifdef USE_LOCALE_NUMERIC
2085 if (PL_op->op_private & OPpLOCALE)
2086 SET_NUMERIC_LOCAL();
2088 SET_NUMERIC_STANDARD();
2090 do_sprintf(TARG, SP-MARK, MARK+1);
2091 TAINT_IF(SvTAINTED(TARG));
2101 U8 *tmps = (U8*)POPp;
2104 if (IN_UTF8 && (*tmps & 0x80))
2105 value = (I32) utf8_to_uv(tmps, &retlen);
2107 value = (I32) (*tmps & 255);
2118 (void)SvUPGRADE(TARG,SVt_PV);
2120 if (IN_UTF8 && value >= 128) {
2123 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2124 SvCUR_set(TARG, tmps - SvPVX(TARG));
2126 (void)SvPOK_only(TARG);
2136 (void)SvPOK_only(TARG);
2143 djSP; dTARGET; dPOPTOPssrl;
2145 char *tmps = SvPV(left, PL_na);
2147 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2149 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2153 "The crypt() function is unimplemented due to excessive paranoia.");
2166 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2170 UV uv = utf8_to_uv(s, &ulen);
2172 if (PL_op->op_private & OPpLOCALE) {
2175 uv = toTITLE_LC_uni(uv);
2178 uv = toTITLE_utf8(s);
2180 tend = uv_to_utf8(tmpbuf, uv);
2182 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2184 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2185 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2189 s = (U8*)SvPV_force(sv, slen);
2190 Copy(tmpbuf, s, ulen, U8);
2195 if (!SvPADTMP(sv)) {
2201 s = (U8*)SvPV_force(sv, PL_na);
2203 if (PL_op->op_private & OPpLOCALE) {
2206 *s = toUPPER_LC(*s);
2222 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2226 UV uv = utf8_to_uv(s, &ulen);
2228 if (PL_op->op_private & OPpLOCALE) {
2231 uv = toLOWER_LC_uni(uv);
2234 uv = toLOWER_utf8(s);
2236 tend = uv_to_utf8(tmpbuf, uv);
2238 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2240 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2241 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2245 s = (U8*)SvPV_force(sv, slen);
2246 Copy(tmpbuf, s, ulen, U8);
2251 if (!SvPADTMP(sv)) {
2257 s = (U8*)SvPV_force(sv, PL_na);
2259 if (PL_op->op_private & OPpLOCALE) {
2262 *s = toLOWER_LC(*s);
2285 s = (U8*)SvPV(sv,len);
2287 sv_setpvn(TARG, "", 0);
2292 (void)SvUPGRADE(TARG, SVt_PV);
2293 SvGROW(TARG, (len * 2) + 1);
2294 (void)SvPOK_only(TARG);
2295 d = (U8*)SvPVX(TARG);
2297 if (PL_op->op_private & OPpLOCALE) {
2301 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2307 d = uv_to_utf8(d, toUPPER_utf8( s ));
2312 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2317 if (!SvPADTMP(sv)) {
2324 s = (U8*)SvPV_force(sv, len);
2326 register U8 *send = s + len;
2328 if (PL_op->op_private & OPpLOCALE) {
2331 for (; s < send; s++)
2332 *s = toUPPER_LC(*s);
2335 for (; s < send; s++)
2355 s = (U8*)SvPV(sv,len);
2357 sv_setpvn(TARG, "", 0);
2362 (void)SvUPGRADE(TARG, SVt_PV);
2363 SvGROW(TARG, (len * 2) + 1);
2364 (void)SvPOK_only(TARG);
2365 d = (U8*)SvPVX(TARG);
2367 if (PL_op->op_private & OPpLOCALE) {
2371 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2377 d = uv_to_utf8(d, toLOWER_utf8(s));
2382 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2387 if (!SvPADTMP(sv)) {
2394 s = (U8*)SvPV_force(sv, len);
2396 register U8 *send = s + len;
2398 if (PL_op->op_private & OPpLOCALE) {
2401 for (; s < send; s++)
2402 *s = toLOWER_LC(*s);
2405 for (; s < send; s++)
2417 register char *s = SvPV(sv,len);
2421 (void)SvUPGRADE(TARG, SVt_PV);
2422 SvGROW(TARG, (len * 2) + 1);
2425 if (!(*s & 0x80) && !isALNUM(*s))
2430 SvCUR_set(TARG, d - SvPVX(TARG));
2431 (void)SvPOK_only(TARG);
2434 sv_setpvn(TARG, s, len);
2443 djSP; dMARK; dORIGMARK;
2445 register AV* av = (AV*)POPs;
2446 register I32 lval = PL_op->op_flags & OPf_MOD;
2447 I32 arybase = PL_curcop->cop_arybase;
2450 if (SvTYPE(av) == SVt_PVAV) {
2451 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2453 for (svp = MARK + 1; svp <= SP; svp++) {
2458 if (max > AvMAX(av))
2461 while (++MARK <= SP) {
2462 elem = SvIVx(*MARK);
2466 svp = av_fetch(av, elem, lval);
2468 if (!svp || *svp == &PL_sv_undef)
2469 DIE(no_aelem, elem);
2470 if (PL_op->op_private & OPpLVAL_INTRO)
2471 save_aelem(av, elem, svp);
2473 *MARK = svp ? *svp : &PL_sv_undef;
2476 if (GIMME != G_ARRAY) {
2484 /* Associative arrays. */
2489 HV *hash = (HV*)POPs;
2491 I32 gimme = GIMME_V;
2492 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2495 /* might clobber stack_sp */
2496 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2501 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2502 if (gimme == G_ARRAY) {
2504 /* might clobber stack_sp */
2505 sv_setsv(TARG, realhv ?
2506 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2511 else if (gimme == G_SCALAR)
2530 I32 gimme = GIMME_V;
2531 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2535 if (PL_op->op_private & OPpSLICE) {
2539 hvtype = SvTYPE(hv);
2540 while (++MARK <= SP) {
2541 if (hvtype == SVt_PVHV)
2542 sv = hv_delete_ent(hv, *MARK, discard, 0);
2544 DIE("Not a HASH reference");
2545 *MARK = sv ? sv : &PL_sv_undef;
2549 else if (gimme == G_SCALAR) {
2558 if (SvTYPE(hv) == SVt_PVHV)
2559 sv = hv_delete_ent(hv, keysv, discard, 0);
2561 DIE("Not a HASH reference");
2575 if (SvTYPE(hv) == SVt_PVHV) {
2576 if (hv_exists_ent(hv, tmpsv, 0))
2578 } else if (SvTYPE(hv) == SVt_PVAV) {
2579 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2582 DIE("Not a HASH reference");
2589 djSP; dMARK; dORIGMARK;
2590 register HV *hv = (HV*)POPs;
2591 register I32 lval = PL_op->op_flags & OPf_MOD;
2592 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2594 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2595 DIE("Can't localize pseudo-hash element");
2597 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2598 while (++MARK <= SP) {
2602 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2603 svp = he ? &HeVAL(he) : 0;
2605 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2608 if (!svp || *svp == &PL_sv_undef)
2609 DIE(no_helem, SvPV(keysv, PL_na));
2610 if (PL_op->op_private & OPpLVAL_INTRO)
2611 save_helem(hv, keysv, svp);
2613 *MARK = svp ? *svp : &PL_sv_undef;
2616 if (GIMME != G_ARRAY) {
2624 /* List operators. */
2629 if (GIMME != G_ARRAY) {
2631 *MARK = *SP; /* unwanted list, return last item */
2633 *MARK = &PL_sv_undef;
2642 SV **lastrelem = PL_stack_sp;
2643 SV **lastlelem = PL_stack_base + POPMARK;
2644 SV **firstlelem = PL_stack_base + POPMARK + 1;
2645 register SV **firstrelem = lastlelem + 1;
2646 I32 arybase = PL_curcop->cop_arybase;
2647 I32 lval = PL_op->op_flags & OPf_MOD;
2648 I32 is_something_there = lval;
2650 register I32 max = lastrelem - lastlelem;
2651 register SV **lelem;
2654 if (GIMME != G_ARRAY) {
2655 ix = SvIVx(*lastlelem);
2660 if (ix < 0 || ix >= max)
2661 *firstlelem = &PL_sv_undef;
2663 *firstlelem = firstrelem[ix];
2669 SP = firstlelem - 1;
2673 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2678 *lelem = &PL_sv_undef;
2679 else if (!(*lelem = firstrelem[ix]))
2680 *lelem = &PL_sv_undef;
2684 if (ix >= max || !(*lelem = firstrelem[ix]))
2685 *lelem = &PL_sv_undef;
2687 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2688 is_something_there = TRUE;
2690 if (is_something_there)
2693 SP = firstlelem - 1;
2699 djSP; dMARK; dORIGMARK;
2700 I32 items = SP - MARK;
2701 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2702 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2709 djSP; dMARK; dORIGMARK;
2710 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2714 SV *val = NEWSV(46, 0);
2716 sv_setsv(val, *++MARK);
2717 else if (ckWARN(WARN_UNSAFE))
2718 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2719 (void)hv_store_ent(hv,key,val,0);
2728 djSP; dMARK; dORIGMARK;
2729 register AV *ary = (AV*)*++MARK;
2733 register I32 offset;
2734 register I32 length;
2741 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2742 *MARK-- = mg->mg_obj;
2746 perl_call_method("SPLICE",GIMME_V);
2755 offset = i = SvIVx(*MARK);
2757 offset += AvFILLp(ary) + 1;
2759 offset -= PL_curcop->cop_arybase;
2763 length = SvIVx(*MARK++);
2765 length += AvFILLp(ary) - offset + 1;
2771 length = AvMAX(ary) + 1; /* close enough to infinity */
2775 length = AvMAX(ary) + 1;
2777 if (offset > AvFILLp(ary) + 1)
2778 offset = AvFILLp(ary) + 1;
2779 after = AvFILLp(ary) + 1 - (offset + length);
2780 if (after < 0) { /* not that much array */
2781 length += after; /* offset+length now in array */
2787 /* At this point, MARK .. SP-1 is our new LIST */
2790 diff = newlen - length;
2791 if (newlen && !AvREAL(ary)) {
2795 assert(AvREAL(ary)); /* would leak, so croak */
2798 if (diff < 0) { /* shrinking the area */
2800 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2801 Copy(MARK, tmparyval, newlen, SV*);
2804 MARK = ORIGMARK + 1;
2805 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2806 MEXTEND(MARK, length);
2807 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2809 EXTEND_MORTAL(length);
2810 for (i = length, dst = MARK; i; i--) {
2811 sv_2mortal(*dst); /* free them eventualy */
2818 *MARK = AvARRAY(ary)[offset+length-1];
2821 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2822 SvREFCNT_dec(*dst++); /* free them now */
2825 AvFILLp(ary) += diff;
2827 /* pull up or down? */
2829 if (offset < after) { /* easier to pull up */
2830 if (offset) { /* esp. if nothing to pull */
2831 src = &AvARRAY(ary)[offset-1];
2832 dst = src - diff; /* diff is negative */
2833 for (i = offset; i > 0; i--) /* can't trust Copy */
2837 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2841 if (after) { /* anything to pull down? */
2842 src = AvARRAY(ary) + offset + length;
2843 dst = src + diff; /* diff is negative */
2844 Move(src, dst, after, SV*);
2846 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2847 /* avoid later double free */
2851 dst[--i] = &PL_sv_undef;
2854 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2856 *dst = NEWSV(46, 0);
2857 sv_setsv(*dst++, *src++);
2859 Safefree(tmparyval);
2862 else { /* no, expanding (or same) */
2864 New(452, tmparyval, length, SV*); /* so remember deletion */
2865 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2868 if (diff > 0) { /* expanding */
2870 /* push up or down? */
2872 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2876 Move(src, dst, offset, SV*);
2878 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2880 AvFILLp(ary) += diff;
2883 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2884 av_extend(ary, AvFILLp(ary) + diff);
2885 AvFILLp(ary) += diff;
2888 dst = AvARRAY(ary) + AvFILLp(ary);
2890 for (i = after; i; i--) {
2897 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2898 *dst = NEWSV(46, 0);
2899 sv_setsv(*dst++, *src++);
2901 MARK = ORIGMARK + 1;
2902 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2904 Copy(tmparyval, MARK, length, SV*);
2906 EXTEND_MORTAL(length);
2907 for (i = length, dst = MARK; i; i--) {
2908 sv_2mortal(*dst); /* free them eventualy */
2912 Safefree(tmparyval);
2916 else if (length--) {
2917 *MARK = tmparyval[length];
2920 while (length-- > 0)
2921 SvREFCNT_dec(tmparyval[length]);
2923 Safefree(tmparyval);
2926 *MARK = &PL_sv_undef;
2934 djSP; dMARK; dORIGMARK; dTARGET;
2935 register AV *ary = (AV*)*++MARK;
2936 register SV *sv = &PL_sv_undef;
2939 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2940 *MARK-- = mg->mg_obj;
2944 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2949 /* Why no pre-extend of ary here ? */
2950 for (++MARK; MARK <= SP; MARK++) {
2953 sv_setsv(sv, *MARK);
2958 PUSHi( AvFILL(ary) + 1 );
2966 SV *sv = av_pop(av);
2968 (void)sv_2mortal(sv);
2977 SV *sv = av_shift(av);
2982 (void)sv_2mortal(sv);
2989 djSP; dMARK; dORIGMARK; dTARGET;
2990 register AV *ary = (AV*)*++MARK;
2995 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2996 *MARK-- = mg->mg_obj;
3000 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3005 av_unshift(ary, SP - MARK);
3008 sv_setsv(sv, *++MARK);
3009 (void)av_store(ary, i++, sv);
3013 PUSHi( AvFILL(ary) + 1 );
3023 if (GIMME == G_ARRAY) {
3034 register char *down;
3040 do_join(TARG, &PL_sv_no, MARK, SP);
3042 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3043 up = SvPV_force(TARG, len);
3045 if (IN_UTF8) { /* first reverse each character */
3046 U8* s = (U8*)SvPVX(TARG);
3047 U8* send = (U8*)(s + len);
3056 down = (char*)(s - 1);
3057 if (s > send || !((*down & 0xc0) == 0x80)) {
3058 warn("Malformed UTF-8 character");
3070 down = SvPVX(TARG) + len - 1;
3076 (void)SvPOK_only(TARG);
3085 mul128(SV *sv, U8 m)
3088 char *s = SvPV(sv, len);
3092 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3093 SV *tmpNew = newSVpv("0000000000", 10);
3095 sv_catsv(tmpNew, sv);
3096 SvREFCNT_dec(sv); /* free old sv */
3101 while (!*t) /* trailing '\0'? */
3104 i = ((*t - '0') << 7) + m;
3105 *(t--) = '0' + (i % 10);
3111 /* Explosives and implosives. */
3113 static const char uuemap[] =
3114 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3115 static char uudmap[256]; /* Initialised on first use */
3116 #if 'I' == 73 && 'J' == 74
3117 /* On an ASCII/ISO kind of system */
3118 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3121 Some other sort of character set - use memchr() so we don't match
3124 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3132 I32 gimme = GIMME_V;
3136 register char *pat = SvPV(left, llen);
3137 register char *s = SvPV(right, rlen);
3138 char *strend = s + rlen;
3140 register char *patend = pat + llen;
3145 /* These must not be in registers: */
3156 unsigned Quad_t auquad;
3162 register U32 culong;
3164 static char* bitcount = 0;
3167 if (gimme != G_ARRAY) { /* arrange to do first one only */
3169 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3170 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3172 while (isDIGIT(*patend) || *patend == '*')
3178 while (pat < patend) {
3180 datumtype = *pat++ & 0xFF;
3181 if (isSPACE(datumtype))
3185 else if (*pat == '*') {
3186 len = strend - strbeg; /* long enough */
3189 else if (isDIGIT(*pat)) {
3191 while (isDIGIT(*pat))
3192 len = (len * 10) + (*pat++ - '0');
3195 len = (datumtype != '@');
3198 croak("Invalid type in unpack: '%c'", (int)datumtype);
3199 case ',': /* grandfather in commas but with a warning */
3200 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3201 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3204 if (len == 1 && pat[-1] != '1')
3213 if (len > strend - strbeg)
3214 DIE("@ outside of string");
3218 if (len > s - strbeg)
3219 DIE("X outside of string");
3223 if (len > strend - s)
3224 DIE("x outside of string");
3229 if (len > strend - s)
3232 goto uchar_checksum;
3233 sv = NEWSV(35, len);
3234 sv_setpvn(sv, s, len);
3236 if (datumtype == 'A') {
3237 aptr = s; /* borrow register */
3238 s = SvPVX(sv) + len - 1;
3239 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3242 SvCUR_set(sv, s - SvPVX(sv));
3243 s = aptr; /* unborrow register */
3245 XPUSHs(sv_2mortal(sv));
3249 if (pat[-1] == '*' || len > (strend - s) * 8)
3250 len = (strend - s) * 8;
3253 Newz(601, bitcount, 256, char);
3254 for (bits = 1; bits < 256; bits++) {
3255 if (bits & 1) bitcount[bits]++;
3256 if (bits & 2) bitcount[bits]++;
3257 if (bits & 4) bitcount[bits]++;
3258 if (bits & 8) bitcount[bits]++;
3259 if (bits & 16) bitcount[bits]++;
3260 if (bits & 32) bitcount[bits]++;
3261 if (bits & 64) bitcount[bits]++;
3262 if (bits & 128) bitcount[bits]++;
3266 culong += bitcount[*(unsigned char*)s++];
3271 if (datumtype == 'b') {
3273 if (bits & 1) culong++;
3279 if (bits & 128) culong++;
3286 sv = NEWSV(35, len + 1);
3289 aptr = pat; /* borrow register */
3291 if (datumtype == 'b') {
3293 for (len = 0; len < aint; len++) {
3294 if (len & 7) /*SUPPRESS 595*/
3298 *pat++ = '0' + (bits & 1);
3303 for (len = 0; len < aint; len++) {
3308 *pat++ = '0' + ((bits & 128) != 0);
3312 pat = aptr; /* unborrow register */
3313 XPUSHs(sv_2mortal(sv));
3317 if (pat[-1] == '*' || len > (strend - s) * 2)
3318 len = (strend - s) * 2;
3319 sv = NEWSV(35, len + 1);
3322 aptr = pat; /* borrow register */
3324 if (datumtype == 'h') {
3326 for (len = 0; len < aint; len++) {
3331 *pat++ = PL_hexdigit[bits & 15];
3336 for (len = 0; len < aint; len++) {
3341 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3345 pat = aptr; /* unborrow register */
3346 XPUSHs(sv_2mortal(sv));
3349 if (len > strend - s)
3354 if (aint >= 128) /* fake up signed chars */
3364 if (aint >= 128) /* fake up signed chars */
3367 sv_setiv(sv, (IV)aint);
3368 PUSHs(sv_2mortal(sv));
3373 if (len > strend - s)
3388 sv_setiv(sv, (IV)auint);
3389 PUSHs(sv_2mortal(sv));
3394 if (len > strend - s)
3397 while (len-- > 0 && s < strend) {
3398 auint = utf8_to_uv((U8*)s, &along);
3406 while (len-- > 0 && s < strend) {
3407 auint = utf8_to_uv((U8*)s, &along);
3410 sv_setiv(sv, (IV)auint);
3411 PUSHs(sv_2mortal(sv));
3416 along = (strend - s) / SIZE16;
3433 sv_setiv(sv, (IV)ashort);
3434 PUSHs(sv_2mortal(sv));
3441 along = (strend - s) / SIZE16;
3446 COPY16(s, &aushort);
3449 if (datumtype == 'n')
3450 aushort = PerlSock_ntohs(aushort);
3453 if (datumtype == 'v')
3454 aushort = vtohs(aushort);
3463 COPY16(s, &aushort);
3467 if (datumtype == 'n')
3468 aushort = PerlSock_ntohs(aushort);
3471 if (datumtype == 'v')
3472 aushort = vtohs(aushort);
3474 sv_setiv(sv, (IV)aushort);
3475 PUSHs(sv_2mortal(sv));
3480 along = (strend - s) / sizeof(int);
3485 Copy(s, &aint, 1, int);
3488 cdouble += (double)aint;
3497 Copy(s, &aint, 1, int);
3501 /* Without the dummy below unpack("i", pack("i",-1))
3502 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3503 * cc with optimization turned on */
3505 sv_setiv(sv, (IV)aint) :
3507 sv_setiv(sv, (IV)aint);
3508 PUSHs(sv_2mortal(sv));
3513 along = (strend - s) / sizeof(unsigned int);
3518 Copy(s, &auint, 1, unsigned int);
3519 s += sizeof(unsigned int);
3521 cdouble += (double)auint;
3530 Copy(s, &auint, 1, unsigned int);
3531 s += sizeof(unsigned int);
3533 sv_setuv(sv, (UV)auint);
3534 PUSHs(sv_2mortal(sv));
3539 along = (strend - s) / SIZE32;
3547 cdouble += (double)along;
3559 sv_setiv(sv, (IV)along);
3560 PUSHs(sv_2mortal(sv));
3567 along = (strend - s) / SIZE32;
3575 if (datumtype == 'N')
3576 aulong = PerlSock_ntohl(aulong);
3579 if (datumtype == 'V')
3580 aulong = vtohl(aulong);
3583 cdouble += (double)aulong;
3595 if (datumtype == 'N')
3596 aulong = PerlSock_ntohl(aulong);
3599 if (datumtype == 'V')
3600 aulong = vtohl(aulong);
3603 sv_setuv(sv, (UV)aulong);
3604 PUSHs(sv_2mortal(sv));
3609 along = (strend - s) / sizeof(char*);
3615 if (sizeof(char*) > strend - s)
3618 Copy(s, &aptr, 1, char*);
3624 PUSHs(sv_2mortal(sv));
3634 while ((len > 0) && (s < strend)) {
3635 auv = (auv << 7) | (*s & 0x7f);
3636 if (!(*s++ & 0x80)) {
3640 PUSHs(sv_2mortal(sv));
3644 else if (++bytes >= sizeof(UV)) { /* promote to string */
3647 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3648 while (s < strend) {
3649 sv = mul128(sv, *s & 0x7f);
3650 if (!(*s++ & 0x80)) {
3655 t = SvPV(sv, PL_na);
3659 PUSHs(sv_2mortal(sv));
3664 if ((s >= strend) && bytes)
3665 croak("Unterminated compressed integer");
3670 if (sizeof(char*) > strend - s)
3673 Copy(s, &aptr, 1, char*);
3678 sv_setpvn(sv, aptr, len);
3679 PUSHs(sv_2mortal(sv));
3683 along = (strend - s) / sizeof(Quad_t);
3689 if (s + sizeof(Quad_t) > strend)
3692 Copy(s, &aquad, 1, Quad_t);
3693 s += sizeof(Quad_t);
3696 if (aquad >= IV_MIN && aquad <= IV_MAX)
3697 sv_setiv(sv, (IV)aquad);
3699 sv_setnv(sv, (double)aquad);
3700 PUSHs(sv_2mortal(sv));
3704 along = (strend - s) / sizeof(Quad_t);
3710 if (s + sizeof(unsigned Quad_t) > strend)
3713 Copy(s, &auquad, 1, unsigned Quad_t);
3714 s += sizeof(unsigned Quad_t);
3717 if (auquad <= UV_MAX)
3718 sv_setuv(sv, (UV)auquad);
3720 sv_setnv(sv, (double)auquad);
3721 PUSHs(sv_2mortal(sv));
3725 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3728 along = (strend - s) / sizeof(float);
3733 Copy(s, &afloat, 1, float);
3742 Copy(s, &afloat, 1, float);
3745 sv_setnv(sv, (double)afloat);
3746 PUSHs(sv_2mortal(sv));
3752 along = (strend - s) / sizeof(double);
3757 Copy(s, &adouble, 1, double);
3758 s += sizeof(double);
3766 Copy(s, &adouble, 1, double);
3767 s += sizeof(double);
3769 sv_setnv(sv, (double)adouble);
3770 PUSHs(sv_2mortal(sv));
3776 * Initialise the decode mapping. By using a table driven
3777 * algorithm, the code will be character-set independent
3778 * (and just as fast as doing character arithmetic)
3780 if (uudmap['M'] == 0) {
3783 for (i = 0; i < sizeof(uuemap); i += 1)
3784 uudmap[uuemap[i]] = i;
3786 * Because ' ' and '`' map to the same value,
3787 * we need to decode them both the same.
3792 along = (strend - s) * 3 / 4;
3793 sv = NEWSV(42, along);
3796 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3801 len = (*s++ - ' ') & 077;
3803 if (s < strend && ISUUCHAR(*s))
3804 a = uudmap[*s++] & 077;
3807 if (s < strend && ISUUCHAR(*s))
3808 b = uudmap[*s++] & 077;
3811 if (s < strend && ISUUCHAR(*s))
3812 c = uudmap[*s++] & 077;
3815 if (s < strend && ISUUCHAR(*s))
3816 d = uudmap[*s++] & 077;
3819 hunk[0] = (a << 2) | (b >> 4);
3820 hunk[1] = (b << 4) | (c >> 2);
3821 hunk[2] = (c << 6) | d;
3822 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3827 else if (s[1] == '\n') /* possible checksum byte */
3830 XPUSHs(sv_2mortal(sv));
3835 if (strchr("fFdD", datumtype) ||
3836 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3840 while (checksum >= 16) {
3844 while (checksum >= 4) {
3850 along = (1 << checksum) - 1;
3851 while (cdouble < 0.0)
3853 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3854 sv_setnv(sv, cdouble);
3857 if (checksum < 32) {
3858 aulong = (1 << checksum) - 1;
3861 sv_setuv(sv, (UV)culong);
3863 XPUSHs(sv_2mortal(sv));
3867 if (SP == oldsp && gimme == G_SCALAR)
3868 PUSHs(&PL_sv_undef);
3873 doencodes(register SV *sv, register char *s, register I32 len)
3877 *hunk = uuemap[len];
3878 sv_catpvn(sv, hunk, 1);
3881 hunk[0] = uuemap[(077 & (*s >> 2))];
3882 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3883 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3884 hunk[3] = uuemap[(077 & (s[2] & 077))];
3885 sv_catpvn(sv, hunk, 4);
3890 char r = (len > 1 ? s[1] : '\0');
3891 hunk[0] = uuemap[(077 & (*s >> 2))];
3892 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3893 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3894 hunk[3] = uuemap[0];
3895 sv_catpvn(sv, hunk, 4);
3897 sv_catpvn(sv, "\n", 1);
3901 is_an_int(char *s, STRLEN l)
3903 SV *result = newSVpv("", l);
3904 char *result_c = SvPV(result, PL_na); /* convenience */
3905 char *out = result_c;
3915 SvREFCNT_dec(result);
3938 SvREFCNT_dec(result);
3944 SvCUR_set(result, out - result_c);
3949 div128(SV *pnum, bool *done)
3950 /* must be '\0' terminated */
3954 char *s = SvPV(pnum, len);
3963 i = m * 10 + (*t - '0');
3965 r = (i >> 7); /* r < 10 */
3972 SvCUR_set(pnum, (STRLEN) (t - s));
3979 djSP; dMARK; dORIGMARK; dTARGET;
3980 register SV *cat = TARG;
3983 register char *pat = SvPVx(*++MARK, fromlen);
3984 register char *patend = pat + fromlen;
3989 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3990 static char *space10 = " ";
3992 /* These must not be in registers: */
4001 unsigned Quad_t auquad;
4010 sv_setpvn(cat, "", 0);
4011 while (pat < patend) {
4012 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4013 datumtype = *pat++ & 0xFF;
4014 if (isSPACE(datumtype))
4017 len = strchr("@Xxu", datumtype) ? 0 : items;
4020 else if (isDIGIT(*pat)) {
4022 while (isDIGIT(*pat))
4023 len = (len * 10) + (*pat++ - '0');
4029 croak("Invalid type in pack: '%c'", (int)datumtype);
4030 case ',': /* grandfather in commas but with a warning */
4031 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4032 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4035 DIE("%% may only be used in unpack");
4046 if (SvCUR(cat) < len)
4047 DIE("X outside of string");
4054 sv_catpvn(cat, null10, 10);
4057 sv_catpvn(cat, null10, len);
4062 aptr = SvPV(fromstr, fromlen);
4066 sv_catpvn(cat, aptr, len);
4068 sv_catpvn(cat, aptr, fromlen);
4070 if (datumtype == 'A') {
4072 sv_catpvn(cat, space10, 10);
4075 sv_catpvn(cat, space10, len);
4079 sv_catpvn(cat, null10, 10);
4082 sv_catpvn(cat, null10, len);
4089 char *savepat = pat;
4094 aptr = SvPV(fromstr, fromlen);
4099 SvCUR(cat) += (len+7)/8;
4100 SvGROW(cat, SvCUR(cat) + 1);
4101 aptr = SvPVX(cat) + aint;
4106 if (datumtype == 'B') {
4107 for (len = 0; len++ < aint;) {
4108 items |= *pat++ & 1;
4112 *aptr++ = items & 0xff;
4118 for (len = 0; len++ < aint;) {
4124 *aptr++ = items & 0xff;
4130 if (datumtype == 'B')
4131 items <<= 7 - (aint & 7);
4133 items >>= 7 - (aint & 7);
4134 *aptr++ = items & 0xff;
4136 pat = SvPVX(cat) + SvCUR(cat);
4147 char *savepat = pat;
4152 aptr = SvPV(fromstr, fromlen);
4157 SvCUR(cat) += (len+1)/2;
4158 SvGROW(cat, SvCUR(cat) + 1);
4159 aptr = SvPVX(cat) + aint;
4164 if (datumtype == 'H') {
4165 for (len = 0; len++ < aint;) {
4167 items |= ((*pat++ & 15) + 9) & 15;
4169 items |= *pat++ & 15;
4173 *aptr++ = items & 0xff;
4179 for (len = 0; len++ < aint;) {
4181 items |= (((*pat++ & 15) + 9) & 15) << 4;
4183 items |= (*pat++ & 15) << 4;
4187 *aptr++ = items & 0xff;
4193 *aptr++ = items & 0xff;
4194 pat = SvPVX(cat) + SvCUR(cat);
4206 aint = SvIV(fromstr);
4208 sv_catpvn(cat, &achar, sizeof(char));
4214 auint = SvUV(fromstr);
4215 SvGROW(cat, SvCUR(cat) + 10);
4216 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4221 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4226 afloat = (float)SvNV(fromstr);
4227 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4234 adouble = (double)SvNV(fromstr);
4235 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4241 ashort = (I16)SvIV(fromstr);
4243 ashort = PerlSock_htons(ashort);
4245 CAT16(cat, &ashort);
4251 ashort = (I16)SvIV(fromstr);
4253 ashort = htovs(ashort);
4255 CAT16(cat, &ashort);
4262 ashort = (I16)SvIV(fromstr);
4263 CAT16(cat, &ashort);
4269 auint = SvUV(fromstr);
4270 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4276 adouble = floor(SvNV(fromstr));
4279 croak("Cannot compress negative numbers");
4285 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4286 adouble <= UV_MAX_cxux
4293 char buf[1 + sizeof(UV)];
4294 char *in = buf + sizeof(buf);
4295 UV auv = U_V(adouble);;
4298 *--in = (auv & 0x7f) | 0x80;
4301 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4302 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4304 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4305 char *from, *result, *in;
4310 /* Copy string and check for compliance */
4311 from = SvPV(fromstr, len);
4312 if ((norm = is_an_int(from, len)) == NULL)
4313 croak("can compress only unsigned integer");
4315 New('w', result, len, char);
4319 *--in = div128(norm, &done) | 0x80;
4320 result[len - 1] &= 0x7F; /* clear continue bit */
4321 sv_catpvn(cat, in, (result + len) - in);
4323 SvREFCNT_dec(norm); /* free norm */
4325 else if (SvNOKp(fromstr)) {
4326 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4327 char *in = buf + sizeof(buf);
4330 double next = floor(adouble / 128);
4331 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4332 if (--in < buf) /* this cannot happen ;-) */
4333 croak ("Cannot compress integer");
4335 } while (adouble > 0);
4336 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4337 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4340 croak("Cannot compress non integer");
4346 aint = SvIV(fromstr);
4347 sv_catpvn(cat, (char*)&aint, sizeof(int));
4353 aulong = SvUV(fromstr);
4355 aulong = PerlSock_htonl(aulong);
4357 CAT32(cat, &aulong);
4363 aulong = SvUV(fromstr);
4365 aulong = htovl(aulong);
4367 CAT32(cat, &aulong);
4373 aulong = SvUV(fromstr);
4374 CAT32(cat, &aulong);
4380 along = SvIV(fromstr);
4388 auquad = (unsigned Quad_t)SvIV(fromstr);
4389 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4395 aquad = (Quad_t)SvIV(fromstr);
4396 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4399 #endif /* HAS_QUAD */
4401 len = 1; /* assume SV is correct length */
4406 if (fromstr == &PL_sv_undef)
4409 /* XXX better yet, could spirit away the string to
4410 * a safe spot and hang on to it until the result
4411 * of pack() (and all copies of the result) are
4414 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4416 "Attempt to pack pointer to temporary value");
4417 if (SvPOK(fromstr) || SvNIOK(fromstr))
4418 aptr = SvPV(fromstr,PL_na);
4420 aptr = SvPV_force(fromstr,PL_na);
4422 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4427 aptr = SvPV(fromstr, fromlen);
4428 SvGROW(cat, fromlen * 4 / 3);
4433 while (fromlen > 0) {
4440 doencodes(cat, aptr, todo);
4459 register I32 limit = POPi; /* note, negative is forever */
4462 register char *s = SvPV(sv, len);
4463 char *strend = s + len;
4465 register REGEXP *rx;
4469 I32 maxiters = (strend - s) + 10;
4472 I32 origlimit = limit;
4475 AV *oldstack = PL_curstack;
4476 I32 gimme = GIMME_V;
4477 I32 oldsave = PL_savestack_ix;
4478 I32 make_mortal = 1;
4479 MAGIC *mg = (MAGIC *) NULL;
4482 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4487 DIE("panic: do_split");
4488 rx = pm->op_pmregexp;
4490 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4491 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4493 if (pm->op_pmreplroot)
4494 ary = GvAVn((GV*)pm->op_pmreplroot);
4495 else if (gimme != G_ARRAY)
4497 ary = (AV*)PL_curpad[0];
4499 ary = GvAVn(PL_defgv);
4500 #endif /* USE_THREADS */
4503 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4509 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4516 for (i = AvFILLp(ary); i >= 0; i--)
4517 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4519 /* temporarily switch stacks */
4520 SWITCHSTACK(PL_curstack, ary);
4524 base = SP - PL_stack_base;
4526 if (pm->op_pmflags & PMf_SKIPWHITE) {
4527 if (pm->op_pmflags & PMf_LOCALE) {
4528 while (isSPACE_LC(*s))
4536 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4537 SAVEINT(PL_multiline);
4538 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4542 limit = maxiters + 2;
4543 if (pm->op_pmflags & PMf_WHITE) {
4546 while (m < strend &&
4547 !((pm->op_pmflags & PMf_LOCALE)
4548 ? isSPACE_LC(*m) : isSPACE(*m)))
4553 dstr = NEWSV(30, m-s);
4554 sv_setpvn(dstr, s, m-s);
4560 while (s < strend &&
4561 ((pm->op_pmflags & PMf_LOCALE)
4562 ? isSPACE_LC(*s) : isSPACE(*s)))
4566 else if (strEQ("^", rx->precomp)) {
4569 for (m = s; m < strend && *m != '\n'; m++) ;
4573 dstr = NEWSV(30, m-s);
4574 sv_setpvn(dstr, s, m-s);
4581 else if (rx->check_substr && !rx->nparens
4582 && (rx->reganch & ROPT_CHECK_ALL)
4583 && !(rx->reganch & ROPT_ANCH)) {
4584 i = SvCUR(rx->check_substr);
4585 if (i == 1 && !SvTAIL(rx->check_substr)) {
4586 i = *SvPVX(rx->check_substr);
4589 for (m = s; m < strend && *m != i; m++) ;
4592 dstr = NEWSV(30, m-s);
4593 sv_setpvn(dstr, s, m-s);
4602 while (s < strend && --limit &&
4603 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4604 rx->check_substr, 0)) )
4607 dstr = NEWSV(31, m-s);
4608 sv_setpvn(dstr, s, m-s);
4617 maxiters += (strend - s) * rx->nparens;
4618 while (s < strend && --limit &&
4619 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4621 TAINT_IF(RX_MATCH_TAINTED(rx));
4623 && rx->subbase != orig) {
4628 strend = s + (strend - m);
4631 dstr = NEWSV(32, m-s);
4632 sv_setpvn(dstr, s, m-s);
4637 for (i = 1; i <= rx->nparens; i++) {
4641 dstr = NEWSV(33, m-s);
4642 sv_setpvn(dstr, s, m-s);
4645 dstr = NEWSV(33, 0);
4655 LEAVE_SCOPE(oldsave);
4656 iters = (SP - PL_stack_base) - base;
4657 if (iters > maxiters)
4660 /* keep field after final delim? */
4661 if (s < strend || (iters && origlimit)) {
4662 dstr = NEWSV(34, strend-s);
4663 sv_setpvn(dstr, s, strend-s);
4669 else if (!origlimit) {
4670 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4676 SWITCHSTACK(ary, oldstack);
4677 if (SvSMAGICAL(ary)) {
4682 if (gimme == G_ARRAY) {
4684 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4692 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4695 if (gimme == G_ARRAY) {
4696 /* EXTEND should not be needed - we just popped them */
4698 for (i=0; i < iters; i++) {
4699 SV **svp = av_fetch(ary, i, FALSE);
4700 PUSHs((svp) ? *svp : &PL_sv_undef);
4707 if (gimme == G_ARRAY)
4710 if (iters || !pm->op_pmreplroot) {
4720 unlock_condpair(void *svv)
4723 MAGIC *mg = mg_find((SV*)svv, 'm');
4726 croak("panic: unlock_condpair unlocking non-mutex");
4727 MUTEX_LOCK(MgMUTEXP(mg));
4728 if (MgOWNER(mg) != thr)
4729 croak("panic: unlock_condpair unlocking mutex that we don't own");
4731 COND_SIGNAL(MgOWNERCONDP(mg));
4732 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4733 (unsigned long)thr, (unsigned long)svv);)
4734 MUTEX_UNLOCK(MgMUTEXP(mg));
4736 #endif /* USE_THREADS */
4749 mg = condpair_magic(sv);
4750 MUTEX_LOCK(MgMUTEXP(mg));
4751 if (MgOWNER(mg) == thr)
4752 MUTEX_UNLOCK(MgMUTEXP(mg));
4755 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4757 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4758 (unsigned long)thr, (unsigned long)sv);)
4759 MUTEX_UNLOCK(MgMUTEXP(mg));
4760 SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
4761 save_destructor(unlock_condpair, sv);
4763 #endif /* USE_THREADS */
4764 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4765 || SvTYPE(retsv) == SVt_PVCV) {
4766 retsv = refto(retsv);
4777 if (PL_op->op_private & OPpLVAL_INTRO)
4778 PUSHs(*save_threadsv(PL_op->op_targ));
4780 PUSHs(THREADSV(PL_op->op_targ));
4783 DIE("tried to access per-thread data in non-threaded perl");
4784 #endif /* USE_THREADS */