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);
1826 value = scan_oct(tmps, 99, &argtype);
1838 SETi( sv_len_utf8(TOPs) );
1842 SETi( sv_len(TOPs) );
1856 I32 lvalue = PL_op->op_flags & OPf_MOD;
1858 I32 arybase = PL_curcop->cop_arybase;
1862 SvTAINTED_off(TARG); /* decontaminate */
1866 repl = SvPV(sv, repl_len);
1873 tmps = SvPV(sv, curlen);
1875 utfcurlen = sv_len_utf8(sv);
1876 if (utfcurlen == curlen)
1884 if (pos >= arybase) {
1902 else if (len >= 0) {
1904 if (rem > (I32)curlen)
1918 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1919 warner(WARN_SUBSTR, "substr outside of string");
1924 sv_pos_u2b(sv, &pos, &rem);
1926 sv_setpvn(TARG, tmps, rem);
1927 if (lvalue) { /* it's an lvalue! */
1928 if (!SvGMAGICAL(sv)) {
1932 if (ckWARN(WARN_SUBSTR))
1934 "Attempt to use reference as lvalue in substr");
1936 if (SvOK(sv)) /* is it defined ? */
1937 (void)SvPOK_only(sv);
1939 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1942 if (SvTYPE(TARG) < SVt_PVLV) {
1943 sv_upgrade(TARG, SVt_PVLV);
1944 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1948 if (LvTARG(TARG) != sv) {
1950 SvREFCNT_dec(LvTARG(TARG));
1951 LvTARG(TARG) = SvREFCNT_inc(sv);
1953 LvTARGOFF(TARG) = pos;
1954 LvTARGLEN(TARG) = rem;
1957 sv_insert(sv, pos, rem, repl, repl_len);
1960 PUSHs(TARG); /* avoid SvSETMAGIC here */
1967 register I32 size = POPi;
1968 register I32 offset = POPi;
1969 register SV *src = POPs;
1970 I32 lvalue = PL_op->op_flags & OPf_MOD;
1972 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1973 unsigned long retnum;
1976 SvTAINTED_off(TARG); /* decontaminate */
1977 offset *= size; /* turn into bit offset */
1978 len = (offset + size + 7) / 8;
1979 if (offset < 0 || size < 1)
1982 if (lvalue) { /* it's an lvalue! */
1983 if (SvTYPE(TARG) < SVt_PVLV) {
1984 sv_upgrade(TARG, SVt_PVLV);
1985 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1989 if (LvTARG(TARG) != src) {
1991 SvREFCNT_dec(LvTARG(TARG));
1992 LvTARG(TARG) = SvREFCNT_inc(src);
1994 LvTARGOFF(TARG) = offset;
1995 LvTARGLEN(TARG) = size;
2003 if (offset >= srclen)
2006 retnum = (unsigned long) s[offset] << 8;
2008 else if (size == 32) {
2009 if (offset >= srclen)
2011 else if (offset + 1 >= srclen)
2012 retnum = (unsigned long) s[offset] << 24;
2013 else if (offset + 2 >= srclen)
2014 retnum = ((unsigned long) s[offset] << 24) +
2015 ((unsigned long) s[offset + 1] << 16);
2017 retnum = ((unsigned long) s[offset] << 24) +
2018 ((unsigned long) s[offset + 1] << 16) +
2019 (s[offset + 2] << 8);
2024 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2029 else if (size == 16)
2030 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2031 else if (size == 32)
2032 retnum = ((unsigned long) s[offset] << 24) +
2033 ((unsigned long) s[offset + 1] << 16) +
2034 (s[offset + 2] << 8) + s[offset+3];
2038 sv_setuv(TARG, (UV)retnum);
2053 I32 arybase = PL_curcop->cop_arybase;
2058 offset = POPi - arybase;
2061 tmps = SvPV(big, biglen);
2062 if (IN_UTF8 && offset > 0)
2063 sv_pos_u2b(big, &offset, 0);
2066 else if (offset > biglen)
2068 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2069 (unsigned char*)tmps + biglen, little, 0)))
2072 retval = tmps2 - tmps;
2073 if (IN_UTF8 && retval > 0)
2074 sv_pos_b2u(big, &retval);
2075 PUSHi(retval + arybase);
2090 I32 arybase = PL_curcop->cop_arybase;
2096 tmps2 = SvPV(little, llen);
2097 tmps = SvPV(big, blen);
2101 if (IN_UTF8 && offset > 0)
2102 sv_pos_u2b(big, &offset, 0);
2103 offset = offset - arybase + llen;
2107 else if (offset > blen)
2109 if (!(tmps2 = rninstr(tmps, tmps + offset,
2110 tmps2, tmps2 + llen)))
2113 retval = tmps2 - tmps;
2114 if (IN_UTF8 && retval > 0)
2115 sv_pos_b2u(big, &retval);
2116 PUSHi(retval + arybase);
2122 djSP; dMARK; dORIGMARK; dTARGET;
2123 #ifdef USE_LOCALE_NUMERIC
2124 if (PL_op->op_private & OPpLOCALE)
2125 SET_NUMERIC_LOCAL();
2127 SET_NUMERIC_STANDARD();
2129 do_sprintf(TARG, SP-MARK, MARK+1);
2130 TAINT_IF(SvTAINTED(TARG));
2141 U8 *tmps = (U8*)POPpx;
2144 if (IN_UTF8 && (*tmps & 0x80))
2145 value = utf8_to_uv(tmps, &retlen);
2147 value = (UV)(*tmps & 255);
2158 (void)SvUPGRADE(TARG,SVt_PV);
2160 if (IN_UTF8 && value >= 128) {
2163 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2164 SvCUR_set(TARG, tmps - SvPVX(TARG));
2166 (void)SvPOK_only(TARG);
2176 (void)SvPOK_only(TARG);
2183 djSP; dTARGET; dPOPTOPssrl;
2186 char *tmps = SvPV(left, n_a);
2188 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2190 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2194 "The crypt() function is unimplemented due to excessive paranoia.");
2207 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2211 UV uv = utf8_to_uv(s, &ulen);
2213 if (PL_op->op_private & OPpLOCALE) {
2216 uv = toTITLE_LC_uni(uv);
2219 uv = toTITLE_utf8(s);
2221 tend = uv_to_utf8(tmpbuf, uv);
2223 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2225 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2226 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2230 s = (U8*)SvPV_force(sv, slen);
2231 Copy(tmpbuf, s, ulen, U8);
2236 if (!SvPADTMP(sv)) {
2242 s = (U8*)SvPV_force(sv, slen);
2244 if (PL_op->op_private & OPpLOCALE) {
2247 *s = toUPPER_LC(*s);
2263 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2267 UV uv = utf8_to_uv(s, &ulen);
2269 if (PL_op->op_private & OPpLOCALE) {
2272 uv = toLOWER_LC_uni(uv);
2275 uv = toLOWER_utf8(s);
2277 tend = uv_to_utf8(tmpbuf, uv);
2279 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2281 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2282 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2286 s = (U8*)SvPV_force(sv, slen);
2287 Copy(tmpbuf, s, ulen, U8);
2292 if (!SvPADTMP(sv)) {
2298 s = (U8*)SvPV_force(sv, slen);
2300 if (PL_op->op_private & OPpLOCALE) {
2303 *s = toLOWER_LC(*s);
2326 s = (U8*)SvPV(sv,len);
2328 sv_setpvn(TARG, "", 0);
2333 (void)SvUPGRADE(TARG, SVt_PV);
2334 SvGROW(TARG, (len * 2) + 1);
2335 (void)SvPOK_only(TARG);
2336 d = (U8*)SvPVX(TARG);
2338 if (PL_op->op_private & OPpLOCALE) {
2342 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2348 d = uv_to_utf8(d, toUPPER_utf8( s ));
2353 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2358 if (!SvPADTMP(sv)) {
2365 s = (U8*)SvPV_force(sv, len);
2367 register U8 *send = s + len;
2369 if (PL_op->op_private & OPpLOCALE) {
2372 for (; s < send; s++)
2373 *s = toUPPER_LC(*s);
2376 for (; s < send; s++)
2396 s = (U8*)SvPV(sv,len);
2398 sv_setpvn(TARG, "", 0);
2403 (void)SvUPGRADE(TARG, SVt_PV);
2404 SvGROW(TARG, (len * 2) + 1);
2405 (void)SvPOK_only(TARG);
2406 d = (U8*)SvPVX(TARG);
2408 if (PL_op->op_private & OPpLOCALE) {
2412 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2418 d = uv_to_utf8(d, toLOWER_utf8(s));
2423 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2428 if (!SvPADTMP(sv)) {
2435 s = (U8*)SvPV_force(sv, len);
2437 register U8 *send = s + len;
2439 if (PL_op->op_private & OPpLOCALE) {
2442 for (; s < send; s++)
2443 *s = toLOWER_LC(*s);
2446 for (; s < send; s++)
2458 register char *s = SvPV(sv,len);
2462 (void)SvUPGRADE(TARG, SVt_PV);
2463 SvGROW(TARG, (len * 2) + 1);
2468 STRLEN ulen = UTF8SKIP(s);
2491 SvCUR_set(TARG, d - SvPVX(TARG));
2492 (void)SvPOK_only(TARG);
2495 sv_setpvn(TARG, s, len);
2504 djSP; dMARK; dORIGMARK;
2506 register AV* av = (AV*)POPs;
2507 register I32 lval = PL_op->op_flags & OPf_MOD;
2508 I32 arybase = PL_curcop->cop_arybase;
2511 if (SvTYPE(av) == SVt_PVAV) {
2512 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2514 for (svp = MARK + 1; svp <= SP; svp++) {
2519 if (max > AvMAX(av))
2522 while (++MARK <= SP) {
2523 elem = SvIVx(*MARK);
2527 svp = av_fetch(av, elem, lval);
2529 if (!svp || *svp == &PL_sv_undef)
2530 DIE(PL_no_aelem, elem);
2531 if (PL_op->op_private & OPpLVAL_INTRO)
2532 save_aelem(av, elem, svp);
2534 *MARK = svp ? *svp : &PL_sv_undef;
2537 if (GIMME != G_ARRAY) {
2545 /* Associative arrays. */
2550 HV *hash = (HV*)POPs;
2552 I32 gimme = GIMME_V;
2553 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2556 /* might clobber stack_sp */
2557 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2562 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2563 if (gimme == G_ARRAY) {
2565 /* might clobber stack_sp */
2566 sv_setsv(TARG, realhv ?
2567 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2572 else if (gimme == G_SCALAR)
2591 I32 gimme = GIMME_V;
2592 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2596 if (PL_op->op_private & OPpSLICE) {
2600 hvtype = SvTYPE(hv);
2601 while (++MARK <= SP) {
2602 if (hvtype == SVt_PVHV)
2603 sv = hv_delete_ent(hv, *MARK, discard, 0);
2605 DIE("Not a HASH reference");
2606 *MARK = sv ? sv : &PL_sv_undef;
2610 else if (gimme == G_SCALAR) {
2619 if (SvTYPE(hv) == SVt_PVHV)
2620 sv = hv_delete_ent(hv, keysv, discard, 0);
2622 DIE("Not a HASH reference");
2636 if (SvTYPE(hv) == SVt_PVHV) {
2637 if (hv_exists_ent(hv, tmpsv, 0))
2639 } else if (SvTYPE(hv) == SVt_PVAV) {
2640 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2643 DIE("Not a HASH reference");
2650 djSP; dMARK; dORIGMARK;
2651 register HV *hv = (HV*)POPs;
2652 register I32 lval = PL_op->op_flags & OPf_MOD;
2653 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2655 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2656 DIE("Can't localize pseudo-hash element");
2658 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2659 while (++MARK <= SP) {
2663 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2664 svp = he ? &HeVAL(he) : 0;
2666 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2669 if (!svp || *svp == &PL_sv_undef) {
2671 DIE(PL_no_helem, SvPV(keysv, n_a));
2673 if (PL_op->op_private & OPpLVAL_INTRO)
2674 save_helem(hv, keysv, svp);
2676 *MARK = svp ? *svp : &PL_sv_undef;
2679 if (GIMME != G_ARRAY) {
2687 /* List operators. */
2692 if (GIMME != G_ARRAY) {
2694 *MARK = *SP; /* unwanted list, return last item */
2696 *MARK = &PL_sv_undef;
2705 SV **lastrelem = PL_stack_sp;
2706 SV **lastlelem = PL_stack_base + POPMARK;
2707 SV **firstlelem = PL_stack_base + POPMARK + 1;
2708 register SV **firstrelem = lastlelem + 1;
2709 I32 arybase = PL_curcop->cop_arybase;
2710 I32 lval = PL_op->op_flags & OPf_MOD;
2711 I32 is_something_there = lval;
2713 register I32 max = lastrelem - lastlelem;
2714 register SV **lelem;
2717 if (GIMME != G_ARRAY) {
2718 ix = SvIVx(*lastlelem);
2723 if (ix < 0 || ix >= max)
2724 *firstlelem = &PL_sv_undef;
2726 *firstlelem = firstrelem[ix];
2732 SP = firstlelem - 1;
2736 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2741 *lelem = &PL_sv_undef;
2742 else if (!(*lelem = firstrelem[ix]))
2743 *lelem = &PL_sv_undef;
2747 if (ix >= max || !(*lelem = firstrelem[ix]))
2748 *lelem = &PL_sv_undef;
2750 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2751 is_something_there = TRUE;
2753 if (is_something_there)
2756 SP = firstlelem - 1;
2762 djSP; dMARK; dORIGMARK;
2763 I32 items = SP - MARK;
2764 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2765 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2772 djSP; dMARK; dORIGMARK;
2773 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2777 SV *val = NEWSV(46, 0);
2779 sv_setsv(val, *++MARK);
2780 else if (ckWARN(WARN_UNSAFE))
2781 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2782 (void)hv_store_ent(hv,key,val,0);
2791 djSP; dMARK; dORIGMARK;
2792 register AV *ary = (AV*)*++MARK;
2796 register I32 offset;
2797 register I32 length;
2804 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2805 *MARK-- = SvTIED_obj((SV*)ary, mg);
2809 perl_call_method("SPLICE",GIMME_V);
2818 offset = i = SvIVx(*MARK);
2820 offset += AvFILLp(ary) + 1;
2822 offset -= PL_curcop->cop_arybase;
2824 DIE(PL_no_aelem, i);
2826 length = SvIVx(*MARK++);
2828 length += AvFILLp(ary) - offset + 1;
2834 length = AvMAX(ary) + 1; /* close enough to infinity */
2838 length = AvMAX(ary) + 1;
2840 if (offset > AvFILLp(ary) + 1)
2841 offset = AvFILLp(ary) + 1;
2842 after = AvFILLp(ary) + 1 - (offset + length);
2843 if (after < 0) { /* not that much array */
2844 length += after; /* offset+length now in array */
2850 /* At this point, MARK .. SP-1 is our new LIST */
2853 diff = newlen - length;
2854 if (newlen && !AvREAL(ary)) {
2858 assert(AvREAL(ary)); /* would leak, so croak */
2861 if (diff < 0) { /* shrinking the area */
2863 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2864 Copy(MARK, tmparyval, newlen, SV*);
2867 MARK = ORIGMARK + 1;
2868 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2869 MEXTEND(MARK, length);
2870 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2872 EXTEND_MORTAL(length);
2873 for (i = length, dst = MARK; i; i--) {
2874 sv_2mortal(*dst); /* free them eventualy */
2881 *MARK = AvARRAY(ary)[offset+length-1];
2884 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2885 SvREFCNT_dec(*dst++); /* free them now */
2888 AvFILLp(ary) += diff;
2890 /* pull up or down? */
2892 if (offset < after) { /* easier to pull up */
2893 if (offset) { /* esp. if nothing to pull */
2894 src = &AvARRAY(ary)[offset-1];
2895 dst = src - diff; /* diff is negative */
2896 for (i = offset; i > 0; i--) /* can't trust Copy */
2900 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2904 if (after) { /* anything to pull down? */
2905 src = AvARRAY(ary) + offset + length;
2906 dst = src + diff; /* diff is negative */
2907 Move(src, dst, after, SV*);
2909 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2910 /* avoid later double free */
2914 dst[--i] = &PL_sv_undef;
2917 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2919 *dst = NEWSV(46, 0);
2920 sv_setsv(*dst++, *src++);
2922 Safefree(tmparyval);
2925 else { /* no, expanding (or same) */
2927 New(452, tmparyval, length, SV*); /* so remember deletion */
2928 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2931 if (diff > 0) { /* expanding */
2933 /* push up or down? */
2935 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2939 Move(src, dst, offset, SV*);
2941 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2943 AvFILLp(ary) += diff;
2946 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2947 av_extend(ary, AvFILLp(ary) + diff);
2948 AvFILLp(ary) += diff;
2951 dst = AvARRAY(ary) + AvFILLp(ary);
2953 for (i = after; i; i--) {
2960 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2961 *dst = NEWSV(46, 0);
2962 sv_setsv(*dst++, *src++);
2964 MARK = ORIGMARK + 1;
2965 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2967 Copy(tmparyval, MARK, length, SV*);
2969 EXTEND_MORTAL(length);
2970 for (i = length, dst = MARK; i; i--) {
2971 sv_2mortal(*dst); /* free them eventualy */
2975 Safefree(tmparyval);
2979 else if (length--) {
2980 *MARK = tmparyval[length];
2983 while (length-- > 0)
2984 SvREFCNT_dec(tmparyval[length]);
2986 Safefree(tmparyval);
2989 *MARK = &PL_sv_undef;
2997 djSP; dMARK; dORIGMARK; dTARGET;
2998 register AV *ary = (AV*)*++MARK;
2999 register SV *sv = &PL_sv_undef;
3002 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3003 *MARK-- = SvTIED_obj((SV*)ary, mg);
3007 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3012 /* Why no pre-extend of ary here ? */
3013 for (++MARK; MARK <= SP; MARK++) {
3016 sv_setsv(sv, *MARK);
3021 PUSHi( AvFILL(ary) + 1 );
3029 SV *sv = av_pop(av);
3031 (void)sv_2mortal(sv);
3040 SV *sv = av_shift(av);
3045 (void)sv_2mortal(sv);
3052 djSP; dMARK; dORIGMARK; dTARGET;
3053 register AV *ary = (AV*)*++MARK;
3058 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3059 *MARK-- = SvTIED_obj((SV*)ary, mg);
3063 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3068 av_unshift(ary, SP - MARK);
3071 sv_setsv(sv, *++MARK);
3072 (void)av_store(ary, i++, sv);
3076 PUSHi( AvFILL(ary) + 1 );
3086 if (GIMME == G_ARRAY) {
3097 register char *down;
3103 do_join(TARG, &PL_sv_no, MARK, SP);
3105 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3106 up = SvPV_force(TARG, len);
3108 if (IN_UTF8) { /* first reverse each character */
3109 U8* s = (U8*)SvPVX(TARG);
3110 U8* send = (U8*)(s + len);
3119 down = (char*)(s - 1);
3120 if (s > send || !((*down & 0xc0) == 0x80)) {
3121 warn("Malformed UTF-8 character");
3133 down = SvPVX(TARG) + len - 1;
3139 (void)SvPOK_only(TARG);
3148 mul128(SV *sv, U8 m)
3151 char *s = SvPV(sv, len);
3155 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3156 SV *tmpNew = newSVpv("0000000000", 10);
3158 sv_catsv(tmpNew, sv);
3159 SvREFCNT_dec(sv); /* free old sv */
3164 while (!*t) /* trailing '\0'? */
3167 i = ((*t - '0') << 7) + m;
3168 *(t--) = '0' + (i % 10);
3174 /* Explosives and implosives. */
3176 static const char uuemap[] =
3177 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3178 static char uudmap[256]; /* Initialised on first use */
3179 #if 'I' == 73 && 'J' == 74
3180 /* On an ASCII/ISO kind of system */
3181 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3184 Some other sort of character set - use memchr() so we don't match
3187 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3195 I32 gimme = GIMME_V;
3199 register char *pat = SvPV(left, llen);
3200 register char *s = SvPV(right, rlen);
3201 char *strend = s + rlen;
3203 register char *patend = pat + llen;
3208 /* These must not be in registers: */
3225 register U32 culong;
3227 static char* bitcount = 0;
3230 if (gimme != G_ARRAY) { /* arrange to do first one only */
3232 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3233 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3235 while (isDIGIT(*patend) || *patend == '*')
3241 while (pat < patend) {
3243 datumtype = *pat++ & 0xFF;
3244 if (isSPACE(datumtype))
3248 else if (*pat == '*') {
3249 len = strend - strbeg; /* long enough */
3252 else if (isDIGIT(*pat)) {
3254 while (isDIGIT(*pat))
3255 len = (len * 10) + (*pat++ - '0');
3258 len = (datumtype != '@');
3261 croak("Invalid type in unpack: '%c'", (int)datumtype);
3262 case ',': /* grandfather in commas but with a warning */
3263 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3264 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3267 if (len == 1 && pat[-1] != '1')
3276 if (len > strend - strbeg)
3277 DIE("@ outside of string");
3281 if (len > s - strbeg)
3282 DIE("X outside of string");
3286 if (len > strend - s)
3287 DIE("x outside of string");
3292 if (len > strend - s)
3295 goto uchar_checksum;
3296 sv = NEWSV(35, len);
3297 sv_setpvn(sv, s, len);
3299 if (datumtype == 'A') {
3300 aptr = s; /* borrow register */
3301 s = SvPVX(sv) + len - 1;
3302 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3305 SvCUR_set(sv, s - SvPVX(sv));
3306 s = aptr; /* unborrow register */
3308 XPUSHs(sv_2mortal(sv));
3312 if (pat[-1] == '*' || len > (strend - s) * 8)
3313 len = (strend - s) * 8;
3316 Newz(601, bitcount, 256, char);
3317 for (bits = 1; bits < 256; bits++) {
3318 if (bits & 1) bitcount[bits]++;
3319 if (bits & 2) bitcount[bits]++;
3320 if (bits & 4) bitcount[bits]++;
3321 if (bits & 8) bitcount[bits]++;
3322 if (bits & 16) bitcount[bits]++;
3323 if (bits & 32) bitcount[bits]++;
3324 if (bits & 64) bitcount[bits]++;
3325 if (bits & 128) bitcount[bits]++;
3329 culong += bitcount[*(unsigned char*)s++];
3334 if (datumtype == 'b') {
3336 if (bits & 1) culong++;
3342 if (bits & 128) culong++;
3349 sv = NEWSV(35, len + 1);
3352 aptr = pat; /* borrow register */
3354 if (datumtype == 'b') {
3356 for (len = 0; len < aint; len++) {
3357 if (len & 7) /*SUPPRESS 595*/
3361 *pat++ = '0' + (bits & 1);
3366 for (len = 0; len < aint; len++) {
3371 *pat++ = '0' + ((bits & 128) != 0);
3375 pat = aptr; /* unborrow register */
3376 XPUSHs(sv_2mortal(sv));
3380 if (pat[-1] == '*' || len > (strend - s) * 2)
3381 len = (strend - s) * 2;
3382 sv = NEWSV(35, len + 1);
3385 aptr = pat; /* borrow register */
3387 if (datumtype == 'h') {
3389 for (len = 0; len < aint; len++) {
3394 *pat++ = PL_hexdigit[bits & 15];
3399 for (len = 0; len < aint; len++) {
3404 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3408 pat = aptr; /* unborrow register */
3409 XPUSHs(sv_2mortal(sv));
3412 if (len > strend - s)
3417 if (aint >= 128) /* fake up signed chars */
3427 if (aint >= 128) /* fake up signed chars */
3430 sv_setiv(sv, (IV)aint);
3431 PUSHs(sv_2mortal(sv));
3436 if (len > strend - s)
3451 sv_setiv(sv, (IV)auint);
3452 PUSHs(sv_2mortal(sv));
3457 if (len > strend - s)
3460 while (len-- > 0 && s < strend) {
3461 auint = utf8_to_uv((U8*)s, &along);
3464 cdouble += (double)auint;
3472 while (len-- > 0 && s < strend) {
3473 auint = utf8_to_uv((U8*)s, &along);
3476 sv_setuv(sv, (UV)auint);
3477 PUSHs(sv_2mortal(sv));
3482 along = (strend - s) / SIZE16;
3499 sv_setiv(sv, (IV)ashort);
3500 PUSHs(sv_2mortal(sv));
3507 along = (strend - s) / SIZE16;
3512 COPY16(s, &aushort);
3515 if (datumtype == 'n')
3516 aushort = PerlSock_ntohs(aushort);
3519 if (datumtype == 'v')
3520 aushort = vtohs(aushort);
3529 COPY16(s, &aushort);
3533 if (datumtype == 'n')
3534 aushort = PerlSock_ntohs(aushort);
3537 if (datumtype == 'v')
3538 aushort = vtohs(aushort);
3540 sv_setiv(sv, (IV)aushort);
3541 PUSHs(sv_2mortal(sv));
3546 along = (strend - s) / sizeof(int);
3551 Copy(s, &aint, 1, int);
3554 cdouble += (double)aint;
3563 Copy(s, &aint, 1, int);
3567 /* Without the dummy below unpack("i", pack("i",-1))
3568 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3569 * cc with optimization turned on */
3571 sv_setiv(sv, (IV)aint) :
3573 sv_setiv(sv, (IV)aint);
3574 PUSHs(sv_2mortal(sv));
3579 along = (strend - s) / sizeof(unsigned int);
3584 Copy(s, &auint, 1, unsigned int);
3585 s += sizeof(unsigned int);
3587 cdouble += (double)auint;
3596 Copy(s, &auint, 1, unsigned int);
3597 s += sizeof(unsigned int);
3599 sv_setuv(sv, (UV)auint);
3600 PUSHs(sv_2mortal(sv));
3605 along = (strend - s) / SIZE32;
3613 cdouble += (double)along;
3625 sv_setiv(sv, (IV)along);
3626 PUSHs(sv_2mortal(sv));
3633 along = (strend - s) / SIZE32;
3641 if (datumtype == 'N')
3642 aulong = PerlSock_ntohl(aulong);
3645 if (datumtype == 'V')
3646 aulong = vtohl(aulong);
3649 cdouble += (double)aulong;
3661 if (datumtype == 'N')
3662 aulong = PerlSock_ntohl(aulong);
3665 if (datumtype == 'V')
3666 aulong = vtohl(aulong);
3669 sv_setuv(sv, (UV)aulong);
3670 PUSHs(sv_2mortal(sv));
3675 along = (strend - s) / sizeof(char*);
3681 if (sizeof(char*) > strend - s)
3684 Copy(s, &aptr, 1, char*);
3690 PUSHs(sv_2mortal(sv));
3700 while ((len > 0) && (s < strend)) {
3701 auv = (auv << 7) | (*s & 0x7f);
3702 if (!(*s++ & 0x80)) {
3706 PUSHs(sv_2mortal(sv));
3710 else if (++bytes >= sizeof(UV)) { /* promote to string */
3714 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3715 while (s < strend) {
3716 sv = mul128(sv, *s & 0x7f);
3717 if (!(*s++ & 0x80)) {
3726 PUSHs(sv_2mortal(sv));
3731 if ((s >= strend) && bytes)
3732 croak("Unterminated compressed integer");
3737 if (sizeof(char*) > strend - s)
3740 Copy(s, &aptr, 1, char*);
3745 sv_setpvn(sv, aptr, len);
3746 PUSHs(sv_2mortal(sv));
3750 along = (strend - s) / sizeof(Quad_t);
3756 if (s + sizeof(Quad_t) > strend)
3759 Copy(s, &aquad, 1, Quad_t);
3760 s += sizeof(Quad_t);
3763 if (aquad >= IV_MIN && aquad <= IV_MAX)
3764 sv_setiv(sv, (IV)aquad);
3766 sv_setnv(sv, (double)aquad);
3767 PUSHs(sv_2mortal(sv));
3771 along = (strend - s) / sizeof(Quad_t);
3777 if (s + sizeof(Uquad_t) > strend)
3780 Copy(s, &auquad, 1, Uquad_t);
3781 s += sizeof(Uquad_t);
3784 if (auquad <= UV_MAX)
3785 sv_setuv(sv, (UV)auquad);
3787 sv_setnv(sv, (double)auquad);
3788 PUSHs(sv_2mortal(sv));
3792 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3795 along = (strend - s) / sizeof(float);
3800 Copy(s, &afloat, 1, float);
3809 Copy(s, &afloat, 1, float);
3812 sv_setnv(sv, (double)afloat);
3813 PUSHs(sv_2mortal(sv));
3819 along = (strend - s) / sizeof(double);
3824 Copy(s, &adouble, 1, double);
3825 s += sizeof(double);
3833 Copy(s, &adouble, 1, double);
3834 s += sizeof(double);
3836 sv_setnv(sv, (double)adouble);
3837 PUSHs(sv_2mortal(sv));
3843 * Initialise the decode mapping. By using a table driven
3844 * algorithm, the code will be character-set independent
3845 * (and just as fast as doing character arithmetic)
3847 if (uudmap['M'] == 0) {
3850 for (i = 0; i < sizeof(uuemap); i += 1)
3851 uudmap[uuemap[i]] = i;
3853 * Because ' ' and '`' map to the same value,
3854 * we need to decode them both the same.
3859 along = (strend - s) * 3 / 4;
3860 sv = NEWSV(42, along);
3863 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3868 len = uudmap[*s++] & 077;
3870 if (s < strend && ISUUCHAR(*s))
3871 a = uudmap[*s++] & 077;
3874 if (s < strend && ISUUCHAR(*s))
3875 b = uudmap[*s++] & 077;
3878 if (s < strend && ISUUCHAR(*s))
3879 c = uudmap[*s++] & 077;
3882 if (s < strend && ISUUCHAR(*s))
3883 d = uudmap[*s++] & 077;
3886 hunk[0] = (a << 2) | (b >> 4);
3887 hunk[1] = (b << 4) | (c >> 2);
3888 hunk[2] = (c << 6) | d;
3889 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3894 else if (s[1] == '\n') /* possible checksum byte */
3897 XPUSHs(sv_2mortal(sv));
3902 if (strchr("fFdD", datumtype) ||
3903 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3907 while (checksum >= 16) {
3911 while (checksum >= 4) {
3917 along = (1 << checksum) - 1;
3918 while (cdouble < 0.0)
3920 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3921 sv_setnv(sv, cdouble);
3924 if (checksum < 32) {
3925 aulong = (1 << checksum) - 1;
3928 sv_setuv(sv, (UV)culong);
3930 XPUSHs(sv_2mortal(sv));
3934 if (SP == oldsp && gimme == G_SCALAR)
3935 PUSHs(&PL_sv_undef);
3940 doencodes(register SV *sv, register char *s, register I32 len)
3944 *hunk = uuemap[len];
3945 sv_catpvn(sv, hunk, 1);
3948 hunk[0] = uuemap[(077 & (*s >> 2))];
3949 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3950 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3951 hunk[3] = uuemap[(077 & (s[2] & 077))];
3952 sv_catpvn(sv, hunk, 4);
3957 char r = (len > 1 ? s[1] : '\0');
3958 hunk[0] = uuemap[(077 & (*s >> 2))];
3959 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3960 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3961 hunk[3] = uuemap[0];
3962 sv_catpvn(sv, hunk, 4);
3964 sv_catpvn(sv, "\n", 1);
3968 is_an_int(char *s, STRLEN l)
3971 SV *result = newSVpv("", l);
3972 char *result_c = SvPV(result, n_a); /* convenience */
3973 char *out = result_c;
3983 SvREFCNT_dec(result);
4006 SvREFCNT_dec(result);
4012 SvCUR_set(result, out - result_c);
4017 div128(SV *pnum, bool *done)
4018 /* must be '\0' terminated */
4022 char *s = SvPV(pnum, len);
4031 i = m * 10 + (*t - '0');
4033 r = (i >> 7); /* r < 10 */
4040 SvCUR_set(pnum, (STRLEN) (t - s));
4047 djSP; dMARK; dORIGMARK; dTARGET;
4048 register SV *cat = TARG;
4051 register char *pat = SvPVx(*++MARK, fromlen);
4052 register char *patend = pat + fromlen;
4057 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4058 static char *space10 = " ";
4060 /* These must not be in registers: */
4078 sv_setpvn(cat, "", 0);
4079 while (pat < patend) {
4080 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4081 datumtype = *pat++ & 0xFF;
4082 if (isSPACE(datumtype))
4085 len = strchr("@Xxu", datumtype) ? 0 : items;
4088 else if (isDIGIT(*pat)) {
4090 while (isDIGIT(*pat))
4091 len = (len * 10) + (*pat++ - '0');
4097 croak("Invalid type in pack: '%c'", (int)datumtype);
4098 case ',': /* grandfather in commas but with a warning */
4099 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4100 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4103 DIE("%% may only be used in unpack");
4114 if (SvCUR(cat) < len)
4115 DIE("X outside of string");
4122 sv_catpvn(cat, null10, 10);
4125 sv_catpvn(cat, null10, len);
4130 aptr = SvPV(fromstr, fromlen);
4134 sv_catpvn(cat, aptr, len);
4136 sv_catpvn(cat, aptr, fromlen);
4138 if (datumtype == 'A') {
4140 sv_catpvn(cat, space10, 10);
4143 sv_catpvn(cat, space10, len);
4147 sv_catpvn(cat, null10, 10);
4150 sv_catpvn(cat, null10, len);
4157 char *savepat = pat;
4162 aptr = SvPV(fromstr, fromlen);
4167 SvCUR(cat) += (len+7)/8;
4168 SvGROW(cat, SvCUR(cat) + 1);
4169 aptr = SvPVX(cat) + aint;
4174 if (datumtype == 'B') {
4175 for (len = 0; len++ < aint;) {
4176 items |= *pat++ & 1;
4180 *aptr++ = items & 0xff;
4186 for (len = 0; len++ < aint;) {
4192 *aptr++ = items & 0xff;
4198 if (datumtype == 'B')
4199 items <<= 7 - (aint & 7);
4201 items >>= 7 - (aint & 7);
4202 *aptr++ = items & 0xff;
4204 pat = SvPVX(cat) + SvCUR(cat);
4215 char *savepat = pat;
4220 aptr = SvPV(fromstr, fromlen);
4225 SvCUR(cat) += (len+1)/2;
4226 SvGROW(cat, SvCUR(cat) + 1);
4227 aptr = SvPVX(cat) + aint;
4232 if (datumtype == 'H') {
4233 for (len = 0; len++ < aint;) {
4235 items |= ((*pat++ & 15) + 9) & 15;
4237 items |= *pat++ & 15;
4241 *aptr++ = items & 0xff;
4247 for (len = 0; len++ < aint;) {
4249 items |= (((*pat++ & 15) + 9) & 15) << 4;
4251 items |= (*pat++ & 15) << 4;
4255 *aptr++ = items & 0xff;
4261 *aptr++ = items & 0xff;
4262 pat = SvPVX(cat) + SvCUR(cat);
4274 aint = SvIV(fromstr);
4276 sv_catpvn(cat, &achar, sizeof(char));
4282 auint = SvUV(fromstr);
4283 SvGROW(cat, SvCUR(cat) + 10);
4284 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4289 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4294 afloat = (float)SvNV(fromstr);
4295 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4302 adouble = (double)SvNV(fromstr);
4303 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4309 ashort = (I16)SvIV(fromstr);
4311 ashort = PerlSock_htons(ashort);
4313 CAT16(cat, &ashort);
4319 ashort = (I16)SvIV(fromstr);
4321 ashort = htovs(ashort);
4323 CAT16(cat, &ashort);
4330 ashort = (I16)SvIV(fromstr);
4331 CAT16(cat, &ashort);
4337 auint = SvUV(fromstr);
4338 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4344 adouble = floor(SvNV(fromstr));
4347 croak("Cannot compress negative numbers");
4353 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4354 adouble <= UV_MAX_cxux
4361 char buf[1 + sizeof(UV)];
4362 char *in = buf + sizeof(buf);
4363 UV auv = U_V(adouble);;
4366 *--in = (auv & 0x7f) | 0x80;
4369 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4370 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4372 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4373 char *from, *result, *in;
4378 /* Copy string and check for compliance */
4379 from = SvPV(fromstr, len);
4380 if ((norm = is_an_int(from, len)) == NULL)
4381 croak("can compress only unsigned integer");
4383 New('w', result, len, char);
4387 *--in = div128(norm, &done) | 0x80;
4388 result[len - 1] &= 0x7F; /* clear continue bit */
4389 sv_catpvn(cat, in, (result + len) - in);
4391 SvREFCNT_dec(norm); /* free norm */
4393 else if (SvNOKp(fromstr)) {
4394 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4395 char *in = buf + sizeof(buf);
4398 double next = floor(adouble / 128);
4399 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4400 if (--in < buf) /* this cannot happen ;-) */
4401 croak ("Cannot compress integer");
4403 } while (adouble > 0);
4404 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4405 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4408 croak("Cannot compress non integer");
4414 aint = SvIV(fromstr);
4415 sv_catpvn(cat, (char*)&aint, sizeof(int));
4421 aulong = SvUV(fromstr);
4423 aulong = PerlSock_htonl(aulong);
4425 CAT32(cat, &aulong);
4431 aulong = SvUV(fromstr);
4433 aulong = htovl(aulong);
4435 CAT32(cat, &aulong);
4441 aulong = SvUV(fromstr);
4442 CAT32(cat, &aulong);
4448 along = SvIV(fromstr);
4456 auquad = (Uquad_t)SvIV(fromstr);
4457 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4463 aquad = (Quad_t)SvIV(fromstr);
4464 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4467 #endif /* HAS_QUAD */
4469 len = 1; /* assume SV is correct length */
4474 if (fromstr == &PL_sv_undef)
4478 /* XXX better yet, could spirit away the string to
4479 * a safe spot and hang on to it until the result
4480 * of pack() (and all copies of the result) are
4483 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4485 "Attempt to pack pointer to temporary value");
4486 if (SvPOK(fromstr) || SvNIOK(fromstr))
4487 aptr = SvPV(fromstr,n_a);
4489 aptr = SvPV_force(fromstr,n_a);
4491 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4496 aptr = SvPV(fromstr, fromlen);
4497 SvGROW(cat, fromlen * 4 / 3);
4502 while (fromlen > 0) {
4509 doencodes(cat, aptr, todo);
4528 register I32 limit = POPi; /* note, negative is forever */
4531 register char *s = SvPV(sv, len);
4532 char *strend = s + len;
4534 register REGEXP *rx;
4538 I32 maxiters = (strend - s) + 10;
4541 I32 origlimit = limit;
4544 AV *oldstack = PL_curstack;
4545 I32 gimme = GIMME_V;
4546 I32 oldsave = PL_savestack_ix;
4547 I32 make_mortal = 1;
4548 MAGIC *mg = (MAGIC *) NULL;
4551 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4556 DIE("panic: do_split");
4557 rx = pm->op_pmregexp;
4559 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4560 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4562 if (pm->op_pmreplroot)
4563 ary = GvAVn((GV*)pm->op_pmreplroot);
4564 else if (gimme != G_ARRAY)
4566 ary = (AV*)PL_curpad[0];
4568 ary = GvAVn(PL_defgv);
4569 #endif /* USE_THREADS */
4572 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4578 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4580 XPUSHs(SvTIED_obj((SV*)ary, mg));
4585 for (i = AvFILLp(ary); i >= 0; i--)
4586 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4588 /* temporarily switch stacks */
4589 SWITCHSTACK(PL_curstack, ary);
4593 base = SP - PL_stack_base;
4595 if (pm->op_pmflags & PMf_SKIPWHITE) {
4596 if (pm->op_pmflags & PMf_LOCALE) {
4597 while (isSPACE_LC(*s))
4605 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4606 SAVEINT(PL_multiline);
4607 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4611 limit = maxiters + 2;
4612 if (pm->op_pmflags & PMf_WHITE) {
4615 while (m < strend &&
4616 !((pm->op_pmflags & PMf_LOCALE)
4617 ? isSPACE_LC(*m) : isSPACE(*m)))
4622 dstr = NEWSV(30, m-s);
4623 sv_setpvn(dstr, s, m-s);
4629 while (s < strend &&
4630 ((pm->op_pmflags & PMf_LOCALE)
4631 ? isSPACE_LC(*s) : isSPACE(*s)))
4635 else if (strEQ("^", rx->precomp)) {
4638 for (m = s; m < strend && *m != '\n'; m++) ;
4642 dstr = NEWSV(30, m-s);
4643 sv_setpvn(dstr, s, m-s);
4650 else if (rx->check_substr && !rx->nparens
4651 && (rx->reganch & ROPT_CHECK_ALL)
4652 && !(rx->reganch & ROPT_ANCH)) {
4653 i = SvCUR(rx->check_substr);
4654 if (i == 1 && !SvTAIL(rx->check_substr)) {
4655 i = *SvPVX(rx->check_substr);
4658 for (m = s; m < strend && *m != i; m++) ;
4661 dstr = NEWSV(30, m-s);
4662 sv_setpvn(dstr, s, m-s);
4671 while (s < strend && --limit &&
4672 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4673 rx->check_substr, 0)) )
4676 dstr = NEWSV(31, m-s);
4677 sv_setpvn(dstr, s, m-s);
4686 maxiters += (strend - s) * rx->nparens;
4687 while (s < strend && --limit &&
4688 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4690 TAINT_IF(RX_MATCH_TAINTED(rx));
4692 && rx->subbase != orig) {
4697 strend = s + (strend - m);
4700 dstr = NEWSV(32, m-s);
4701 sv_setpvn(dstr, s, m-s);
4706 for (i = 1; i <= rx->nparens; i++) {
4710 dstr = NEWSV(33, m-s);
4711 sv_setpvn(dstr, s, m-s);
4714 dstr = NEWSV(33, 0);
4724 LEAVE_SCOPE(oldsave);
4725 iters = (SP - PL_stack_base) - base;
4726 if (iters > maxiters)
4729 /* keep field after final delim? */
4730 if (s < strend || (iters && origlimit)) {
4731 dstr = NEWSV(34, strend-s);
4732 sv_setpvn(dstr, s, strend-s);
4738 else if (!origlimit) {
4739 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4745 SWITCHSTACK(ary, oldstack);
4746 if (SvSMAGICAL(ary)) {
4751 if (gimme == G_ARRAY) {
4753 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4761 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4764 if (gimme == G_ARRAY) {
4765 /* EXTEND should not be needed - we just popped them */
4767 for (i=0; i < iters; i++) {
4768 SV **svp = av_fetch(ary, i, FALSE);
4769 PUSHs((svp) ? *svp : &PL_sv_undef);
4776 if (gimme == G_ARRAY)
4779 if (iters || !pm->op_pmreplroot) {
4789 unlock_condpair(void *svv)
4792 MAGIC *mg = mg_find((SV*)svv, 'm');
4795 croak("panic: unlock_condpair unlocking non-mutex");
4796 MUTEX_LOCK(MgMUTEXP(mg));
4797 if (MgOWNER(mg) != thr)
4798 croak("panic: unlock_condpair unlocking mutex that we don't own");
4800 COND_SIGNAL(MgOWNERCONDP(mg));
4801 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4802 (unsigned long)thr, (unsigned long)svv);)
4803 MUTEX_UNLOCK(MgMUTEXP(mg));
4805 #endif /* USE_THREADS */
4818 mg = condpair_magic(sv);
4819 MUTEX_LOCK(MgMUTEXP(mg));
4820 if (MgOWNER(mg) == thr)
4821 MUTEX_UNLOCK(MgMUTEXP(mg));
4824 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4826 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4827 (unsigned long)thr, (unsigned long)sv);)
4828 MUTEX_UNLOCK(MgMUTEXP(mg));
4829 save_destructor(unlock_condpair, sv);
4831 #endif /* USE_THREADS */
4832 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4833 || SvTYPE(retsv) == SVt_PVCV) {
4834 retsv = refto(retsv);
4845 if (PL_op->op_private & OPpLVAL_INTRO)
4846 PUSHs(*save_threadsv(PL_op->op_targ));
4848 PUSHs(THREADSV(PL_op->op_targ));
4851 DIE("tried to access per-thread data in non-threaded perl");
4852 #endif /* USE_THREADS */