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) {
231 if (SvGMAGICAL(sv)) {
237 if (PL_op->op_flags & OPf_REF ||
238 PL_op->op_private & HINT_STRICT_REFS)
239 DIE(PL_no_usym, "a symbol");
240 if (ckWARN(WARN_UNINITIALIZED))
241 warner(WARN_UNINITIALIZED, PL_warn_uninit);
245 if (PL_op->op_private & HINT_STRICT_REFS)
246 DIE(PL_no_symref, sym, "a symbol");
247 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
250 if (PL_op->op_private & OPpLVAL_INTRO)
251 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
262 tryAMAGICunDEREF(to_sv);
265 switch (SvTYPE(sv)) {
269 DIE("Not a SCALAR reference");
277 if (SvTYPE(gv) != SVt_PVGV) {
278 if (SvGMAGICAL(sv)) {
284 if (PL_op->op_flags & OPf_REF ||
285 PL_op->op_private & HINT_STRICT_REFS)
286 DIE(PL_no_usym, "a SCALAR");
287 if (ckWARN(WARN_UNINITIALIZED))
288 warner(WARN_UNINITIALIZED, PL_warn_uninit);
292 if (PL_op->op_private & HINT_STRICT_REFS)
293 DIE(PL_no_symref, sym, "a SCALAR");
294 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
298 if (PL_op->op_flags & OPf_MOD) {
299 if (PL_op->op_private & OPpLVAL_INTRO)
300 sv = save_scalar((GV*)TOPs);
301 else if (PL_op->op_private & OPpDEREF)
302 vivify_ref(sv, PL_op->op_private & OPpDEREF);
312 SV *sv = AvARYLEN(av);
314 AvARYLEN(av) = sv = NEWSV(0,0);
315 sv_upgrade(sv, SVt_IV);
316 sv_magic(sv, (SV*)av, '#', Nullch, 0);
324 djSP; dTARGET; dPOPss;
326 if (PL_op->op_flags & OPf_MOD) {
327 if (SvTYPE(TARG) < SVt_PVLV) {
328 sv_upgrade(TARG, SVt_PVLV);
329 sv_magic(TARG, Nullsv, '.', Nullch, 0);
333 if (LvTARG(TARG) != sv) {
335 SvREFCNT_dec(LvTARG(TARG));
336 LvTARG(TARG) = SvREFCNT_inc(sv);
338 PUSHs(TARG); /* no SvSETMAGIC */
344 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
345 mg = mg_find(sv, 'g');
346 if (mg && mg->mg_len >= 0) {
350 PUSHi(i + PL_curcop->cop_arybase);
364 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
365 /* (But not in defined().) */
366 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
369 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
372 cv = (CV*)&PL_sv_undef;
386 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
387 char *s = SvPVX(TOPs);
388 if (strnEQ(s, "CORE::", 6)) {
391 code = keyword(s + 6, SvCUR(TOPs) - 6);
392 if (code < 0) { /* Overridable. */
393 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
394 int i = 0, n = 0, seen_question = 0;
396 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
398 while (i < MAXO) { /* The slow way. */
399 if (strEQ(s + 6, PL_op_name[i])
400 || strEQ(s + 6, PL_op_desc[i]))
406 goto nonesuch; /* Should not happen... */
408 oa = PL_opargs[i] >> OASHIFT;
410 if (oa & OA_OPTIONAL) {
413 } else if (seen_question)
414 goto set; /* XXXX system, exec */
415 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
416 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
419 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
420 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
424 ret = sv_2mortal(newSVpv(str, n - 1));
425 } else if (code) /* Non-Overridable */
427 else { /* None such */
429 croak("Cannot find an opnumber for \"%s\"", s+6);
433 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
435 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
444 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
446 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
462 if (GIMME != G_ARRAY) {
466 *MARK = &PL_sv_undef;
467 *MARK = refto(*MARK);
471 EXTEND_MORTAL(SP - MARK);
473 *MARK = refto(*MARK);
482 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
485 if (!(sv = LvTARG(sv)))
488 else if (SvPADTMP(sv))
492 (void)SvREFCNT_inc(sv);
495 sv_upgrade(rv, SVt_RV);
509 if (sv && SvGMAGICAL(sv))
512 if (!sv || !SvROK(sv))
516 pv = sv_reftype(sv,TRUE);
517 PUSHp(pv, strlen(pv));
527 stash = PL_curcop->cop_stash;
531 char *ptr = SvPV(ssv,len);
532 if (ckWARN(WARN_UNSAFE) && len == 0)
534 "Explicit blessing to '' (assuming package main)");
535 stash = gv_stashpvn(ptr, len, TRUE);
538 (void)sv_bless(TOPs, stash);
552 elem = SvPV(sv, n_a);
556 switch (elem ? *elem : '\0')
559 if (strEQ(elem, "ARRAY"))
560 tmpRef = (SV*)GvAV(gv);
563 if (strEQ(elem, "CODE"))
564 tmpRef = (SV*)GvCVu(gv);
567 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
568 tmpRef = (SV*)GvIOp(gv);
571 if (strEQ(elem, "GLOB"))
575 if (strEQ(elem, "HASH"))
576 tmpRef = (SV*)GvHV(gv);
579 if (strEQ(elem, "IO"))
580 tmpRef = (SV*)GvIOp(gv);
583 if (strEQ(elem, "NAME"))
584 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
587 if (strEQ(elem, "PACKAGE"))
588 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
591 if (strEQ(elem, "SCALAR"))
605 /* Pattern matching */
610 register UNOP *unop = cUNOP;
611 register unsigned char *s;
614 register I32 *sfirst;
618 if (sv == PL_lastscream) {
624 SvSCREAM_off(PL_lastscream);
625 SvREFCNT_dec(PL_lastscream);
627 PL_lastscream = SvREFCNT_inc(sv);
630 s = (unsigned char*)(SvPV(sv, len));
634 if (pos > PL_maxscream) {
635 if (PL_maxscream < 0) {
636 PL_maxscream = pos + 80;
637 New(301, PL_screamfirst, 256, I32);
638 New(302, PL_screamnext, PL_maxscream, I32);
641 PL_maxscream = pos + pos / 4;
642 Renew(PL_screamnext, PL_maxscream, I32);
646 sfirst = PL_screamfirst;
647 snext = PL_screamnext;
649 if (!sfirst || !snext)
650 DIE("do_study: out of memory");
652 for (ch = 256; ch; --ch)
659 snext[pos] = sfirst[ch] - pos;
666 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
675 if (PL_op->op_flags & OPf_STACKED)
681 TARG = sv_newmortal();
686 /* Lvalue operators. */
698 djSP; dMARK; dTARGET;
708 SETi(do_chomp(TOPs));
714 djSP; dMARK; dTARGET;
715 register I32 count = 0;
718 count += do_chomp(POPs);
729 if (!sv || !SvANY(sv))
731 switch (SvTYPE(sv)) {
733 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
737 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
741 if (CvROOT(sv) || CvXSUB(sv))
758 if (!PL_op->op_private) {
767 if (SvTHINKFIRST(sv)) {
768 if (SvREADONLY(sv)) {
770 if (PL_curcop != &PL_compiling)
777 switch (SvTYPE(sv)) {
787 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
788 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
789 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
792 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
794 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
798 SvSetMagicSV(sv, &PL_sv_undef);
802 Newz(602, gp, 1, GP);
803 GvGP(sv) = gp_ref(gp);
804 GvSV(sv) = NEWSV(72,0);
805 GvLINE(sv) = PL_curcop->cop_line;
811 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
814 SvPV_set(sv, Nullch);
827 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
829 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
830 SvIVX(TOPs) != IV_MIN)
833 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
844 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
846 sv_setsv(TARG, TOPs);
847 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
848 SvIVX(TOPs) != IV_MAX)
851 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
865 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
867 sv_setsv(TARG, TOPs);
868 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
869 SvIVX(TOPs) != IV_MIN)
872 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
881 /* Ordinary operators. */
885 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
888 SETn( pow( left, right) );
895 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
898 SETn( left * right );
905 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
910 DIE("Illegal division by zero");
912 /* insure that 20./5. == 4. */
915 if ((double)I_V(left) == left &&
916 (double)I_V(right) == right &&
917 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
920 value = left / right;
924 value = left / right;
933 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
941 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
943 right = (right_neg = (i < 0)) ? -i : i;
947 right = U_V((right_neg = (n < 0)) ? -n : n);
950 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
952 left = (left_neg = (i < 0)) ? -i : i;
956 left = U_V((left_neg = (n < 0)) ? -n : n);
960 DIE("Illegal modulus zero");
963 if ((left_neg != right_neg) && ans)
966 /* XXX may warn: unary minus operator applied to unsigned type */
967 /* could change -foo to be (~foo)+1 instead */
968 if (ans <= ~((UV)IV_MAX)+1)
969 sv_setiv(TARG, ~ans+1);
971 sv_setnv(TARG, -(double)ans);
982 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
984 register I32 count = POPi;
985 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
987 I32 items = SP - MARK;
999 repeatcpy((char*)(MARK + items), (char*)MARK,
1000 items * sizeof(SV*), count - 1);
1003 else if (count <= 0)
1006 else { /* Note: mark already snarfed by pp_list */
1011 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1012 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1013 DIE("Can't x= to readonly value");
1017 SvSetSV(TARG, tmpstr);
1018 SvPV_force(TARG, len);
1023 SvGROW(TARG, (count * len) + 1);
1024 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1025 SvCUR(TARG) *= count;
1027 *SvEND(TARG) = '\0';
1029 (void)SvPOK_only(TARG);
1038 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1041 SETn( left - right );
1048 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1051 if (PL_op->op_private & HINT_INTEGER) {
1053 i = BWi(i) << shift;
1067 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1070 if (PL_op->op_private & HINT_INTEGER) {
1072 i = BWi(i) >> shift;
1086 djSP; tryAMAGICbinSET(lt,0);
1089 SETs(boolSV(TOPn < value));
1096 djSP; tryAMAGICbinSET(gt,0);
1099 SETs(boolSV(TOPn > value));
1106 djSP; tryAMAGICbinSET(le,0);
1109 SETs(boolSV(TOPn <= value));
1116 djSP; tryAMAGICbinSET(ge,0);
1119 SETs(boolSV(TOPn >= value));
1126 djSP; tryAMAGICbinSET(ne,0);
1129 SETs(boolSV(TOPn != value));
1136 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1143 else if (left < right)
1145 else if (left > right)
1158 djSP; tryAMAGICbinSET(slt,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(sgt,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(sle,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(sge,0);
1200 int cmp = ((PL_op->op_private & OPpLOCALE)
1201 ? sv_cmp_locale(left, right)
1202 : sv_cmp(left, right));
1203 SETs(boolSV(cmp >= 0));
1210 djSP; tryAMAGICbinSET(seq,0);
1213 SETs(boolSV(sv_eq(left, right)));
1220 djSP; tryAMAGICbinSET(sne,0);
1223 SETs(boolSV(!sv_eq(left, right)));
1230 djSP; dTARGET; tryAMAGICbin(scmp,0);
1233 int cmp = ((PL_op->op_private & OPpLOCALE)
1234 ? sv_cmp_locale(left, right)
1235 : sv_cmp(left, right));
1243 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1246 if (SvNIOKp(left) || SvNIOKp(right)) {
1247 if (PL_op->op_private & HINT_INTEGER) {
1248 IBW value = SvIV(left) & SvIV(right);
1252 UBW value = SvUV(left) & SvUV(right);
1257 do_vop(PL_op->op_type, TARG, left, right);
1266 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1269 if (SvNIOKp(left) || SvNIOKp(right)) {
1270 if (PL_op->op_private & HINT_INTEGER) {
1271 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1275 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1280 do_vop(PL_op->op_type, TARG, left, right);
1289 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1292 if (SvNIOKp(left) || SvNIOKp(right)) {
1293 if (PL_op->op_private & HINT_INTEGER) {
1294 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1298 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1303 do_vop(PL_op->op_type, TARG, left, right);
1312 djSP; dTARGET; tryAMAGICun(neg);
1317 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1319 else if (SvNIOKp(sv))
1321 else if (SvPOKp(sv)) {
1323 char *s = SvPV(sv, len);
1324 if (isIDFIRST(*s)) {
1325 sv_setpvn(TARG, "-", 1);
1328 else if (*s == '+' || *s == '-') {
1330 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1332 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1333 sv_setpvn(TARG, "-", 1);
1337 sv_setnv(TARG, -SvNV(sv));
1349 djSP; tryAMAGICunSET(not);
1350 #endif /* OVERLOAD */
1351 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1357 djSP; dTARGET; tryAMAGICun(compl);
1361 if (PL_op->op_private & HINT_INTEGER) {
1362 IBW value = ~SvIV(sv);
1366 UBW value = ~SvUV(sv);
1371 register char *tmps;
1372 register long *tmpl;
1377 tmps = SvPV_force(TARG, len);
1380 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1383 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1387 for ( ; anum > 0; anum--, tmps++)
1396 /* integer versions of some of the above */
1400 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1403 SETi( left * right );
1410 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1414 DIE("Illegal division by zero");
1415 value = POPi / value;
1423 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1427 DIE("Illegal modulus zero");
1428 SETi( left % right );
1435 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1438 SETi( left + right );
1445 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1448 SETi( left - right );
1455 djSP; tryAMAGICbinSET(lt,0);
1458 SETs(boolSV(left < right));
1465 djSP; tryAMAGICbinSET(gt,0);
1468 SETs(boolSV(left > right));
1475 djSP; tryAMAGICbinSET(le,0);
1478 SETs(boolSV(left <= right));
1485 djSP; tryAMAGICbinSET(ge,0);
1488 SETs(boolSV(left >= right));
1495 djSP; tryAMAGICbinSET(eq,0);
1498 SETs(boolSV(left == right));
1505 djSP; tryAMAGICbinSET(ne,0);
1508 SETs(boolSV(left != right));
1515 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1522 else if (left < right)
1533 djSP; dTARGET; tryAMAGICun(neg);
1538 /* High falutin' math. */
1542 djSP; dTARGET; tryAMAGICbin(atan2,0);
1545 SETn(atan2(left, right));
1552 djSP; dTARGET; tryAMAGICun(sin);
1564 djSP; dTARGET; tryAMAGICun(cos);
1574 /* Support Configure command-line overrides for rand() functions.
1575 After 5.005, perhaps we should replace this by Configure support
1576 for drand48(), random(), or rand(). For 5.005, though, maintain
1577 compatibility by calling rand() but allow the user to override it.
1578 See INSTALL for details. --Andy Dougherty 15 July 1998
1580 /* Now it's after 5.005, and Configure supports drand48() and random(),
1581 in addition to rand(). So the overrides should not be needed any more.
1582 --Jarkko Hietaniemi 27 September 1998
1585 #ifndef HAS_DRAND48_PROTO
1586 extern double drand48 _((void));
1599 if (!srand_called) {
1600 (void)seedDrand01((Rand_seed_t)seed());
1601 srand_called = TRUE;
1616 (void)seedDrand01((Rand_seed_t)anum);
1617 srand_called = TRUE;
1626 * This is really just a quick hack which grabs various garbage
1627 * values. It really should be a real hash algorithm which
1628 * spreads the effect of every input bit onto every output bit,
1629 * if someone who knows about such things would bother to write it.
1630 * Might be a good idea to add that function to CORE as well.
1631 * No numbers below come from careful analysis or anything here,
1632 * except they are primes and SEED_C1 > 1E6 to get a full-width
1633 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1634 * probably be bigger too.
1637 # define SEED_C1 1000003
1638 #define SEED_C4 73819
1640 # define SEED_C1 25747
1641 #define SEED_C4 20639
1645 #define SEED_C5 26107
1648 #ifndef PERL_NO_DEV_RANDOM
1653 # include <starlet.h>
1654 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1655 * in 100-ns units, typically incremented ever 10 ms. */
1656 unsigned int when[2];
1658 # ifdef HAS_GETTIMEOFDAY
1659 struct timeval when;
1665 /* This test is an escape hatch, this symbol isn't set by Configure. */
1666 #ifndef PERL_NO_DEV_RANDOM
1667 #ifndef PERL_RANDOM_DEVICE
1668 /* /dev/random isn't used by default because reads from it will block
1669 * if there isn't enough entropy available. You can compile with
1670 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1671 * is enough real entropy to fill the seed. */
1672 # define PERL_RANDOM_DEVICE "/dev/urandom"
1674 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1676 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1685 _ckvmssts(sys$gettim(when));
1686 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1688 # ifdef HAS_GETTIMEOFDAY
1689 gettimeofday(&when,(struct timezone *) 0);
1690 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1693 u = (U32)SEED_C1 * when;
1696 u += SEED_C3 * (U32)getpid();
1697 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1698 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1699 u += SEED_C5 * (U32)(UV)&when;
1706 djSP; dTARGET; tryAMAGICun(exp);
1718 djSP; dTARGET; tryAMAGICun(log);
1723 SET_NUMERIC_STANDARD();
1724 DIE("Can't take log of %g", value);
1734 djSP; dTARGET; tryAMAGICun(sqrt);
1739 SET_NUMERIC_STANDARD();
1740 DIE("Can't take sqrt of %g", value);
1742 value = sqrt(value);
1752 double value = TOPn;
1755 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1761 (void)modf(value, &value);
1763 (void)modf(-value, &value);
1778 djSP; dTARGET; tryAMAGICun(abs);
1780 double value = TOPn;
1783 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1784 (iv = SvIVX(TOPs)) != IV_MIN) {
1806 XPUSHu(scan_hex(tmps, 99, &argtype));
1819 while (*tmps && isSPACE(*tmps))
1824 value = scan_hex(++tmps, 99, &argtype);
1825 else if (*tmps == 'b')
1826 value = scan_bin(++tmps, 99, &argtype);
1828 value = scan_oct(tmps, 99, &argtype);
1840 SETi( sv_len_utf8(TOPs) );
1844 SETi( sv_len(TOPs) );
1858 I32 lvalue = PL_op->op_flags & OPf_MOD;
1860 I32 arybase = PL_curcop->cop_arybase;
1864 SvTAINTED_off(TARG); /* decontaminate */
1868 repl = SvPV(sv, repl_len);
1875 tmps = SvPV(sv, curlen);
1877 utfcurlen = sv_len_utf8(sv);
1878 if (utfcurlen == curlen)
1886 if (pos >= arybase) {
1904 else if (len >= 0) {
1906 if (rem > (I32)curlen)
1920 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1921 warner(WARN_SUBSTR, "substr outside of string");
1926 sv_pos_u2b(sv, &pos, &rem);
1928 sv_setpvn(TARG, tmps, rem);
1929 if (lvalue) { /* it's an lvalue! */
1930 if (!SvGMAGICAL(sv)) {
1934 if (ckWARN(WARN_SUBSTR))
1936 "Attempt to use reference as lvalue in substr");
1938 if (SvOK(sv)) /* is it defined ? */
1939 (void)SvPOK_only(sv);
1941 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1944 if (SvTYPE(TARG) < SVt_PVLV) {
1945 sv_upgrade(TARG, SVt_PVLV);
1946 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1950 if (LvTARG(TARG) != sv) {
1952 SvREFCNT_dec(LvTARG(TARG));
1953 LvTARG(TARG) = SvREFCNT_inc(sv);
1955 LvTARGOFF(TARG) = pos;
1956 LvTARGLEN(TARG) = rem;
1959 sv_insert(sv, pos, rem, repl, repl_len);
1962 PUSHs(TARG); /* avoid SvSETMAGIC here */
1969 register I32 size = POPi;
1970 register I32 offset = POPi;
1971 register SV *src = POPs;
1972 I32 lvalue = PL_op->op_flags & OPf_MOD;
1974 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1975 unsigned long retnum;
1978 SvTAINTED_off(TARG); /* decontaminate */
1979 offset *= size; /* turn into bit offset */
1980 len = (offset + size + 7) / 8;
1981 if (offset < 0 || size < 1)
1984 if (lvalue) { /* it's an lvalue! */
1985 if (SvTYPE(TARG) < SVt_PVLV) {
1986 sv_upgrade(TARG, SVt_PVLV);
1987 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1991 if (LvTARG(TARG) != src) {
1993 SvREFCNT_dec(LvTARG(TARG));
1994 LvTARG(TARG) = SvREFCNT_inc(src);
1996 LvTARGOFF(TARG) = offset;
1997 LvTARGLEN(TARG) = size;
2005 if (offset >= srclen)
2008 retnum = (unsigned long) s[offset] << 8;
2010 else if (size == 32) {
2011 if (offset >= srclen)
2013 else if (offset + 1 >= srclen)
2014 retnum = (unsigned long) s[offset] << 24;
2015 else if (offset + 2 >= srclen)
2016 retnum = ((unsigned long) s[offset] << 24) +
2017 ((unsigned long) s[offset + 1] << 16);
2019 retnum = ((unsigned long) s[offset] << 24) +
2020 ((unsigned long) s[offset + 1] << 16) +
2021 (s[offset + 2] << 8);
2026 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2031 else if (size == 16)
2032 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2033 else if (size == 32)
2034 retnum = ((unsigned long) s[offset] << 24) +
2035 ((unsigned long) s[offset + 1] << 16) +
2036 (s[offset + 2] << 8) + s[offset+3];
2040 sv_setuv(TARG, (UV)retnum);
2055 I32 arybase = PL_curcop->cop_arybase;
2060 offset = POPi - arybase;
2063 tmps = SvPV(big, biglen);
2064 if (IN_UTF8 && offset > 0)
2065 sv_pos_u2b(big, &offset, 0);
2068 else if (offset > biglen)
2070 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2071 (unsigned char*)tmps + biglen, little, 0)))
2074 retval = tmps2 - tmps;
2075 if (IN_UTF8 && retval > 0)
2076 sv_pos_b2u(big, &retval);
2077 PUSHi(retval + arybase);
2092 I32 arybase = PL_curcop->cop_arybase;
2098 tmps2 = SvPV(little, llen);
2099 tmps = SvPV(big, blen);
2103 if (IN_UTF8 && offset > 0)
2104 sv_pos_u2b(big, &offset, 0);
2105 offset = offset - arybase + llen;
2109 else if (offset > blen)
2111 if (!(tmps2 = rninstr(tmps, tmps + offset,
2112 tmps2, tmps2 + llen)))
2115 retval = tmps2 - tmps;
2116 if (IN_UTF8 && retval > 0)
2117 sv_pos_b2u(big, &retval);
2118 PUSHi(retval + arybase);
2124 djSP; dMARK; dORIGMARK; dTARGET;
2125 #ifdef USE_LOCALE_NUMERIC
2126 if (PL_op->op_private & OPpLOCALE)
2127 SET_NUMERIC_LOCAL();
2129 SET_NUMERIC_STANDARD();
2131 do_sprintf(TARG, SP-MARK, MARK+1);
2132 TAINT_IF(SvTAINTED(TARG));
2143 U8 *tmps = (U8*)POPpx;
2146 if (IN_UTF8 && (*tmps & 0x80))
2147 value = utf8_to_uv(tmps, &retlen);
2149 value = (UV)(*tmps & 255);
2160 (void)SvUPGRADE(TARG,SVt_PV);
2162 if (IN_UTF8 && value >= 128) {
2165 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2166 SvCUR_set(TARG, tmps - SvPVX(TARG));
2168 (void)SvPOK_only(TARG);
2178 (void)SvPOK_only(TARG);
2185 djSP; dTARGET; dPOPTOPssrl;
2188 char *tmps = SvPV(left, n_a);
2190 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2192 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2196 "The crypt() function is unimplemented due to excessive paranoia.");
2209 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2213 UV uv = utf8_to_uv(s, &ulen);
2215 if (PL_op->op_private & OPpLOCALE) {
2218 uv = toTITLE_LC_uni(uv);
2221 uv = toTITLE_utf8(s);
2223 tend = uv_to_utf8(tmpbuf, uv);
2225 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2227 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2228 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2232 s = (U8*)SvPV_force(sv, slen);
2233 Copy(tmpbuf, s, ulen, U8);
2238 if (!SvPADTMP(sv)) {
2244 s = (U8*)SvPV_force(sv, slen);
2246 if (PL_op->op_private & OPpLOCALE) {
2249 *s = toUPPER_LC(*s);
2265 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2269 UV uv = utf8_to_uv(s, &ulen);
2271 if (PL_op->op_private & OPpLOCALE) {
2274 uv = toLOWER_LC_uni(uv);
2277 uv = toLOWER_utf8(s);
2279 tend = uv_to_utf8(tmpbuf, uv);
2281 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2283 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2284 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2288 s = (U8*)SvPV_force(sv, slen);
2289 Copy(tmpbuf, s, ulen, U8);
2294 if (!SvPADTMP(sv)) {
2300 s = (U8*)SvPV_force(sv, slen);
2302 if (PL_op->op_private & OPpLOCALE) {
2305 *s = toLOWER_LC(*s);
2328 s = (U8*)SvPV(sv,len);
2330 sv_setpvn(TARG, "", 0);
2335 (void)SvUPGRADE(TARG, SVt_PV);
2336 SvGROW(TARG, (len * 2) + 1);
2337 (void)SvPOK_only(TARG);
2338 d = (U8*)SvPVX(TARG);
2340 if (PL_op->op_private & OPpLOCALE) {
2344 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2350 d = uv_to_utf8(d, toUPPER_utf8( s ));
2355 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2360 if (!SvPADTMP(sv)) {
2367 s = (U8*)SvPV_force(sv, len);
2369 register U8 *send = s + len;
2371 if (PL_op->op_private & OPpLOCALE) {
2374 for (; s < send; s++)
2375 *s = toUPPER_LC(*s);
2378 for (; s < send; s++)
2398 s = (U8*)SvPV(sv,len);
2400 sv_setpvn(TARG, "", 0);
2405 (void)SvUPGRADE(TARG, SVt_PV);
2406 SvGROW(TARG, (len * 2) + 1);
2407 (void)SvPOK_only(TARG);
2408 d = (U8*)SvPVX(TARG);
2410 if (PL_op->op_private & OPpLOCALE) {
2414 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2420 d = uv_to_utf8(d, toLOWER_utf8(s));
2425 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2430 if (!SvPADTMP(sv)) {
2437 s = (U8*)SvPV_force(sv, len);
2439 register U8 *send = s + len;
2441 if (PL_op->op_private & OPpLOCALE) {
2444 for (; s < send; s++)
2445 *s = toLOWER_LC(*s);
2448 for (; s < send; s++)
2460 register char *s = SvPV(sv,len);
2464 (void)SvUPGRADE(TARG, SVt_PV);
2465 SvGROW(TARG, (len * 2) + 1);
2470 STRLEN ulen = UTF8SKIP(s);
2493 SvCUR_set(TARG, d - SvPVX(TARG));
2494 (void)SvPOK_only(TARG);
2497 sv_setpvn(TARG, s, len);
2506 djSP; dMARK; dORIGMARK;
2508 register AV* av = (AV*)POPs;
2509 register I32 lval = PL_op->op_flags & OPf_MOD;
2510 I32 arybase = PL_curcop->cop_arybase;
2513 if (SvTYPE(av) == SVt_PVAV) {
2514 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2516 for (svp = MARK + 1; svp <= SP; svp++) {
2521 if (max > AvMAX(av))
2524 while (++MARK <= SP) {
2525 elem = SvIVx(*MARK);
2529 svp = av_fetch(av, elem, lval);
2531 if (!svp || *svp == &PL_sv_undef)
2532 DIE(PL_no_aelem, elem);
2533 if (PL_op->op_private & OPpLVAL_INTRO)
2534 save_aelem(av, elem, svp);
2536 *MARK = svp ? *svp : &PL_sv_undef;
2539 if (GIMME != G_ARRAY) {
2547 /* Associative arrays. */
2552 HV *hash = (HV*)POPs;
2554 I32 gimme = GIMME_V;
2555 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2558 /* might clobber stack_sp */
2559 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2564 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2565 if (gimme == G_ARRAY) {
2567 /* might clobber stack_sp */
2568 sv_setsv(TARG, realhv ?
2569 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2574 else if (gimme == G_SCALAR)
2593 I32 gimme = GIMME_V;
2594 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2598 if (PL_op->op_private & OPpSLICE) {
2602 hvtype = SvTYPE(hv);
2603 while (++MARK <= SP) {
2604 if (hvtype == SVt_PVHV)
2605 sv = hv_delete_ent(hv, *MARK, discard, 0);
2607 DIE("Not a HASH reference");
2608 *MARK = sv ? sv : &PL_sv_undef;
2612 else if (gimme == G_SCALAR) {
2621 if (SvTYPE(hv) == SVt_PVHV)
2622 sv = hv_delete_ent(hv, keysv, discard, 0);
2624 DIE("Not a HASH reference");
2638 if (SvTYPE(hv) == SVt_PVHV) {
2639 if (hv_exists_ent(hv, tmpsv, 0))
2641 } else if (SvTYPE(hv) == SVt_PVAV) {
2642 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2645 DIE("Not a HASH reference");
2652 djSP; dMARK; dORIGMARK;
2653 register HV *hv = (HV*)POPs;
2654 register I32 lval = PL_op->op_flags & OPf_MOD;
2655 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2657 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2658 DIE("Can't localize pseudo-hash element");
2660 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2661 while (++MARK <= SP) {
2665 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2666 svp = he ? &HeVAL(he) : 0;
2668 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2671 if (!svp || *svp == &PL_sv_undef) {
2673 DIE(PL_no_helem, SvPV(keysv, n_a));
2675 if (PL_op->op_private & OPpLVAL_INTRO)
2676 save_helem(hv, keysv, svp);
2678 *MARK = svp ? *svp : &PL_sv_undef;
2681 if (GIMME != G_ARRAY) {
2689 /* List operators. */
2694 if (GIMME != G_ARRAY) {
2696 *MARK = *SP; /* unwanted list, return last item */
2698 *MARK = &PL_sv_undef;
2707 SV **lastrelem = PL_stack_sp;
2708 SV **lastlelem = PL_stack_base + POPMARK;
2709 SV **firstlelem = PL_stack_base + POPMARK + 1;
2710 register SV **firstrelem = lastlelem + 1;
2711 I32 arybase = PL_curcop->cop_arybase;
2712 I32 lval = PL_op->op_flags & OPf_MOD;
2713 I32 is_something_there = lval;
2715 register I32 max = lastrelem - lastlelem;
2716 register SV **lelem;
2719 if (GIMME != G_ARRAY) {
2720 ix = SvIVx(*lastlelem);
2725 if (ix < 0 || ix >= max)
2726 *firstlelem = &PL_sv_undef;
2728 *firstlelem = firstrelem[ix];
2734 SP = firstlelem - 1;
2738 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2743 *lelem = &PL_sv_undef;
2744 else if (!(*lelem = firstrelem[ix]))
2745 *lelem = &PL_sv_undef;
2749 if (ix >= max || !(*lelem = firstrelem[ix]))
2750 *lelem = &PL_sv_undef;
2752 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2753 is_something_there = TRUE;
2755 if (is_something_there)
2758 SP = firstlelem - 1;
2764 djSP; dMARK; dORIGMARK;
2765 I32 items = SP - MARK;
2766 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2767 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2774 djSP; dMARK; dORIGMARK;
2775 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2779 SV *val = NEWSV(46, 0);
2781 sv_setsv(val, *++MARK);
2782 else if (ckWARN(WARN_UNSAFE))
2783 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2784 (void)hv_store_ent(hv,key,val,0);
2793 djSP; dMARK; dORIGMARK;
2794 register AV *ary = (AV*)*++MARK;
2798 register I32 offset;
2799 register I32 length;
2806 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2807 *MARK-- = SvTIED_obj((SV*)ary, mg);
2811 perl_call_method("SPLICE",GIMME_V);
2820 offset = i = SvIVx(*MARK);
2822 offset += AvFILLp(ary) + 1;
2824 offset -= PL_curcop->cop_arybase;
2826 DIE(PL_no_aelem, i);
2828 length = SvIVx(*MARK++);
2830 length += AvFILLp(ary) - offset + 1;
2836 length = AvMAX(ary) + 1; /* close enough to infinity */
2840 length = AvMAX(ary) + 1;
2842 if (offset > AvFILLp(ary) + 1)
2843 offset = AvFILLp(ary) + 1;
2844 after = AvFILLp(ary) + 1 - (offset + length);
2845 if (after < 0) { /* not that much array */
2846 length += after; /* offset+length now in array */
2852 /* At this point, MARK .. SP-1 is our new LIST */
2855 diff = newlen - length;
2856 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2859 if (diff < 0) { /* shrinking the area */
2861 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2862 Copy(MARK, tmparyval, newlen, SV*);
2865 MARK = ORIGMARK + 1;
2866 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2867 MEXTEND(MARK, length);
2868 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2870 EXTEND_MORTAL(length);
2871 for (i = length, dst = MARK; i; i--) {
2872 sv_2mortal(*dst); /* free them eventualy */
2879 *MARK = AvARRAY(ary)[offset+length-1];
2882 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2883 SvREFCNT_dec(*dst++); /* free them now */
2886 AvFILLp(ary) += diff;
2888 /* pull up or down? */
2890 if (offset < after) { /* easier to pull up */
2891 if (offset) { /* esp. if nothing to pull */
2892 src = &AvARRAY(ary)[offset-1];
2893 dst = src - diff; /* diff is negative */
2894 for (i = offset; i > 0; i--) /* can't trust Copy */
2898 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2902 if (after) { /* anything to pull down? */
2903 src = AvARRAY(ary) + offset + length;
2904 dst = src + diff; /* diff is negative */
2905 Move(src, dst, after, SV*);
2907 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2908 /* avoid later double free */
2912 dst[--i] = &PL_sv_undef;
2915 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2917 *dst = NEWSV(46, 0);
2918 sv_setsv(*dst++, *src++);
2920 Safefree(tmparyval);
2923 else { /* no, expanding (or same) */
2925 New(452, tmparyval, length, SV*); /* so remember deletion */
2926 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2929 if (diff > 0) { /* expanding */
2931 /* push up or down? */
2933 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2937 Move(src, dst, offset, SV*);
2939 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2941 AvFILLp(ary) += diff;
2944 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2945 av_extend(ary, AvFILLp(ary) + diff);
2946 AvFILLp(ary) += diff;
2949 dst = AvARRAY(ary) + AvFILLp(ary);
2951 for (i = after; i; i--) {
2958 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2959 *dst = NEWSV(46, 0);
2960 sv_setsv(*dst++, *src++);
2962 MARK = ORIGMARK + 1;
2963 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2965 Copy(tmparyval, MARK, length, SV*);
2967 EXTEND_MORTAL(length);
2968 for (i = length, dst = MARK; i; i--) {
2969 sv_2mortal(*dst); /* free them eventualy */
2973 Safefree(tmparyval);
2977 else if (length--) {
2978 *MARK = tmparyval[length];
2981 while (length-- > 0)
2982 SvREFCNT_dec(tmparyval[length]);
2984 Safefree(tmparyval);
2987 *MARK = &PL_sv_undef;
2995 djSP; dMARK; dORIGMARK; dTARGET;
2996 register AV *ary = (AV*)*++MARK;
2997 register SV *sv = &PL_sv_undef;
3000 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3001 *MARK-- = SvTIED_obj((SV*)ary, mg);
3005 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3010 /* Why no pre-extend of ary here ? */
3011 for (++MARK; MARK <= SP; MARK++) {
3014 sv_setsv(sv, *MARK);
3019 PUSHi( AvFILL(ary) + 1 );
3027 SV *sv = av_pop(av);
3029 (void)sv_2mortal(sv);
3038 SV *sv = av_shift(av);
3043 (void)sv_2mortal(sv);
3050 djSP; dMARK; dORIGMARK; dTARGET;
3051 register AV *ary = (AV*)*++MARK;
3056 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3057 *MARK-- = SvTIED_obj((SV*)ary, mg);
3061 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3066 av_unshift(ary, SP - MARK);
3069 sv_setsv(sv, *++MARK);
3070 (void)av_store(ary, i++, sv);
3074 PUSHi( AvFILL(ary) + 1 );
3084 if (GIMME == G_ARRAY) {
3095 register char *down;
3101 do_join(TARG, &PL_sv_no, MARK, SP);
3103 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3104 up = SvPV_force(TARG, len);
3106 if (IN_UTF8) { /* first reverse each character */
3107 U8* s = (U8*)SvPVX(TARG);
3108 U8* send = (U8*)(s + len);
3117 down = (char*)(s - 1);
3118 if (s > send || !((*down & 0xc0) == 0x80)) {
3119 warn("Malformed UTF-8 character");
3131 down = SvPVX(TARG) + len - 1;
3137 (void)SvPOK_only(TARG);
3146 mul128(SV *sv, U8 m)
3149 char *s = SvPV(sv, len);
3153 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3154 SV *tmpNew = newSVpv("0000000000", 10);
3156 sv_catsv(tmpNew, sv);
3157 SvREFCNT_dec(sv); /* free old sv */
3162 while (!*t) /* trailing '\0'? */
3165 i = ((*t - '0') << 7) + m;
3166 *(t--) = '0' + (i % 10);
3172 /* Explosives and implosives. */
3174 static const char uuemap[] =
3175 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3176 static char uudmap[256]; /* Initialised on first use */
3177 #if 'I' == 73 && 'J' == 74
3178 /* On an ASCII/ISO kind of system */
3179 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3182 Some other sort of character set - use memchr() so we don't match
3185 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3193 I32 gimme = GIMME_V;
3197 register char *pat = SvPV(left, llen);
3198 register char *s = SvPV(right, rlen);
3199 char *strend = s + rlen;
3201 register char *patend = pat + llen;
3206 /* These must not be in registers: */
3223 register U32 culong;
3225 static char* bitcount = 0;
3228 if (gimme != G_ARRAY) { /* arrange to do first one only */
3230 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3231 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3233 while (isDIGIT(*patend) || *patend == '*')
3239 while (pat < patend) {
3241 datumtype = *pat++ & 0xFF;
3242 if (isSPACE(datumtype))
3246 else if (*pat == '*') {
3247 len = strend - strbeg; /* long enough */
3250 else if (isDIGIT(*pat)) {
3252 while (isDIGIT(*pat))
3253 len = (len * 10) + (*pat++ - '0');
3256 len = (datumtype != '@');
3259 croak("Invalid type in unpack: '%c'", (int)datumtype);
3260 case ',': /* grandfather in commas but with a warning */
3261 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3262 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3265 if (len == 1 && pat[-1] != '1')
3274 if (len > strend - strbeg)
3275 DIE("@ outside of string");
3279 if (len > s - strbeg)
3280 DIE("X outside of string");
3284 if (len > strend - s)
3285 DIE("x outside of string");
3290 if (len > strend - s)
3293 goto uchar_checksum;
3294 sv = NEWSV(35, len);
3295 sv_setpvn(sv, s, len);
3297 if (datumtype == 'A') {
3298 aptr = s; /* borrow register */
3299 s = SvPVX(sv) + len - 1;
3300 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3303 SvCUR_set(sv, s - SvPVX(sv));
3304 s = aptr; /* unborrow register */
3306 XPUSHs(sv_2mortal(sv));
3310 if (pat[-1] == '*' || len > (strend - s) * 8)
3311 len = (strend - s) * 8;
3314 Newz(601, bitcount, 256, char);
3315 for (bits = 1; bits < 256; bits++) {
3316 if (bits & 1) bitcount[bits]++;
3317 if (bits & 2) bitcount[bits]++;
3318 if (bits & 4) bitcount[bits]++;
3319 if (bits & 8) bitcount[bits]++;
3320 if (bits & 16) bitcount[bits]++;
3321 if (bits & 32) bitcount[bits]++;
3322 if (bits & 64) bitcount[bits]++;
3323 if (bits & 128) bitcount[bits]++;
3327 culong += bitcount[*(unsigned char*)s++];
3332 if (datumtype == 'b') {
3334 if (bits & 1) culong++;
3340 if (bits & 128) culong++;
3347 sv = NEWSV(35, len + 1);
3350 aptr = pat; /* borrow register */
3352 if (datumtype == 'b') {
3354 for (len = 0; len < aint; len++) {
3355 if (len & 7) /*SUPPRESS 595*/
3359 *pat++ = '0' + (bits & 1);
3364 for (len = 0; len < aint; len++) {
3369 *pat++ = '0' + ((bits & 128) != 0);
3373 pat = aptr; /* unborrow register */
3374 XPUSHs(sv_2mortal(sv));
3378 if (pat[-1] == '*' || len > (strend - s) * 2)
3379 len = (strend - s) * 2;
3380 sv = NEWSV(35, len + 1);
3383 aptr = pat; /* borrow register */
3385 if (datumtype == 'h') {
3387 for (len = 0; len < aint; len++) {
3392 *pat++ = PL_hexdigit[bits & 15];
3397 for (len = 0; len < aint; len++) {
3402 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3406 pat = aptr; /* unborrow register */
3407 XPUSHs(sv_2mortal(sv));
3410 if (len > strend - s)
3415 if (aint >= 128) /* fake up signed chars */
3425 if (aint >= 128) /* fake up signed chars */
3428 sv_setiv(sv, (IV)aint);
3429 PUSHs(sv_2mortal(sv));
3434 if (len > strend - s)
3449 sv_setiv(sv, (IV)auint);
3450 PUSHs(sv_2mortal(sv));
3455 if (len > strend - s)
3458 while (len-- > 0 && s < strend) {
3459 auint = utf8_to_uv((U8*)s, &along);
3462 cdouble += (double)auint;
3470 while (len-- > 0 && s < strend) {
3471 auint = utf8_to_uv((U8*)s, &along);
3474 sv_setuv(sv, (UV)auint);
3475 PUSHs(sv_2mortal(sv));
3480 along = (strend - s) / SIZE16;
3497 sv_setiv(sv, (IV)ashort);
3498 PUSHs(sv_2mortal(sv));
3505 along = (strend - s) / SIZE16;
3510 COPY16(s, &aushort);
3513 if (datumtype == 'n')
3514 aushort = PerlSock_ntohs(aushort);
3517 if (datumtype == 'v')
3518 aushort = vtohs(aushort);
3527 COPY16(s, &aushort);
3531 if (datumtype == 'n')
3532 aushort = PerlSock_ntohs(aushort);
3535 if (datumtype == 'v')
3536 aushort = vtohs(aushort);
3538 sv_setiv(sv, (IV)aushort);
3539 PUSHs(sv_2mortal(sv));
3544 along = (strend - s) / sizeof(int);
3549 Copy(s, &aint, 1, int);
3552 cdouble += (double)aint;
3561 Copy(s, &aint, 1, int);
3565 /* Without the dummy below unpack("i", pack("i",-1))
3566 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3567 * cc with optimization turned on */
3569 sv_setiv(sv, (IV)aint) :
3571 sv_setiv(sv, (IV)aint);
3572 PUSHs(sv_2mortal(sv));
3577 along = (strend - s) / sizeof(unsigned int);
3582 Copy(s, &auint, 1, unsigned int);
3583 s += sizeof(unsigned int);
3585 cdouble += (double)auint;
3594 Copy(s, &auint, 1, unsigned int);
3595 s += sizeof(unsigned int);
3597 sv_setuv(sv, (UV)auint);
3598 PUSHs(sv_2mortal(sv));
3603 along = (strend - s) / SIZE32;
3611 cdouble += (double)along;
3623 sv_setiv(sv, (IV)along);
3624 PUSHs(sv_2mortal(sv));
3631 along = (strend - s) / SIZE32;
3639 if (datumtype == 'N')
3640 aulong = PerlSock_ntohl(aulong);
3643 if (datumtype == 'V')
3644 aulong = vtohl(aulong);
3647 cdouble += (double)aulong;
3659 if (datumtype == 'N')
3660 aulong = PerlSock_ntohl(aulong);
3663 if (datumtype == 'V')
3664 aulong = vtohl(aulong);
3667 sv_setuv(sv, (UV)aulong);
3668 PUSHs(sv_2mortal(sv));
3673 along = (strend - s) / sizeof(char*);
3679 if (sizeof(char*) > strend - s)
3682 Copy(s, &aptr, 1, char*);
3688 PUSHs(sv_2mortal(sv));
3698 while ((len > 0) && (s < strend)) {
3699 auv = (auv << 7) | (*s & 0x7f);
3700 if (!(*s++ & 0x80)) {
3704 PUSHs(sv_2mortal(sv));
3708 else if (++bytes >= sizeof(UV)) { /* promote to string */
3712 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3713 while (s < strend) {
3714 sv = mul128(sv, *s & 0x7f);
3715 if (!(*s++ & 0x80)) {
3724 PUSHs(sv_2mortal(sv));
3729 if ((s >= strend) && bytes)
3730 croak("Unterminated compressed integer");
3735 if (sizeof(char*) > strend - s)
3738 Copy(s, &aptr, 1, char*);
3743 sv_setpvn(sv, aptr, len);
3744 PUSHs(sv_2mortal(sv));
3748 along = (strend - s) / sizeof(Quad_t);
3754 if (s + sizeof(Quad_t) > strend)
3757 Copy(s, &aquad, 1, Quad_t);
3758 s += sizeof(Quad_t);
3761 if (aquad >= IV_MIN && aquad <= IV_MAX)
3762 sv_setiv(sv, (IV)aquad);
3764 sv_setnv(sv, (double)aquad);
3765 PUSHs(sv_2mortal(sv));
3769 along = (strend - s) / sizeof(Quad_t);
3775 if (s + sizeof(Uquad_t) > strend)
3778 Copy(s, &auquad, 1, Uquad_t);
3779 s += sizeof(Uquad_t);
3782 if (auquad <= UV_MAX)
3783 sv_setuv(sv, (UV)auquad);
3785 sv_setnv(sv, (double)auquad);
3786 PUSHs(sv_2mortal(sv));
3790 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3793 along = (strend - s) / sizeof(float);
3798 Copy(s, &afloat, 1, float);
3807 Copy(s, &afloat, 1, float);
3810 sv_setnv(sv, (double)afloat);
3811 PUSHs(sv_2mortal(sv));
3817 along = (strend - s) / sizeof(double);
3822 Copy(s, &adouble, 1, double);
3823 s += sizeof(double);
3831 Copy(s, &adouble, 1, double);
3832 s += sizeof(double);
3834 sv_setnv(sv, (double)adouble);
3835 PUSHs(sv_2mortal(sv));
3841 * Initialise the decode mapping. By using a table driven
3842 * algorithm, the code will be character-set independent
3843 * (and just as fast as doing character arithmetic)
3845 if (uudmap['M'] == 0) {
3848 for (i = 0; i < sizeof(uuemap); i += 1)
3849 uudmap[uuemap[i]] = i;
3851 * Because ' ' and '`' map to the same value,
3852 * we need to decode them both the same.
3857 along = (strend - s) * 3 / 4;
3858 sv = NEWSV(42, along);
3861 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3866 len = uudmap[*s++] & 077;
3868 if (s < strend && ISUUCHAR(*s))
3869 a = uudmap[*s++] & 077;
3872 if (s < strend && ISUUCHAR(*s))
3873 b = uudmap[*s++] & 077;
3876 if (s < strend && ISUUCHAR(*s))
3877 c = uudmap[*s++] & 077;
3880 if (s < strend && ISUUCHAR(*s))
3881 d = uudmap[*s++] & 077;
3884 hunk[0] = (a << 2) | (b >> 4);
3885 hunk[1] = (b << 4) | (c >> 2);
3886 hunk[2] = (c << 6) | d;
3887 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3892 else if (s[1] == '\n') /* possible checksum byte */
3895 XPUSHs(sv_2mortal(sv));
3900 if (strchr("fFdD", datumtype) ||
3901 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3905 while (checksum >= 16) {
3909 while (checksum >= 4) {
3915 along = (1 << checksum) - 1;
3916 while (cdouble < 0.0)
3918 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3919 sv_setnv(sv, cdouble);
3922 if (checksum < 32) {
3923 aulong = (1 << checksum) - 1;
3926 sv_setuv(sv, (UV)culong);
3928 XPUSHs(sv_2mortal(sv));
3932 if (SP == oldsp && gimme == G_SCALAR)
3933 PUSHs(&PL_sv_undef);
3938 doencodes(register SV *sv, register char *s, register I32 len)
3942 *hunk = uuemap[len];
3943 sv_catpvn(sv, hunk, 1);
3946 hunk[0] = uuemap[(077 & (*s >> 2))];
3947 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3948 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3949 hunk[3] = uuemap[(077 & (s[2] & 077))];
3950 sv_catpvn(sv, hunk, 4);
3955 char r = (len > 1 ? s[1] : '\0');
3956 hunk[0] = uuemap[(077 & (*s >> 2))];
3957 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3958 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3959 hunk[3] = uuemap[0];
3960 sv_catpvn(sv, hunk, 4);
3962 sv_catpvn(sv, "\n", 1);
3966 is_an_int(char *s, STRLEN l)
3969 SV *result = newSVpv("", l);
3970 char *result_c = SvPV(result, n_a); /* convenience */
3971 char *out = result_c;
3981 SvREFCNT_dec(result);
4004 SvREFCNT_dec(result);
4010 SvCUR_set(result, out - result_c);
4015 div128(SV *pnum, bool *done)
4016 /* must be '\0' terminated */
4020 char *s = SvPV(pnum, len);
4029 i = m * 10 + (*t - '0');
4031 r = (i >> 7); /* r < 10 */
4038 SvCUR_set(pnum, (STRLEN) (t - s));
4045 djSP; dMARK; dORIGMARK; dTARGET;
4046 register SV *cat = TARG;
4049 register char *pat = SvPVx(*++MARK, fromlen);
4050 register char *patend = pat + fromlen;
4055 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4056 static char *space10 = " ";
4058 /* These must not be in registers: */
4076 sv_setpvn(cat, "", 0);
4077 while (pat < patend) {
4078 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4079 datumtype = *pat++ & 0xFF;
4080 if (isSPACE(datumtype))
4083 len = strchr("@Xxu", datumtype) ? 0 : items;
4086 else if (isDIGIT(*pat)) {
4088 while (isDIGIT(*pat))
4089 len = (len * 10) + (*pat++ - '0');
4095 croak("Invalid type in pack: '%c'", (int)datumtype);
4096 case ',': /* grandfather in commas but with a warning */
4097 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4098 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4101 DIE("%% may only be used in unpack");
4112 if (SvCUR(cat) < len)
4113 DIE("X outside of string");
4120 sv_catpvn(cat, null10, 10);
4123 sv_catpvn(cat, null10, len);
4128 aptr = SvPV(fromstr, fromlen);
4132 sv_catpvn(cat, aptr, len);
4134 sv_catpvn(cat, aptr, fromlen);
4136 if (datumtype == 'A') {
4138 sv_catpvn(cat, space10, 10);
4141 sv_catpvn(cat, space10, len);
4145 sv_catpvn(cat, null10, 10);
4148 sv_catpvn(cat, null10, len);
4155 char *savepat = pat;
4160 aptr = SvPV(fromstr, fromlen);
4165 SvCUR(cat) += (len+7)/8;
4166 SvGROW(cat, SvCUR(cat) + 1);
4167 aptr = SvPVX(cat) + aint;
4172 if (datumtype == 'B') {
4173 for (len = 0; len++ < aint;) {
4174 items |= *pat++ & 1;
4178 *aptr++ = items & 0xff;
4184 for (len = 0; len++ < aint;) {
4190 *aptr++ = items & 0xff;
4196 if (datumtype == 'B')
4197 items <<= 7 - (aint & 7);
4199 items >>= 7 - (aint & 7);
4200 *aptr++ = items & 0xff;
4202 pat = SvPVX(cat) + SvCUR(cat);
4213 char *savepat = pat;
4218 aptr = SvPV(fromstr, fromlen);
4223 SvCUR(cat) += (len+1)/2;
4224 SvGROW(cat, SvCUR(cat) + 1);
4225 aptr = SvPVX(cat) + aint;
4230 if (datumtype == 'H') {
4231 for (len = 0; len++ < aint;) {
4233 items |= ((*pat++ & 15) + 9) & 15;
4235 items |= *pat++ & 15;
4239 *aptr++ = items & 0xff;
4245 for (len = 0; len++ < aint;) {
4247 items |= (((*pat++ & 15) + 9) & 15) << 4;
4249 items |= (*pat++ & 15) << 4;
4253 *aptr++ = items & 0xff;
4259 *aptr++ = items & 0xff;
4260 pat = SvPVX(cat) + SvCUR(cat);
4272 aint = SvIV(fromstr);
4274 sv_catpvn(cat, &achar, sizeof(char));
4280 auint = SvUV(fromstr);
4281 SvGROW(cat, SvCUR(cat) + 10);
4282 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4287 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4292 afloat = (float)SvNV(fromstr);
4293 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4300 adouble = (double)SvNV(fromstr);
4301 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4307 ashort = (I16)SvIV(fromstr);
4309 ashort = PerlSock_htons(ashort);
4311 CAT16(cat, &ashort);
4317 ashort = (I16)SvIV(fromstr);
4319 ashort = htovs(ashort);
4321 CAT16(cat, &ashort);
4328 ashort = (I16)SvIV(fromstr);
4329 CAT16(cat, &ashort);
4335 auint = SvUV(fromstr);
4336 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4342 adouble = floor(SvNV(fromstr));
4345 croak("Cannot compress negative numbers");
4351 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4352 adouble <= UV_MAX_cxux
4359 char buf[1 + sizeof(UV)];
4360 char *in = buf + sizeof(buf);
4361 UV auv = U_V(adouble);;
4364 *--in = (auv & 0x7f) | 0x80;
4367 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4368 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4370 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4371 char *from, *result, *in;
4376 /* Copy string and check for compliance */
4377 from = SvPV(fromstr, len);
4378 if ((norm = is_an_int(from, len)) == NULL)
4379 croak("can compress only unsigned integer");
4381 New('w', result, len, char);
4385 *--in = div128(norm, &done) | 0x80;
4386 result[len - 1] &= 0x7F; /* clear continue bit */
4387 sv_catpvn(cat, in, (result + len) - in);
4389 SvREFCNT_dec(norm); /* free norm */
4391 else if (SvNOKp(fromstr)) {
4392 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4393 char *in = buf + sizeof(buf);
4396 double next = floor(adouble / 128);
4397 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4398 if (--in < buf) /* this cannot happen ;-) */
4399 croak ("Cannot compress integer");
4401 } while (adouble > 0);
4402 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4403 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4406 croak("Cannot compress non integer");
4412 aint = SvIV(fromstr);
4413 sv_catpvn(cat, (char*)&aint, sizeof(int));
4419 aulong = SvUV(fromstr);
4421 aulong = PerlSock_htonl(aulong);
4423 CAT32(cat, &aulong);
4429 aulong = SvUV(fromstr);
4431 aulong = htovl(aulong);
4433 CAT32(cat, &aulong);
4439 aulong = SvUV(fromstr);
4440 CAT32(cat, &aulong);
4446 along = SvIV(fromstr);
4454 auquad = (Uquad_t)SvIV(fromstr);
4455 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4461 aquad = (Quad_t)SvIV(fromstr);
4462 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4465 #endif /* HAS_QUAD */
4467 len = 1; /* assume SV is correct length */
4472 if (fromstr == &PL_sv_undef)
4476 /* XXX better yet, could spirit away the string to
4477 * a safe spot and hang on to it until the result
4478 * of pack() (and all copies of the result) are
4481 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4483 "Attempt to pack pointer to temporary value");
4484 if (SvPOK(fromstr) || SvNIOK(fromstr))
4485 aptr = SvPV(fromstr,n_a);
4487 aptr = SvPV_force(fromstr,n_a);
4489 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4494 aptr = SvPV(fromstr, fromlen);
4495 SvGROW(cat, fromlen * 4 / 3);
4500 while (fromlen > 0) {
4507 doencodes(cat, aptr, todo);
4526 register I32 limit = POPi; /* note, negative is forever */
4529 register char *s = SvPV(sv, len);
4530 char *strend = s + len;
4532 register REGEXP *rx;
4536 I32 maxiters = (strend - s) + 10;
4539 I32 origlimit = limit;
4542 AV *oldstack = PL_curstack;
4543 I32 gimme = GIMME_V;
4544 I32 oldsave = PL_savestack_ix;
4545 I32 make_mortal = 1;
4546 MAGIC *mg = (MAGIC *) NULL;
4549 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4554 DIE("panic: do_split");
4555 rx = pm->op_pmregexp;
4557 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4558 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4560 if (pm->op_pmreplroot)
4561 ary = GvAVn((GV*)pm->op_pmreplroot);
4562 else if (gimme != G_ARRAY)
4564 ary = (AV*)PL_curpad[0];
4566 ary = GvAVn(PL_defgv);
4567 #endif /* USE_THREADS */
4570 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4576 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4578 XPUSHs(SvTIED_obj((SV*)ary, mg));
4583 for (i = AvFILLp(ary); i >= 0; i--)
4584 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4586 /* temporarily switch stacks */
4587 SWITCHSTACK(PL_curstack, ary);
4591 base = SP - PL_stack_base;
4593 if (pm->op_pmflags & PMf_SKIPWHITE) {
4594 if (pm->op_pmflags & PMf_LOCALE) {
4595 while (isSPACE_LC(*s))
4603 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4604 SAVEINT(PL_multiline);
4605 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4609 limit = maxiters + 2;
4610 if (pm->op_pmflags & PMf_WHITE) {
4613 while (m < strend &&
4614 !((pm->op_pmflags & PMf_LOCALE)
4615 ? isSPACE_LC(*m) : isSPACE(*m)))
4620 dstr = NEWSV(30, m-s);
4621 sv_setpvn(dstr, s, m-s);
4627 while (s < strend &&
4628 ((pm->op_pmflags & PMf_LOCALE)
4629 ? isSPACE_LC(*s) : isSPACE(*s)))
4633 else if (strEQ("^", rx->precomp)) {
4636 for (m = s; m < strend && *m != '\n'; m++) ;
4640 dstr = NEWSV(30, m-s);
4641 sv_setpvn(dstr, s, m-s);
4648 else if (rx->check_substr && !rx->nparens
4649 && (rx->reganch & ROPT_CHECK_ALL)
4650 && !(rx->reganch & ROPT_ANCH)) {
4651 i = SvCUR(rx->check_substr);
4652 if (i == 1 && !SvTAIL(rx->check_substr)) {
4653 i = *SvPVX(rx->check_substr);
4656 for (m = s; m < strend && *m != i; m++) ;
4659 dstr = NEWSV(30, m-s);
4660 sv_setpvn(dstr, s, m-s);
4669 while (s < strend && --limit &&
4670 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4671 rx->check_substr, 0)) )
4674 dstr = NEWSV(31, m-s);
4675 sv_setpvn(dstr, s, m-s);
4684 maxiters += (strend - s) * rx->nparens;
4685 while (s < strend && --limit &&
4686 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4688 TAINT_IF(RX_MATCH_TAINTED(rx));
4690 && rx->subbase != orig) {
4695 strend = s + (strend - m);
4698 dstr = NEWSV(32, m-s);
4699 sv_setpvn(dstr, s, m-s);
4704 for (i = 1; i <= rx->nparens; i++) {
4708 dstr = NEWSV(33, m-s);
4709 sv_setpvn(dstr, s, m-s);
4712 dstr = NEWSV(33, 0);
4722 LEAVE_SCOPE(oldsave);
4723 iters = (SP - PL_stack_base) - base;
4724 if (iters > maxiters)
4727 /* keep field after final delim? */
4728 if (s < strend || (iters && origlimit)) {
4729 dstr = NEWSV(34, strend-s);
4730 sv_setpvn(dstr, s, strend-s);
4736 else if (!origlimit) {
4737 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4743 SWITCHSTACK(ary, oldstack);
4744 if (SvSMAGICAL(ary)) {
4749 if (gimme == G_ARRAY) {
4751 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4759 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4762 if (gimme == G_ARRAY) {
4763 /* EXTEND should not be needed - we just popped them */
4765 for (i=0; i < iters; i++) {
4766 SV **svp = av_fetch(ary, i, FALSE);
4767 PUSHs((svp) ? *svp : &PL_sv_undef);
4774 if (gimme == G_ARRAY)
4777 if (iters || !pm->op_pmreplroot) {
4787 unlock_condpair(void *svv)
4790 MAGIC *mg = mg_find((SV*)svv, 'm');
4793 croak("panic: unlock_condpair unlocking non-mutex");
4794 MUTEX_LOCK(MgMUTEXP(mg));
4795 if (MgOWNER(mg) != thr)
4796 croak("panic: unlock_condpair unlocking mutex that we don't own");
4798 COND_SIGNAL(MgOWNERCONDP(mg));
4799 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4800 (unsigned long)thr, (unsigned long)svv);)
4801 MUTEX_UNLOCK(MgMUTEXP(mg));
4803 #endif /* USE_THREADS */
4816 mg = condpair_magic(sv);
4817 MUTEX_LOCK(MgMUTEXP(mg));
4818 if (MgOWNER(mg) == thr)
4819 MUTEX_UNLOCK(MgMUTEXP(mg));
4822 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4824 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4825 (unsigned long)thr, (unsigned long)sv);)
4826 MUTEX_UNLOCK(MgMUTEXP(mg));
4827 save_destructor(unlock_condpair, sv);
4829 #endif /* USE_THREADS */
4830 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4831 || SvTYPE(retsv) == SVt_PVCV) {
4832 retsv = refto(retsv);
4843 if (PL_op->op_private & OPpLVAL_INTRO)
4844 PUSHs(*save_threadsv(PL_op->op_targ));
4846 PUSHs(THREADSV(PL_op->op_targ));
4849 DIE("tried to access per-thread data in non-threaded perl");
4850 #endif /* USE_THREADS */