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__);
214 tryAMAGICunDEREF(to_gv);
217 if (SvTYPE(sv) == SVt_PVIO) {
218 GV *gv = (GV*) sv_newmortal();
219 gv_init(gv, 0, "", 0, 0);
220 GvIOp(gv) = (IO *)sv;
221 (void)SvREFCNT_inc(sv);
223 } else if (SvTYPE(sv) != SVt_PVGV)
224 DIE("Not a GLOB reference");
227 if (SvTYPE(sv) != SVt_PVGV) {
230 if (SvGMAGICAL(sv)) {
236 if (PL_op->op_flags & OPf_REF ||
237 PL_op->op_private & HINT_STRICT_REFS)
238 DIE(PL_no_usym, "a symbol");
239 if (ckWARN(WARN_UNINITIALIZED))
240 warner(WARN_UNINITIALIZED, PL_warn_uninit);
243 sym = SvPV(sv, PL_na);
244 if (PL_op->op_private & HINT_STRICT_REFS)
245 DIE(PL_no_symref, sym, "a symbol");
246 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
249 if (PL_op->op_private & OPpLVAL_INTRO)
250 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
261 tryAMAGICunDEREF(to_sv);
264 switch (SvTYPE(sv)) {
268 DIE("Not a SCALAR reference");
275 if (SvTYPE(gv) != SVt_PVGV) {
276 if (SvGMAGICAL(sv)) {
282 if (PL_op->op_flags & OPf_REF ||
283 PL_op->op_private & HINT_STRICT_REFS)
284 DIE(PL_no_usym, "a SCALAR");
285 if (ckWARN(WARN_UNINITIALIZED))
286 warner(WARN_UNINITIALIZED, PL_warn_uninit);
289 sym = SvPV(sv, PL_na);
290 if (PL_op->op_private & HINT_STRICT_REFS)
291 DIE(PL_no_symref, sym, "a SCALAR");
292 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
296 if (PL_op->op_flags & OPf_MOD) {
297 if (PL_op->op_private & OPpLVAL_INTRO)
298 sv = save_scalar((GV*)TOPs);
299 else if (PL_op->op_private & OPpDEREF)
300 vivify_ref(sv, PL_op->op_private & OPpDEREF);
310 SV *sv = AvARYLEN(av);
312 AvARYLEN(av) = sv = NEWSV(0,0);
313 sv_upgrade(sv, SVt_IV);
314 sv_magic(sv, (SV*)av, '#', Nullch, 0);
322 djSP; dTARGET; dPOPss;
324 if (PL_op->op_flags & OPf_MOD) {
325 if (SvTYPE(TARG) < SVt_PVLV) {
326 sv_upgrade(TARG, SVt_PVLV);
327 sv_magic(TARG, Nullsv, '.', Nullch, 0);
331 if (LvTARG(TARG) != sv) {
333 SvREFCNT_dec(LvTARG(TARG));
334 LvTARG(TARG) = SvREFCNT_inc(sv);
336 PUSHs(TARG); /* no SvSETMAGIC */
342 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
343 mg = mg_find(sv, 'g');
344 if (mg && mg->mg_len >= 0) {
348 PUSHi(i + PL_curcop->cop_arybase);
362 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
363 /* (But not in defined().) */
364 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
367 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
370 cv = (CV*)&PL_sv_undef;
384 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
385 char *s = SvPVX(TOPs);
386 if (strnEQ(s, "CORE::", 6)) {
389 code = keyword(s + 6, SvCUR(TOPs) - 6);
390 if (code < 0) { /* Overridable. */
391 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
392 int i = 0, n = 0, seen_question = 0;
394 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
396 while (i < MAXO) { /* The slow way. */
397 if (strEQ(s + 6, PL_op_name[i])
398 || strEQ(s + 6, PL_op_desc[i]))
404 goto nonesuch; /* Should not happen... */
406 oa = PL_opargs[i] >> OASHIFT;
408 if (oa & OA_OPTIONAL) {
411 } else if (seen_question)
412 goto set; /* XXXX system, exec */
413 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
414 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
417 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
418 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
422 ret = sv_2mortal(newSVpv(str, n - 1));
423 } else if (code) /* Non-Overridable */
425 else { /* None such */
427 croak("Cannot find an opnumber for \"%s\"", s+6);
431 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
433 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
442 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
444 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
460 if (GIMME != G_ARRAY) {
464 *MARK = &PL_sv_undef;
465 *MARK = refto(*MARK);
469 EXTEND_MORTAL(SP - MARK);
471 *MARK = refto(*MARK);
480 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
483 if (!(sv = LvTARG(sv)))
486 else if (SvPADTMP(sv))
490 (void)SvREFCNT_inc(sv);
493 sv_upgrade(rv, SVt_RV);
507 if (sv && SvGMAGICAL(sv))
510 if (!sv || !SvROK(sv))
514 pv = sv_reftype(sv,TRUE);
515 PUSHp(pv, strlen(pv));
525 stash = PL_curcop->cop_stash;
529 char *ptr = SvPV(ssv,len);
530 if (ckWARN(WARN_UNSAFE) && len == 0)
532 "Explicit blessing to '' (assuming package main)");
533 stash = gv_stashpvn(ptr, len, TRUE);
536 (void)sv_bless(TOPs, stash);
549 elem = SvPV(sv, PL_na);
553 switch (elem ? *elem : '\0')
556 if (strEQ(elem, "ARRAY"))
557 tmpRef = (SV*)GvAV(gv);
560 if (strEQ(elem, "CODE"))
561 tmpRef = (SV*)GvCVu(gv);
564 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
565 tmpRef = (SV*)GvIOp(gv);
568 if (strEQ(elem, "GLOB"))
572 if (strEQ(elem, "HASH"))
573 tmpRef = (SV*)GvHV(gv);
576 if (strEQ(elem, "IO"))
577 tmpRef = (SV*)GvIOp(gv);
580 if (strEQ(elem, "NAME"))
581 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
584 if (strEQ(elem, "PACKAGE"))
585 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
588 if (strEQ(elem, "SCALAR"))
602 /* Pattern matching */
607 register UNOP *unop = cUNOP;
608 register unsigned char *s;
611 register I32 *sfirst;
615 if (sv == PL_lastscream) {
621 SvSCREAM_off(PL_lastscream);
622 SvREFCNT_dec(PL_lastscream);
624 PL_lastscream = SvREFCNT_inc(sv);
627 s = (unsigned char*)(SvPV(sv, len));
631 if (pos > PL_maxscream) {
632 if (PL_maxscream < 0) {
633 PL_maxscream = pos + 80;
634 New(301, PL_screamfirst, 256, I32);
635 New(302, PL_screamnext, PL_maxscream, I32);
638 PL_maxscream = pos + pos / 4;
639 Renew(PL_screamnext, PL_maxscream, I32);
643 sfirst = PL_screamfirst;
644 snext = PL_screamnext;
646 if (!sfirst || !snext)
647 DIE("do_study: out of memory");
649 for (ch = 256; ch; --ch)
656 snext[pos] = sfirst[ch] - pos;
663 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
672 if (PL_op->op_flags & OPf_STACKED)
678 TARG = sv_newmortal();
683 /* Lvalue operators. */
695 djSP; dMARK; dTARGET;
705 SETi(do_chomp(TOPs));
711 djSP; dMARK; dTARGET;
712 register I32 count = 0;
715 count += do_chomp(POPs);
726 if (!sv || !SvANY(sv))
728 switch (SvTYPE(sv)) {
730 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
734 if (HvARRAY(sv) || SvGMAGICAL(sv))
738 if (CvROOT(sv) || CvXSUB(sv))
755 if (!PL_op->op_private) {
764 if (SvTHINKFIRST(sv)) {
771 switch (SvTYPE(sv)) {
781 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
782 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
783 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
786 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
788 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
792 SvSetMagicSV(sv, &PL_sv_undef);
796 Newz(602, gp, 1, GP);
797 GvGP(sv) = gp_ref(gp);
798 GvSV(sv) = NEWSV(72,0);
799 GvLINE(sv) = PL_curcop->cop_line;
805 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
808 SvPV_set(sv, Nullch);
821 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
823 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
824 SvIVX(TOPs) != IV_MIN)
827 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
838 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
840 sv_setsv(TARG, TOPs);
841 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
842 SvIVX(TOPs) != IV_MAX)
845 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
859 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
861 sv_setsv(TARG, TOPs);
862 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
863 SvIVX(TOPs) != IV_MIN)
866 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
875 /* Ordinary operators. */
879 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
882 SETn( pow( left, right) );
889 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
892 SETn( left * right );
899 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
904 DIE("Illegal division by zero");
906 /* insure that 20./5. == 4. */
909 if ((double)I_V(left) == left &&
910 (double)I_V(right) == right &&
911 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
914 value = left / right;
918 value = left / right;
927 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
935 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
937 right = (right_neg = (i < 0)) ? -i : i;
941 right = U_V((right_neg = (n < 0)) ? -n : n);
944 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
946 left = (left_neg = (i < 0)) ? -i : i;
950 left = U_V((left_neg = (n < 0)) ? -n : n);
954 DIE("Illegal modulus zero");
957 if ((left_neg != right_neg) && ans)
960 /* XXX may warn: unary minus operator applied to unsigned type */
961 /* could change -foo to be (~foo)+1 instead */
962 if (ans <= ~((UV)IV_MAX)+1)
963 sv_setiv(TARG, ~ans+1);
965 sv_setnv(TARG, -(double)ans);
976 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
978 register I32 count = POPi;
979 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
981 I32 items = SP - MARK;
993 repeatcpy((char*)(MARK + items), (char*)MARK,
994 items * sizeof(SV*), count - 1);
1000 else { /* Note: mark already snarfed by pp_list */
1005 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1006 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1007 DIE("Can't x= to readonly value");
1011 SvSetSV(TARG, tmpstr);
1012 SvPV_force(TARG, len);
1017 SvGROW(TARG, (count * len) + 1);
1018 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1019 SvCUR(TARG) *= count;
1021 *SvEND(TARG) = '\0';
1023 (void)SvPOK_only(TARG);
1032 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1035 SETn( left - right );
1042 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1045 if (PL_op->op_private & HINT_INTEGER) {
1047 i = BWi(i) << shift;
1061 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1064 if (PL_op->op_private & HINT_INTEGER) {
1066 i = BWi(i) >> shift;
1080 djSP; tryAMAGICbinSET(lt,0);
1083 SETs(boolSV(TOPn < value));
1090 djSP; tryAMAGICbinSET(gt,0);
1093 SETs(boolSV(TOPn > value));
1100 djSP; tryAMAGICbinSET(le,0);
1103 SETs(boolSV(TOPn <= value));
1110 djSP; tryAMAGICbinSET(ge,0);
1113 SETs(boolSV(TOPn >= value));
1120 djSP; tryAMAGICbinSET(ne,0);
1123 SETs(boolSV(TOPn != value));
1130 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1137 else if (left < right)
1139 else if (left > right)
1152 djSP; tryAMAGICbinSET(slt,0);
1155 int cmp = ((PL_op->op_private & OPpLOCALE)
1156 ? sv_cmp_locale(left, right)
1157 : sv_cmp(left, right));
1158 SETs(boolSV(cmp < 0));
1165 djSP; tryAMAGICbinSET(sgt,0);
1168 int cmp = ((PL_op->op_private & OPpLOCALE)
1169 ? sv_cmp_locale(left, right)
1170 : sv_cmp(left, right));
1171 SETs(boolSV(cmp > 0));
1178 djSP; tryAMAGICbinSET(sle,0);
1181 int cmp = ((PL_op->op_private & OPpLOCALE)
1182 ? sv_cmp_locale(left, right)
1183 : sv_cmp(left, right));
1184 SETs(boolSV(cmp <= 0));
1191 djSP; tryAMAGICbinSET(sge,0);
1194 int cmp = ((PL_op->op_private & OPpLOCALE)
1195 ? sv_cmp_locale(left, right)
1196 : sv_cmp(left, right));
1197 SETs(boolSV(cmp >= 0));
1204 djSP; tryAMAGICbinSET(seq,0);
1207 SETs(boolSV(sv_eq(left, right)));
1214 djSP; tryAMAGICbinSET(sne,0);
1217 SETs(boolSV(!sv_eq(left, right)));
1224 djSP; dTARGET; tryAMAGICbin(scmp,0);
1227 int cmp = ((PL_op->op_private & OPpLOCALE)
1228 ? sv_cmp_locale(left, right)
1229 : sv_cmp(left, right));
1237 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1240 if (SvNIOKp(left) || SvNIOKp(right)) {
1241 if (PL_op->op_private & HINT_INTEGER) {
1242 IBW value = SvIV(left) & SvIV(right);
1246 UBW value = SvUV(left) & SvUV(right);
1251 do_vop(PL_op->op_type, TARG, left, right);
1260 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1263 if (SvNIOKp(left) || SvNIOKp(right)) {
1264 if (PL_op->op_private & HINT_INTEGER) {
1265 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1269 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1274 do_vop(PL_op->op_type, TARG, left, right);
1283 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1286 if (SvNIOKp(left) || SvNIOKp(right)) {
1287 if (PL_op->op_private & HINT_INTEGER) {
1288 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1292 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1297 do_vop(PL_op->op_type, TARG, left, right);
1306 djSP; dTARGET; tryAMAGICun(neg);
1311 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1313 else if (SvNIOKp(sv))
1315 else if (SvPOKp(sv)) {
1317 char *s = SvPV(sv, len);
1318 if (isIDFIRST(*s)) {
1319 sv_setpvn(TARG, "-", 1);
1322 else if (*s == '+' || *s == '-') {
1324 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1326 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1327 sv_setpvn(TARG, "-", 1);
1331 sv_setnv(TARG, -SvNV(sv));
1343 djSP; tryAMAGICunSET(not);
1344 #endif /* OVERLOAD */
1345 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1351 djSP; dTARGET; tryAMAGICun(compl);
1355 if (PL_op->op_private & HINT_INTEGER) {
1356 IBW value = ~SvIV(sv);
1360 UBW value = ~SvUV(sv);
1365 register char *tmps;
1366 register long *tmpl;
1371 tmps = SvPV_force(TARG, len);
1374 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1377 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1381 for ( ; anum > 0; anum--, tmps++)
1390 /* integer versions of some of the above */
1394 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1397 SETi( left * right );
1404 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1408 DIE("Illegal division by zero");
1409 value = POPi / value;
1417 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1421 DIE("Illegal modulus zero");
1422 SETi( left % right );
1429 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1432 SETi( left + right );
1439 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1442 SETi( left - right );
1449 djSP; tryAMAGICbinSET(lt,0);
1452 SETs(boolSV(left < right));
1459 djSP; tryAMAGICbinSET(gt,0);
1462 SETs(boolSV(left > right));
1469 djSP; tryAMAGICbinSET(le,0);
1472 SETs(boolSV(left <= right));
1479 djSP; tryAMAGICbinSET(ge,0);
1482 SETs(boolSV(left >= right));
1489 djSP; tryAMAGICbinSET(eq,0);
1492 SETs(boolSV(left == right));
1499 djSP; tryAMAGICbinSET(ne,0);
1502 SETs(boolSV(left != right));
1509 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1516 else if (left < right)
1527 djSP; dTARGET; tryAMAGICun(neg);
1532 /* High falutin' math. */
1536 djSP; dTARGET; tryAMAGICbin(atan2,0);
1539 SETn(atan2(left, right));
1546 djSP; dTARGET; tryAMAGICun(sin);
1558 djSP; dTARGET; tryAMAGICun(cos);
1568 /* Support Configure command-line overrides for rand() functions.
1569 After 5.005, perhaps we should replace this by Configure support
1570 for drand48(), random(), or rand(). For 5.005, though, maintain
1571 compatibility by calling rand() but allow the user to override it.
1572 See INSTALL for details. --Andy Dougherty 15 July 1998
1574 /* Now it's after 5.005, and Configure supports drand48() and random(),
1575 in addition to rand(). So the overrides should not be needed any more.
1576 --Jarkko Hietaniemi 27 September 1998
1579 #ifndef HAS_DRAND48_PROTO
1580 extern double drand48 _((void));
1593 if (!srand_called) {
1594 (void)seedDrand01((Rand_seed_t)seed());
1595 srand_called = TRUE;
1610 (void)seedDrand01((Rand_seed_t)anum);
1611 srand_called = TRUE;
1620 * This is really just a quick hack which grabs various garbage
1621 * values. It really should be a real hash algorithm which
1622 * spreads the effect of every input bit onto every output bit,
1623 * if someone who knows about such things would bother to write it.
1624 * Might be a good idea to add that function to CORE as well.
1625 * No numbers below come from careful analysis or anything here,
1626 * except they are primes and SEED_C1 > 1E6 to get a full-width
1627 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1628 * probably be bigger too.
1631 # define SEED_C1 1000003
1632 #define SEED_C4 73819
1634 # define SEED_C1 25747
1635 #define SEED_C4 20639
1639 #define SEED_C5 26107
1642 #ifndef PERL_NO_DEV_RANDOM
1647 # include <starlet.h>
1648 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1649 * in 100-ns units, typically incremented ever 10 ms. */
1650 unsigned int when[2];
1652 # ifdef HAS_GETTIMEOFDAY
1653 struct timeval when;
1659 /* This test is an escape hatch, this symbol isn't set by Configure. */
1660 #ifndef PERL_NO_DEV_RANDOM
1661 #ifndef PERL_RANDOM_DEVICE
1662 /* /dev/random isn't used by default because reads from it will block
1663 * if there isn't enough entropy available. You can compile with
1664 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1665 * is enough real entropy to fill the seed. */
1666 # define PERL_RANDOM_DEVICE "/dev/urandom"
1668 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1670 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1679 _ckvmssts(sys$gettim(when));
1680 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1682 # ifdef HAS_GETTIMEOFDAY
1683 gettimeofday(&when,(struct timezone *) 0);
1684 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1687 u = (U32)SEED_C1 * when;
1690 u += SEED_C3 * (U32)getpid();
1691 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1692 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1693 u += SEED_C5 * (U32)(UV)&when;
1700 djSP; dTARGET; tryAMAGICun(exp);
1712 djSP; dTARGET; tryAMAGICun(log);
1717 SET_NUMERIC_STANDARD();
1718 DIE("Can't take log of %g", value);
1728 djSP; dTARGET; tryAMAGICun(sqrt);
1733 SET_NUMERIC_STANDARD();
1734 DIE("Can't take sqrt of %g", value);
1736 value = sqrt(value);
1746 double value = TOPn;
1749 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1755 (void)modf(value, &value);
1757 (void)modf(-value, &value);
1772 djSP; dTARGET; tryAMAGICun(abs);
1774 double value = TOPn;
1777 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1778 (iv = SvIVX(TOPs)) != IV_MIN) {
1799 XPUSHu(scan_hex(tmps, 99, &argtype));
1811 while (*tmps && isSPACE(*tmps))
1816 value = scan_hex(++tmps, 99, &argtype);
1818 value = scan_oct(tmps, 99, &argtype);
1830 SETi( sv_len_utf8(TOPs) );
1834 SETi( sv_len(TOPs) );
1848 I32 lvalue = PL_op->op_flags & OPf_MOD;
1850 I32 arybase = PL_curcop->cop_arybase;
1854 SvTAINTED_off(TARG); /* decontaminate */
1858 repl = SvPV(sv, repl_len);
1865 tmps = SvPV(sv, curlen);
1867 utfcurlen = sv_len_utf8(sv);
1868 if (utfcurlen == curlen)
1876 if (pos >= arybase) {
1894 else if (len >= 0) {
1896 if (rem > (I32)curlen)
1910 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1911 warner(WARN_SUBSTR, "substr outside of string");
1916 sv_pos_u2b(sv, &pos, &rem);
1918 sv_setpvn(TARG, tmps, rem);
1919 if (lvalue) { /* it's an lvalue! */
1920 if (!SvGMAGICAL(sv)) {
1922 SvPV_force(sv,PL_na);
1923 if (ckWARN(WARN_SUBSTR))
1925 "Attempt to use reference as lvalue in substr");
1927 if (SvOK(sv)) /* is it defined ? */
1928 (void)SvPOK_only(sv);
1930 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1933 if (SvTYPE(TARG) < SVt_PVLV) {
1934 sv_upgrade(TARG, SVt_PVLV);
1935 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1939 if (LvTARG(TARG) != sv) {
1941 SvREFCNT_dec(LvTARG(TARG));
1942 LvTARG(TARG) = SvREFCNT_inc(sv);
1944 LvTARGOFF(TARG) = pos;
1945 LvTARGLEN(TARG) = rem;
1948 sv_insert(sv, pos, rem, repl, repl_len);
1951 PUSHs(TARG); /* avoid SvSETMAGIC here */
1958 register I32 size = POPi;
1959 register I32 offset = POPi;
1960 register SV *src = POPs;
1961 I32 lvalue = PL_op->op_flags & OPf_MOD;
1963 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1964 unsigned long retnum;
1967 SvTAINTED_off(TARG); /* decontaminate */
1968 offset *= size; /* turn into bit offset */
1969 len = (offset + size + 7) / 8;
1970 if (offset < 0 || size < 1)
1973 if (lvalue) { /* it's an lvalue! */
1974 if (SvTYPE(TARG) < SVt_PVLV) {
1975 sv_upgrade(TARG, SVt_PVLV);
1976 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1980 if (LvTARG(TARG) != src) {
1982 SvREFCNT_dec(LvTARG(TARG));
1983 LvTARG(TARG) = SvREFCNT_inc(src);
1985 LvTARGOFF(TARG) = offset;
1986 LvTARGLEN(TARG) = size;
1994 if (offset >= srclen)
1997 retnum = (unsigned long) s[offset] << 8;
1999 else if (size == 32) {
2000 if (offset >= srclen)
2002 else if (offset + 1 >= srclen)
2003 retnum = (unsigned long) s[offset] << 24;
2004 else if (offset + 2 >= srclen)
2005 retnum = ((unsigned long) s[offset] << 24) +
2006 ((unsigned long) s[offset + 1] << 16);
2008 retnum = ((unsigned long) s[offset] << 24) +
2009 ((unsigned long) s[offset + 1] << 16) +
2010 (s[offset + 2] << 8);
2015 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2020 else if (size == 16)
2021 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2022 else if (size == 32)
2023 retnum = ((unsigned long) s[offset] << 24) +
2024 ((unsigned long) s[offset + 1] << 16) +
2025 (s[offset + 2] << 8) + s[offset+3];
2029 sv_setuv(TARG, (UV)retnum);
2044 I32 arybase = PL_curcop->cop_arybase;
2049 offset = POPi - arybase;
2052 tmps = SvPV(big, biglen);
2053 if (IN_UTF8 && offset > 0)
2054 sv_pos_u2b(big, &offset, 0);
2057 else if (offset > biglen)
2059 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2060 (unsigned char*)tmps + biglen, little, 0)))
2063 retval = tmps2 - tmps;
2064 if (IN_UTF8 && retval > 0)
2065 sv_pos_b2u(big, &retval);
2066 PUSHi(retval + arybase);
2081 I32 arybase = PL_curcop->cop_arybase;
2087 tmps2 = SvPV(little, llen);
2088 tmps = SvPV(big, blen);
2092 if (IN_UTF8 && offset > 0)
2093 sv_pos_u2b(big, &offset, 0);
2094 offset = offset - arybase + llen;
2098 else if (offset > blen)
2100 if (!(tmps2 = rninstr(tmps, tmps + offset,
2101 tmps2, tmps2 + llen)))
2104 retval = tmps2 - tmps;
2105 if (IN_UTF8 && retval > 0)
2106 sv_pos_b2u(big, &retval);
2107 PUSHi(retval + arybase);
2113 djSP; dMARK; dORIGMARK; dTARGET;
2114 #ifdef USE_LOCALE_NUMERIC
2115 if (PL_op->op_private & OPpLOCALE)
2116 SET_NUMERIC_LOCAL();
2118 SET_NUMERIC_STANDARD();
2120 do_sprintf(TARG, SP-MARK, MARK+1);
2121 TAINT_IF(SvTAINTED(TARG));
2131 U8 *tmps = (U8*)POPp;
2134 if (IN_UTF8 && (*tmps & 0x80))
2135 value = utf8_to_uv(tmps, &retlen);
2137 value = (UV)(*tmps & 255);
2148 (void)SvUPGRADE(TARG,SVt_PV);
2150 if (IN_UTF8 && value >= 128) {
2153 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2154 SvCUR_set(TARG, tmps - SvPVX(TARG));
2156 (void)SvPOK_only(TARG);
2166 (void)SvPOK_only(TARG);
2173 djSP; dTARGET; dPOPTOPssrl;
2175 char *tmps = SvPV(left, PL_na);
2177 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2179 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2183 "The crypt() function is unimplemented due to excessive paranoia.");
2196 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2200 UV uv = utf8_to_uv(s, &ulen);
2202 if (PL_op->op_private & OPpLOCALE) {
2205 uv = toTITLE_LC_uni(uv);
2208 uv = toTITLE_utf8(s);
2210 tend = uv_to_utf8(tmpbuf, uv);
2212 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2214 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2215 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2219 s = (U8*)SvPV_force(sv, slen);
2220 Copy(tmpbuf, s, ulen, U8);
2225 if (!SvPADTMP(sv)) {
2231 s = (U8*)SvPV_force(sv, PL_na);
2233 if (PL_op->op_private & OPpLOCALE) {
2236 *s = toUPPER_LC(*s);
2252 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2256 UV uv = utf8_to_uv(s, &ulen);
2258 if (PL_op->op_private & OPpLOCALE) {
2261 uv = toLOWER_LC_uni(uv);
2264 uv = toLOWER_utf8(s);
2266 tend = uv_to_utf8(tmpbuf, uv);
2268 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2270 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2271 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2275 s = (U8*)SvPV_force(sv, slen);
2276 Copy(tmpbuf, s, ulen, U8);
2281 if (!SvPADTMP(sv)) {
2287 s = (U8*)SvPV_force(sv, PL_na);
2289 if (PL_op->op_private & OPpLOCALE) {
2292 *s = toLOWER_LC(*s);
2315 s = (U8*)SvPV(sv,len);
2317 sv_setpvn(TARG, "", 0);
2322 (void)SvUPGRADE(TARG, SVt_PV);
2323 SvGROW(TARG, (len * 2) + 1);
2324 (void)SvPOK_only(TARG);
2325 d = (U8*)SvPVX(TARG);
2327 if (PL_op->op_private & OPpLOCALE) {
2331 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2337 d = uv_to_utf8(d, toUPPER_utf8( s ));
2342 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2347 if (!SvPADTMP(sv)) {
2354 s = (U8*)SvPV_force(sv, len);
2356 register U8 *send = s + len;
2358 if (PL_op->op_private & OPpLOCALE) {
2361 for (; s < send; s++)
2362 *s = toUPPER_LC(*s);
2365 for (; s < send; s++)
2385 s = (U8*)SvPV(sv,len);
2387 sv_setpvn(TARG, "", 0);
2392 (void)SvUPGRADE(TARG, SVt_PV);
2393 SvGROW(TARG, (len * 2) + 1);
2394 (void)SvPOK_only(TARG);
2395 d = (U8*)SvPVX(TARG);
2397 if (PL_op->op_private & OPpLOCALE) {
2401 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2407 d = uv_to_utf8(d, toLOWER_utf8(s));
2412 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2417 if (!SvPADTMP(sv)) {
2424 s = (U8*)SvPV_force(sv, len);
2426 register U8 *send = s + len;
2428 if (PL_op->op_private & OPpLOCALE) {
2431 for (; s < send; s++)
2432 *s = toLOWER_LC(*s);
2435 for (; s < send; s++)
2447 register char *s = SvPV(sv,len);
2451 (void)SvUPGRADE(TARG, SVt_PV);
2452 SvGROW(TARG, (len * 2) + 1);
2457 STRLEN ulen = UTF8SKIP(s);
2480 SvCUR_set(TARG, d - SvPVX(TARG));
2481 (void)SvPOK_only(TARG);
2484 sv_setpvn(TARG, s, len);
2493 djSP; dMARK; dORIGMARK;
2495 register AV* av = (AV*)POPs;
2496 register I32 lval = PL_op->op_flags & OPf_MOD;
2497 I32 arybase = PL_curcop->cop_arybase;
2500 if (SvTYPE(av) == SVt_PVAV) {
2501 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2503 for (svp = MARK + 1; svp <= SP; svp++) {
2508 if (max > AvMAX(av))
2511 while (++MARK <= SP) {
2512 elem = SvIVx(*MARK);
2516 svp = av_fetch(av, elem, lval);
2518 if (!svp || *svp == &PL_sv_undef)
2519 DIE(PL_no_aelem, elem);
2520 if (PL_op->op_private & OPpLVAL_INTRO)
2521 save_aelem(av, elem, svp);
2523 *MARK = svp ? *svp : &PL_sv_undef;
2526 if (GIMME != G_ARRAY) {
2534 /* Associative arrays. */
2539 HV *hash = (HV*)POPs;
2541 I32 gimme = GIMME_V;
2542 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2545 /* might clobber stack_sp */
2546 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2551 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2552 if (gimme == G_ARRAY) {
2554 /* might clobber stack_sp */
2555 sv_setsv(TARG, realhv ?
2556 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2561 else if (gimme == G_SCALAR)
2580 I32 gimme = GIMME_V;
2581 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2585 if (PL_op->op_private & OPpSLICE) {
2589 hvtype = SvTYPE(hv);
2590 while (++MARK <= SP) {
2591 if (hvtype == SVt_PVHV)
2592 sv = hv_delete_ent(hv, *MARK, discard, 0);
2594 DIE("Not a HASH reference");
2595 *MARK = sv ? sv : &PL_sv_undef;
2599 else if (gimme == G_SCALAR) {
2608 if (SvTYPE(hv) == SVt_PVHV)
2609 sv = hv_delete_ent(hv, keysv, discard, 0);
2611 DIE("Not a HASH reference");
2625 if (SvTYPE(hv) == SVt_PVHV) {
2626 if (hv_exists_ent(hv, tmpsv, 0))
2628 } else if (SvTYPE(hv) == SVt_PVAV) {
2629 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2632 DIE("Not a HASH reference");
2639 djSP; dMARK; dORIGMARK;
2640 register HV *hv = (HV*)POPs;
2641 register I32 lval = PL_op->op_flags & OPf_MOD;
2642 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2644 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2645 DIE("Can't localize pseudo-hash element");
2647 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2648 while (++MARK <= SP) {
2652 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2653 svp = he ? &HeVAL(he) : 0;
2655 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2658 if (!svp || *svp == &PL_sv_undef)
2659 DIE(PL_no_helem, SvPV(keysv, PL_na));
2660 if (PL_op->op_private & OPpLVAL_INTRO)
2661 save_helem(hv, keysv, svp);
2663 *MARK = svp ? *svp : &PL_sv_undef;
2666 if (GIMME != G_ARRAY) {
2674 /* List operators. */
2679 if (GIMME != G_ARRAY) {
2681 *MARK = *SP; /* unwanted list, return last item */
2683 *MARK = &PL_sv_undef;
2692 SV **lastrelem = PL_stack_sp;
2693 SV **lastlelem = PL_stack_base + POPMARK;
2694 SV **firstlelem = PL_stack_base + POPMARK + 1;
2695 register SV **firstrelem = lastlelem + 1;
2696 I32 arybase = PL_curcop->cop_arybase;
2697 I32 lval = PL_op->op_flags & OPf_MOD;
2698 I32 is_something_there = lval;
2700 register I32 max = lastrelem - lastlelem;
2701 register SV **lelem;
2704 if (GIMME != G_ARRAY) {
2705 ix = SvIVx(*lastlelem);
2710 if (ix < 0 || ix >= max)
2711 *firstlelem = &PL_sv_undef;
2713 *firstlelem = firstrelem[ix];
2719 SP = firstlelem - 1;
2723 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2728 *lelem = &PL_sv_undef;
2729 else if (!(*lelem = firstrelem[ix]))
2730 *lelem = &PL_sv_undef;
2734 if (ix >= max || !(*lelem = firstrelem[ix]))
2735 *lelem = &PL_sv_undef;
2737 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2738 is_something_there = TRUE;
2740 if (is_something_there)
2743 SP = firstlelem - 1;
2749 djSP; dMARK; dORIGMARK;
2750 I32 items = SP - MARK;
2751 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2752 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2759 djSP; dMARK; dORIGMARK;
2760 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2764 SV *val = NEWSV(46, 0);
2766 sv_setsv(val, *++MARK);
2767 else if (ckWARN(WARN_UNSAFE))
2768 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2769 (void)hv_store_ent(hv,key,val,0);
2778 djSP; dMARK; dORIGMARK;
2779 register AV *ary = (AV*)*++MARK;
2783 register I32 offset;
2784 register I32 length;
2791 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2792 *MARK-- = SvTIED_obj((SV*)ary, mg);
2796 perl_call_method("SPLICE",GIMME_V);
2805 offset = i = SvIVx(*MARK);
2807 offset += AvFILLp(ary) + 1;
2809 offset -= PL_curcop->cop_arybase;
2811 DIE(PL_no_aelem, i);
2813 length = SvIVx(*MARK++);
2815 length += AvFILLp(ary) - offset + 1;
2821 length = AvMAX(ary) + 1; /* close enough to infinity */
2825 length = AvMAX(ary) + 1;
2827 if (offset > AvFILLp(ary) + 1)
2828 offset = AvFILLp(ary) + 1;
2829 after = AvFILLp(ary) + 1 - (offset + length);
2830 if (after < 0) { /* not that much array */
2831 length += after; /* offset+length now in array */
2837 /* At this point, MARK .. SP-1 is our new LIST */
2840 diff = newlen - length;
2841 if (newlen && !AvREAL(ary)) {
2845 assert(AvREAL(ary)); /* would leak, so croak */
2848 if (diff < 0) { /* shrinking the area */
2850 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2851 Copy(MARK, tmparyval, newlen, SV*);
2854 MARK = ORIGMARK + 1;
2855 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2856 MEXTEND(MARK, length);
2857 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2859 EXTEND_MORTAL(length);
2860 for (i = length, dst = MARK; i; i--) {
2861 sv_2mortal(*dst); /* free them eventualy */
2868 *MARK = AvARRAY(ary)[offset+length-1];
2871 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2872 SvREFCNT_dec(*dst++); /* free them now */
2875 AvFILLp(ary) += diff;
2877 /* pull up or down? */
2879 if (offset < after) { /* easier to pull up */
2880 if (offset) { /* esp. if nothing to pull */
2881 src = &AvARRAY(ary)[offset-1];
2882 dst = src - diff; /* diff is negative */
2883 for (i = offset; i > 0; i--) /* can't trust Copy */
2887 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2891 if (after) { /* anything to pull down? */
2892 src = AvARRAY(ary) + offset + length;
2893 dst = src + diff; /* diff is negative */
2894 Move(src, dst, after, SV*);
2896 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2897 /* avoid later double free */
2901 dst[--i] = &PL_sv_undef;
2904 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2906 *dst = NEWSV(46, 0);
2907 sv_setsv(*dst++, *src++);
2909 Safefree(tmparyval);
2912 else { /* no, expanding (or same) */
2914 New(452, tmparyval, length, SV*); /* so remember deletion */
2915 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2918 if (diff > 0) { /* expanding */
2920 /* push up or down? */
2922 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2926 Move(src, dst, offset, SV*);
2928 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2930 AvFILLp(ary) += diff;
2933 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2934 av_extend(ary, AvFILLp(ary) + diff);
2935 AvFILLp(ary) += diff;
2938 dst = AvARRAY(ary) + AvFILLp(ary);
2940 for (i = after; i; i--) {
2947 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2948 *dst = NEWSV(46, 0);
2949 sv_setsv(*dst++, *src++);
2951 MARK = ORIGMARK + 1;
2952 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2954 Copy(tmparyval, MARK, length, SV*);
2956 EXTEND_MORTAL(length);
2957 for (i = length, dst = MARK; i; i--) {
2958 sv_2mortal(*dst); /* free them eventualy */
2962 Safefree(tmparyval);
2966 else if (length--) {
2967 *MARK = tmparyval[length];
2970 while (length-- > 0)
2971 SvREFCNT_dec(tmparyval[length]);
2973 Safefree(tmparyval);
2976 *MARK = &PL_sv_undef;
2984 djSP; dMARK; dORIGMARK; dTARGET;
2985 register AV *ary = (AV*)*++MARK;
2986 register SV *sv = &PL_sv_undef;
2989 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2990 *MARK-- = SvTIED_obj((SV*)ary, mg);
2994 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2999 /* Why no pre-extend of ary here ? */
3000 for (++MARK; MARK <= SP; MARK++) {
3003 sv_setsv(sv, *MARK);
3008 PUSHi( AvFILL(ary) + 1 );
3016 SV *sv = av_pop(av);
3018 (void)sv_2mortal(sv);
3027 SV *sv = av_shift(av);
3032 (void)sv_2mortal(sv);
3039 djSP; dMARK; dORIGMARK; dTARGET;
3040 register AV *ary = (AV*)*++MARK;
3045 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3046 *MARK-- = SvTIED_obj((SV*)ary, mg);
3050 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3055 av_unshift(ary, SP - MARK);
3058 sv_setsv(sv, *++MARK);
3059 (void)av_store(ary, i++, sv);
3063 PUSHi( AvFILL(ary) + 1 );
3073 if (GIMME == G_ARRAY) {
3084 register char *down;
3090 do_join(TARG, &PL_sv_no, MARK, SP);
3092 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3093 up = SvPV_force(TARG, len);
3095 if (IN_UTF8) { /* first reverse each character */
3096 U8* s = (U8*)SvPVX(TARG);
3097 U8* send = (U8*)(s + len);
3106 down = (char*)(s - 1);
3107 if (s > send || !((*down & 0xc0) == 0x80)) {
3108 warn("Malformed UTF-8 character");
3120 down = SvPVX(TARG) + len - 1;
3126 (void)SvPOK_only(TARG);
3135 mul128(SV *sv, U8 m)
3138 char *s = SvPV(sv, len);
3142 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3143 SV *tmpNew = newSVpv("0000000000", 10);
3145 sv_catsv(tmpNew, sv);
3146 SvREFCNT_dec(sv); /* free old sv */
3151 while (!*t) /* trailing '\0'? */
3154 i = ((*t - '0') << 7) + m;
3155 *(t--) = '0' + (i % 10);
3161 /* Explosives and implosives. */
3163 static const char uuemap[] =
3164 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3165 static char uudmap[256]; /* Initialised on first use */
3166 #if 'I' == 73 && 'J' == 74
3167 /* On an ASCII/ISO kind of system */
3168 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3171 Some other sort of character set - use memchr() so we don't match
3174 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3182 I32 gimme = GIMME_V;
3186 register char *pat = SvPV(left, llen);
3187 register char *s = SvPV(right, rlen);
3188 char *strend = s + rlen;
3190 register char *patend = pat + llen;
3195 /* These must not be in registers: */
3212 register U32 culong;
3214 static char* bitcount = 0;
3217 if (gimme != G_ARRAY) { /* arrange to do first one only */
3219 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3220 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3222 while (isDIGIT(*patend) || *patend == '*')
3228 while (pat < patend) {
3230 datumtype = *pat++ & 0xFF;
3231 if (isSPACE(datumtype))
3235 else if (*pat == '*') {
3236 len = strend - strbeg; /* long enough */
3239 else if (isDIGIT(*pat)) {
3241 while (isDIGIT(*pat))
3242 len = (len * 10) + (*pat++ - '0');
3245 len = (datumtype != '@');
3248 croak("Invalid type in unpack: '%c'", (int)datumtype);
3249 case ',': /* grandfather in commas but with a warning */
3250 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3251 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3254 if (len == 1 && pat[-1] != '1')
3263 if (len > strend - strbeg)
3264 DIE("@ outside of string");
3268 if (len > s - strbeg)
3269 DIE("X outside of string");
3273 if (len > strend - s)
3274 DIE("x outside of string");
3279 if (len > strend - s)
3282 goto uchar_checksum;
3283 sv = NEWSV(35, len);
3284 sv_setpvn(sv, s, len);
3286 if (datumtype == 'A') {
3287 aptr = s; /* borrow register */
3288 s = SvPVX(sv) + len - 1;
3289 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3292 SvCUR_set(sv, s - SvPVX(sv));
3293 s = aptr; /* unborrow register */
3295 XPUSHs(sv_2mortal(sv));
3299 if (pat[-1] == '*' || len > (strend - s) * 8)
3300 len = (strend - s) * 8;
3303 Newz(601, bitcount, 256, char);
3304 for (bits = 1; bits < 256; bits++) {
3305 if (bits & 1) bitcount[bits]++;
3306 if (bits & 2) bitcount[bits]++;
3307 if (bits & 4) bitcount[bits]++;
3308 if (bits & 8) bitcount[bits]++;
3309 if (bits & 16) bitcount[bits]++;
3310 if (bits & 32) bitcount[bits]++;
3311 if (bits & 64) bitcount[bits]++;
3312 if (bits & 128) bitcount[bits]++;
3316 culong += bitcount[*(unsigned char*)s++];
3321 if (datumtype == 'b') {
3323 if (bits & 1) culong++;
3329 if (bits & 128) culong++;
3336 sv = NEWSV(35, len + 1);
3339 aptr = pat; /* borrow register */
3341 if (datumtype == 'b') {
3343 for (len = 0; len < aint; len++) {
3344 if (len & 7) /*SUPPRESS 595*/
3348 *pat++ = '0' + (bits & 1);
3353 for (len = 0; len < aint; len++) {
3358 *pat++ = '0' + ((bits & 128) != 0);
3362 pat = aptr; /* unborrow register */
3363 XPUSHs(sv_2mortal(sv));
3367 if (pat[-1] == '*' || len > (strend - s) * 2)
3368 len = (strend - s) * 2;
3369 sv = NEWSV(35, len + 1);
3372 aptr = pat; /* borrow register */
3374 if (datumtype == 'h') {
3376 for (len = 0; len < aint; len++) {
3381 *pat++ = PL_hexdigit[bits & 15];
3386 for (len = 0; len < aint; len++) {
3391 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3395 pat = aptr; /* unborrow register */
3396 XPUSHs(sv_2mortal(sv));
3399 if (len > strend - s)
3404 if (aint >= 128) /* fake up signed chars */
3414 if (aint >= 128) /* fake up signed chars */
3417 sv_setiv(sv, (IV)aint);
3418 PUSHs(sv_2mortal(sv));
3423 if (len > strend - s)
3438 sv_setiv(sv, (IV)auint);
3439 PUSHs(sv_2mortal(sv));
3444 if (len > strend - s)
3447 while (len-- > 0 && s < strend) {
3448 auint = utf8_to_uv((U8*)s, &along);
3451 cdouble += (double)auint;
3459 while (len-- > 0 && s < strend) {
3460 auint = utf8_to_uv((U8*)s, &along);
3463 sv_setuv(sv, (UV)auint);
3464 PUSHs(sv_2mortal(sv));
3469 along = (strend - s) / SIZE16;
3486 sv_setiv(sv, (IV)ashort);
3487 PUSHs(sv_2mortal(sv));
3494 along = (strend - s) / SIZE16;
3499 COPY16(s, &aushort);
3502 if (datumtype == 'n')
3503 aushort = PerlSock_ntohs(aushort);
3506 if (datumtype == 'v')
3507 aushort = vtohs(aushort);
3516 COPY16(s, &aushort);
3520 if (datumtype == 'n')
3521 aushort = PerlSock_ntohs(aushort);
3524 if (datumtype == 'v')
3525 aushort = vtohs(aushort);
3527 sv_setiv(sv, (IV)aushort);
3528 PUSHs(sv_2mortal(sv));
3533 along = (strend - s) / sizeof(int);
3538 Copy(s, &aint, 1, int);
3541 cdouble += (double)aint;
3550 Copy(s, &aint, 1, int);
3554 /* Without the dummy below unpack("i", pack("i",-1))
3555 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3556 * cc with optimization turned on */
3558 sv_setiv(sv, (IV)aint) :
3560 sv_setiv(sv, (IV)aint);
3561 PUSHs(sv_2mortal(sv));
3566 along = (strend - s) / sizeof(unsigned int);
3571 Copy(s, &auint, 1, unsigned int);
3572 s += sizeof(unsigned int);
3574 cdouble += (double)auint;
3583 Copy(s, &auint, 1, unsigned int);
3584 s += sizeof(unsigned int);
3586 sv_setuv(sv, (UV)auint);
3587 PUSHs(sv_2mortal(sv));
3592 along = (strend - s) / SIZE32;
3600 cdouble += (double)along;
3612 sv_setiv(sv, (IV)along);
3613 PUSHs(sv_2mortal(sv));
3620 along = (strend - s) / SIZE32;
3628 if (datumtype == 'N')
3629 aulong = PerlSock_ntohl(aulong);
3632 if (datumtype == 'V')
3633 aulong = vtohl(aulong);
3636 cdouble += (double)aulong;
3648 if (datumtype == 'N')
3649 aulong = PerlSock_ntohl(aulong);
3652 if (datumtype == 'V')
3653 aulong = vtohl(aulong);
3656 sv_setuv(sv, (UV)aulong);
3657 PUSHs(sv_2mortal(sv));
3662 along = (strend - s) / sizeof(char*);
3668 if (sizeof(char*) > strend - s)
3671 Copy(s, &aptr, 1, char*);
3677 PUSHs(sv_2mortal(sv));
3687 while ((len > 0) && (s < strend)) {
3688 auv = (auv << 7) | (*s & 0x7f);
3689 if (!(*s++ & 0x80)) {
3693 PUSHs(sv_2mortal(sv));
3697 else if (++bytes >= sizeof(UV)) { /* promote to string */
3700 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3701 while (s < strend) {
3702 sv = mul128(sv, *s & 0x7f);
3703 if (!(*s++ & 0x80)) {
3708 t = SvPV(sv, PL_na);
3712 PUSHs(sv_2mortal(sv));
3717 if ((s >= strend) && bytes)
3718 croak("Unterminated compressed integer");
3723 if (sizeof(char*) > strend - s)
3726 Copy(s, &aptr, 1, char*);
3731 sv_setpvn(sv, aptr, len);
3732 PUSHs(sv_2mortal(sv));
3736 along = (strend - s) / sizeof(Quad_t);
3742 if (s + sizeof(Quad_t) > strend)
3745 Copy(s, &aquad, 1, Quad_t);
3746 s += sizeof(Quad_t);
3749 if (aquad >= IV_MIN && aquad <= IV_MAX)
3750 sv_setiv(sv, (IV)aquad);
3752 sv_setnv(sv, (double)aquad);
3753 PUSHs(sv_2mortal(sv));
3757 along = (strend - s) / sizeof(Quad_t);
3763 if (s + sizeof(Uquad_t) > strend)
3766 Copy(s, &auquad, 1, Uquad_t);
3767 s += sizeof(Uquad_t);
3770 if (auquad <= UV_MAX)
3771 sv_setuv(sv, (UV)auquad);
3773 sv_setnv(sv, (double)auquad);
3774 PUSHs(sv_2mortal(sv));
3778 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3781 along = (strend - s) / sizeof(float);
3786 Copy(s, &afloat, 1, float);
3795 Copy(s, &afloat, 1, float);
3798 sv_setnv(sv, (double)afloat);
3799 PUSHs(sv_2mortal(sv));
3805 along = (strend - s) / sizeof(double);
3810 Copy(s, &adouble, 1, double);
3811 s += sizeof(double);
3819 Copy(s, &adouble, 1, double);
3820 s += sizeof(double);
3822 sv_setnv(sv, (double)adouble);
3823 PUSHs(sv_2mortal(sv));
3829 * Initialise the decode mapping. By using a table driven
3830 * algorithm, the code will be character-set independent
3831 * (and just as fast as doing character arithmetic)
3833 if (uudmap['M'] == 0) {
3836 for (i = 0; i < sizeof(uuemap); i += 1)
3837 uudmap[uuemap[i]] = i;
3839 * Because ' ' and '`' map to the same value,
3840 * we need to decode them both the same.
3845 along = (strend - s) * 3 / 4;
3846 sv = NEWSV(42, along);
3849 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3854 len = uudmap[*s++] & 077;
3856 if (s < strend && ISUUCHAR(*s))
3857 a = uudmap[*s++] & 077;
3860 if (s < strend && ISUUCHAR(*s))
3861 b = uudmap[*s++] & 077;
3864 if (s < strend && ISUUCHAR(*s))
3865 c = uudmap[*s++] & 077;
3868 if (s < strend && ISUUCHAR(*s))
3869 d = uudmap[*s++] & 077;
3872 hunk[0] = (a << 2) | (b >> 4);
3873 hunk[1] = (b << 4) | (c >> 2);
3874 hunk[2] = (c << 6) | d;
3875 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3880 else if (s[1] == '\n') /* possible checksum byte */
3883 XPUSHs(sv_2mortal(sv));
3888 if (strchr("fFdD", datumtype) ||
3889 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3893 while (checksum >= 16) {
3897 while (checksum >= 4) {
3903 along = (1 << checksum) - 1;
3904 while (cdouble < 0.0)
3906 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3907 sv_setnv(sv, cdouble);
3910 if (checksum < 32) {
3911 aulong = (1 << checksum) - 1;
3914 sv_setuv(sv, (UV)culong);
3916 XPUSHs(sv_2mortal(sv));
3920 if (SP == oldsp && gimme == G_SCALAR)
3921 PUSHs(&PL_sv_undef);
3926 doencodes(register SV *sv, register char *s, register I32 len)
3930 *hunk = uuemap[len];
3931 sv_catpvn(sv, hunk, 1);
3934 hunk[0] = uuemap[(077 & (*s >> 2))];
3935 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3936 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3937 hunk[3] = uuemap[(077 & (s[2] & 077))];
3938 sv_catpvn(sv, hunk, 4);
3943 char r = (len > 1 ? s[1] : '\0');
3944 hunk[0] = uuemap[(077 & (*s >> 2))];
3945 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3946 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3947 hunk[3] = uuemap[0];
3948 sv_catpvn(sv, hunk, 4);
3950 sv_catpvn(sv, "\n", 1);
3954 is_an_int(char *s, STRLEN l)
3956 SV *result = newSVpv("", l);
3957 char *result_c = SvPV(result, PL_na); /* convenience */
3958 char *out = result_c;
3968 SvREFCNT_dec(result);
3991 SvREFCNT_dec(result);
3997 SvCUR_set(result, out - result_c);
4002 div128(SV *pnum, bool *done)
4003 /* must be '\0' terminated */
4007 char *s = SvPV(pnum, len);
4016 i = m * 10 + (*t - '0');
4018 r = (i >> 7); /* r < 10 */
4025 SvCUR_set(pnum, (STRLEN) (t - s));
4032 djSP; dMARK; dORIGMARK; dTARGET;
4033 register SV *cat = TARG;
4036 register char *pat = SvPVx(*++MARK, fromlen);
4037 register char *patend = pat + fromlen;
4042 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4043 static char *space10 = " ";
4045 /* These must not be in registers: */
4063 sv_setpvn(cat, "", 0);
4064 while (pat < patend) {
4065 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4066 datumtype = *pat++ & 0xFF;
4067 if (isSPACE(datumtype))
4070 len = strchr("@Xxu", datumtype) ? 0 : items;
4073 else if (isDIGIT(*pat)) {
4075 while (isDIGIT(*pat))
4076 len = (len * 10) + (*pat++ - '0');
4082 croak("Invalid type in pack: '%c'", (int)datumtype);
4083 case ',': /* grandfather in commas but with a warning */
4084 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4085 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4088 DIE("%% may only be used in unpack");
4099 if (SvCUR(cat) < len)
4100 DIE("X outside of string");
4107 sv_catpvn(cat, null10, 10);
4110 sv_catpvn(cat, null10, len);
4115 aptr = SvPV(fromstr, fromlen);
4119 sv_catpvn(cat, aptr, len);
4121 sv_catpvn(cat, aptr, fromlen);
4123 if (datumtype == 'A') {
4125 sv_catpvn(cat, space10, 10);
4128 sv_catpvn(cat, space10, len);
4132 sv_catpvn(cat, null10, 10);
4135 sv_catpvn(cat, null10, len);
4142 char *savepat = pat;
4147 aptr = SvPV(fromstr, fromlen);
4152 SvCUR(cat) += (len+7)/8;
4153 SvGROW(cat, SvCUR(cat) + 1);
4154 aptr = SvPVX(cat) + aint;
4159 if (datumtype == 'B') {
4160 for (len = 0; len++ < aint;) {
4161 items |= *pat++ & 1;
4165 *aptr++ = items & 0xff;
4171 for (len = 0; len++ < aint;) {
4177 *aptr++ = items & 0xff;
4183 if (datumtype == 'B')
4184 items <<= 7 - (aint & 7);
4186 items >>= 7 - (aint & 7);
4187 *aptr++ = items & 0xff;
4189 pat = SvPVX(cat) + SvCUR(cat);
4200 char *savepat = pat;
4205 aptr = SvPV(fromstr, fromlen);
4210 SvCUR(cat) += (len+1)/2;
4211 SvGROW(cat, SvCUR(cat) + 1);
4212 aptr = SvPVX(cat) + aint;
4217 if (datumtype == 'H') {
4218 for (len = 0; len++ < aint;) {
4220 items |= ((*pat++ & 15) + 9) & 15;
4222 items |= *pat++ & 15;
4226 *aptr++ = items & 0xff;
4232 for (len = 0; len++ < aint;) {
4234 items |= (((*pat++ & 15) + 9) & 15) << 4;
4236 items |= (*pat++ & 15) << 4;
4240 *aptr++ = items & 0xff;
4246 *aptr++ = items & 0xff;
4247 pat = SvPVX(cat) + SvCUR(cat);
4259 aint = SvIV(fromstr);
4261 sv_catpvn(cat, &achar, sizeof(char));
4267 auint = SvUV(fromstr);
4268 SvGROW(cat, SvCUR(cat) + 10);
4269 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4274 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4279 afloat = (float)SvNV(fromstr);
4280 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4287 adouble = (double)SvNV(fromstr);
4288 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4294 ashort = (I16)SvIV(fromstr);
4296 ashort = PerlSock_htons(ashort);
4298 CAT16(cat, &ashort);
4304 ashort = (I16)SvIV(fromstr);
4306 ashort = htovs(ashort);
4308 CAT16(cat, &ashort);
4315 ashort = (I16)SvIV(fromstr);
4316 CAT16(cat, &ashort);
4322 auint = SvUV(fromstr);
4323 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4329 adouble = floor(SvNV(fromstr));
4332 croak("Cannot compress negative numbers");
4338 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4339 adouble <= UV_MAX_cxux
4346 char buf[1 + sizeof(UV)];
4347 char *in = buf + sizeof(buf);
4348 UV auv = U_V(adouble);;
4351 *--in = (auv & 0x7f) | 0x80;
4354 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4355 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4357 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4358 char *from, *result, *in;
4363 /* Copy string and check for compliance */
4364 from = SvPV(fromstr, len);
4365 if ((norm = is_an_int(from, len)) == NULL)
4366 croak("can compress only unsigned integer");
4368 New('w', result, len, char);
4372 *--in = div128(norm, &done) | 0x80;
4373 result[len - 1] &= 0x7F; /* clear continue bit */
4374 sv_catpvn(cat, in, (result + len) - in);
4376 SvREFCNT_dec(norm); /* free norm */
4378 else if (SvNOKp(fromstr)) {
4379 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4380 char *in = buf + sizeof(buf);
4383 double next = floor(adouble / 128);
4384 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4385 if (--in < buf) /* this cannot happen ;-) */
4386 croak ("Cannot compress integer");
4388 } while (adouble > 0);
4389 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4390 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4393 croak("Cannot compress non integer");
4399 aint = SvIV(fromstr);
4400 sv_catpvn(cat, (char*)&aint, sizeof(int));
4406 aulong = SvUV(fromstr);
4408 aulong = PerlSock_htonl(aulong);
4410 CAT32(cat, &aulong);
4416 aulong = SvUV(fromstr);
4418 aulong = htovl(aulong);
4420 CAT32(cat, &aulong);
4426 aulong = SvUV(fromstr);
4427 CAT32(cat, &aulong);
4433 along = SvIV(fromstr);
4441 auquad = (Uquad_t)SvIV(fromstr);
4442 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4448 aquad = (Quad_t)SvIV(fromstr);
4449 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4452 #endif /* HAS_QUAD */
4454 len = 1; /* assume SV is correct length */
4459 if (fromstr == &PL_sv_undef)
4462 /* XXX better yet, could spirit away the string to
4463 * a safe spot and hang on to it until the result
4464 * of pack() (and all copies of the result) are
4467 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4469 "Attempt to pack pointer to temporary value");
4470 if (SvPOK(fromstr) || SvNIOK(fromstr))
4471 aptr = SvPV(fromstr,PL_na);
4473 aptr = SvPV_force(fromstr,PL_na);
4475 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4480 aptr = SvPV(fromstr, fromlen);
4481 SvGROW(cat, fromlen * 4 / 3);
4486 while (fromlen > 0) {
4493 doencodes(cat, aptr, todo);
4512 register I32 limit = POPi; /* note, negative is forever */
4515 register char *s = SvPV(sv, len);
4516 char *strend = s + len;
4518 register REGEXP *rx;
4522 I32 maxiters = (strend - s) + 10;
4525 I32 origlimit = limit;
4528 AV *oldstack = PL_curstack;
4529 I32 gimme = GIMME_V;
4530 I32 oldsave = PL_savestack_ix;
4531 I32 make_mortal = 1;
4532 MAGIC *mg = (MAGIC *) NULL;
4535 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4540 DIE("panic: do_split");
4541 rx = pm->op_pmregexp;
4543 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4544 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4546 if (pm->op_pmreplroot)
4547 ary = GvAVn((GV*)pm->op_pmreplroot);
4548 else if (gimme != G_ARRAY)
4550 ary = (AV*)PL_curpad[0];
4552 ary = GvAVn(PL_defgv);
4553 #endif /* USE_THREADS */
4556 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4562 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4564 XPUSHs(SvTIED_obj((SV*)ary, mg));
4569 for (i = AvFILLp(ary); i >= 0; i--)
4570 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4572 /* temporarily switch stacks */
4573 SWITCHSTACK(PL_curstack, ary);
4577 base = SP - PL_stack_base;
4579 if (pm->op_pmflags & PMf_SKIPWHITE) {
4580 if (pm->op_pmflags & PMf_LOCALE) {
4581 while (isSPACE_LC(*s))
4589 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4590 SAVEINT(PL_multiline);
4591 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4595 limit = maxiters + 2;
4596 if (pm->op_pmflags & PMf_WHITE) {
4599 while (m < strend &&
4600 !((pm->op_pmflags & PMf_LOCALE)
4601 ? isSPACE_LC(*m) : isSPACE(*m)))
4606 dstr = NEWSV(30, m-s);
4607 sv_setpvn(dstr, s, m-s);
4613 while (s < strend &&
4614 ((pm->op_pmflags & PMf_LOCALE)
4615 ? isSPACE_LC(*s) : isSPACE(*s)))
4619 else if (strEQ("^", rx->precomp)) {
4622 for (m = s; m < strend && *m != '\n'; m++) ;
4626 dstr = NEWSV(30, m-s);
4627 sv_setpvn(dstr, s, m-s);
4634 else if (rx->check_substr && !rx->nparens
4635 && (rx->reganch & ROPT_CHECK_ALL)
4636 && !(rx->reganch & ROPT_ANCH)) {
4637 i = SvCUR(rx->check_substr);
4638 if (i == 1 && !SvTAIL(rx->check_substr)) {
4639 i = *SvPVX(rx->check_substr);
4642 for (m = s; m < strend && *m != i; m++) ;
4645 dstr = NEWSV(30, m-s);
4646 sv_setpvn(dstr, s, m-s);
4655 while (s < strend && --limit &&
4656 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4657 rx->check_substr, 0)) )
4660 dstr = NEWSV(31, m-s);
4661 sv_setpvn(dstr, s, m-s);
4670 maxiters += (strend - s) * rx->nparens;
4671 while (s < strend && --limit &&
4672 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4674 TAINT_IF(RX_MATCH_TAINTED(rx));
4676 && rx->subbase != orig) {
4681 strend = s + (strend - m);
4684 dstr = NEWSV(32, m-s);
4685 sv_setpvn(dstr, s, m-s);
4690 for (i = 1; i <= rx->nparens; i++) {
4694 dstr = NEWSV(33, m-s);
4695 sv_setpvn(dstr, s, m-s);
4698 dstr = NEWSV(33, 0);
4708 LEAVE_SCOPE(oldsave);
4709 iters = (SP - PL_stack_base) - base;
4710 if (iters > maxiters)
4713 /* keep field after final delim? */
4714 if (s < strend || (iters && origlimit)) {
4715 dstr = NEWSV(34, strend-s);
4716 sv_setpvn(dstr, s, strend-s);
4722 else if (!origlimit) {
4723 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4729 SWITCHSTACK(ary, oldstack);
4730 if (SvSMAGICAL(ary)) {
4735 if (gimme == G_ARRAY) {
4737 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4745 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4748 if (gimme == G_ARRAY) {
4749 /* EXTEND should not be needed - we just popped them */
4751 for (i=0; i < iters; i++) {
4752 SV **svp = av_fetch(ary, i, FALSE);
4753 PUSHs((svp) ? *svp : &PL_sv_undef);
4760 if (gimme == G_ARRAY)
4763 if (iters || !pm->op_pmreplroot) {
4773 unlock_condpair(void *svv)
4776 MAGIC *mg = mg_find((SV*)svv, 'm');
4779 croak("panic: unlock_condpair unlocking non-mutex");
4780 MUTEX_LOCK(MgMUTEXP(mg));
4781 if (MgOWNER(mg) != thr)
4782 croak("panic: unlock_condpair unlocking mutex that we don't own");
4784 COND_SIGNAL(MgOWNERCONDP(mg));
4785 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4786 (unsigned long)thr, (unsigned long)svv);)
4787 MUTEX_UNLOCK(MgMUTEXP(mg));
4789 #endif /* USE_THREADS */
4802 mg = condpair_magic(sv);
4803 MUTEX_LOCK(MgMUTEXP(mg));
4804 if (MgOWNER(mg) == thr)
4805 MUTEX_UNLOCK(MgMUTEXP(mg));
4808 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4810 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4811 (unsigned long)thr, (unsigned long)sv);)
4812 MUTEX_UNLOCK(MgMUTEXP(mg));
4813 save_destructor(unlock_condpair, sv);
4815 #endif /* USE_THREADS */
4816 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4817 || SvTYPE(retsv) == SVt_PVCV) {
4818 retsv = refto(retsv);
4829 if (PL_op->op_private & OPpLVAL_INTRO)
4830 PUSHs(*save_threadsv(PL_op->op_targ));
4832 PUSHs(THREADSV(PL_op->op_targ));
4835 DIE("tried to access per-thread data in non-threaded perl");
4836 #endif /* USE_THREADS */