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)) {
2860 assert(AvREAL(ary)); /* would leak, so croak */
2863 if (diff < 0) { /* shrinking the area */
2865 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2866 Copy(MARK, tmparyval, newlen, SV*);
2869 MARK = ORIGMARK + 1;
2870 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2871 MEXTEND(MARK, length);
2872 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2874 EXTEND_MORTAL(length);
2875 for (i = length, dst = MARK; i; i--) {
2876 sv_2mortal(*dst); /* free them eventualy */
2883 *MARK = AvARRAY(ary)[offset+length-1];
2886 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2887 SvREFCNT_dec(*dst++); /* free them now */
2890 AvFILLp(ary) += diff;
2892 /* pull up or down? */
2894 if (offset < after) { /* easier to pull up */
2895 if (offset) { /* esp. if nothing to pull */
2896 src = &AvARRAY(ary)[offset-1];
2897 dst = src - diff; /* diff is negative */
2898 for (i = offset; i > 0; i--) /* can't trust Copy */
2902 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2906 if (after) { /* anything to pull down? */
2907 src = AvARRAY(ary) + offset + length;
2908 dst = src + diff; /* diff is negative */
2909 Move(src, dst, after, SV*);
2911 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2912 /* avoid later double free */
2916 dst[--i] = &PL_sv_undef;
2919 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2921 *dst = NEWSV(46, 0);
2922 sv_setsv(*dst++, *src++);
2924 Safefree(tmparyval);
2927 else { /* no, expanding (or same) */
2929 New(452, tmparyval, length, SV*); /* so remember deletion */
2930 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2933 if (diff > 0) { /* expanding */
2935 /* push up or down? */
2937 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2941 Move(src, dst, offset, SV*);
2943 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2945 AvFILLp(ary) += diff;
2948 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2949 av_extend(ary, AvFILLp(ary) + diff);
2950 AvFILLp(ary) += diff;
2953 dst = AvARRAY(ary) + AvFILLp(ary);
2955 for (i = after; i; i--) {
2962 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2963 *dst = NEWSV(46, 0);
2964 sv_setsv(*dst++, *src++);
2966 MARK = ORIGMARK + 1;
2967 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2969 Copy(tmparyval, MARK, length, SV*);
2971 EXTEND_MORTAL(length);
2972 for (i = length, dst = MARK; i; i--) {
2973 sv_2mortal(*dst); /* free them eventualy */
2977 Safefree(tmparyval);
2981 else if (length--) {
2982 *MARK = tmparyval[length];
2985 while (length-- > 0)
2986 SvREFCNT_dec(tmparyval[length]);
2988 Safefree(tmparyval);
2991 *MARK = &PL_sv_undef;
2999 djSP; dMARK; dORIGMARK; dTARGET;
3000 register AV *ary = (AV*)*++MARK;
3001 register SV *sv = &PL_sv_undef;
3004 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3005 *MARK-- = SvTIED_obj((SV*)ary, mg);
3009 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3014 /* Why no pre-extend of ary here ? */
3015 for (++MARK; MARK <= SP; MARK++) {
3018 sv_setsv(sv, *MARK);
3023 PUSHi( AvFILL(ary) + 1 );
3031 SV *sv = av_pop(av);
3033 (void)sv_2mortal(sv);
3042 SV *sv = av_shift(av);
3047 (void)sv_2mortal(sv);
3054 djSP; dMARK; dORIGMARK; dTARGET;
3055 register AV *ary = (AV*)*++MARK;
3060 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3061 *MARK-- = SvTIED_obj((SV*)ary, mg);
3065 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3070 av_unshift(ary, SP - MARK);
3073 sv_setsv(sv, *++MARK);
3074 (void)av_store(ary, i++, sv);
3078 PUSHi( AvFILL(ary) + 1 );
3088 if (GIMME == G_ARRAY) {
3099 register char *down;
3105 do_join(TARG, &PL_sv_no, MARK, SP);
3107 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3108 up = SvPV_force(TARG, len);
3110 if (IN_UTF8) { /* first reverse each character */
3111 U8* s = (U8*)SvPVX(TARG);
3112 U8* send = (U8*)(s + len);
3121 down = (char*)(s - 1);
3122 if (s > send || !((*down & 0xc0) == 0x80)) {
3123 warn("Malformed UTF-8 character");
3135 down = SvPVX(TARG) + len - 1;
3141 (void)SvPOK_only(TARG);
3150 mul128(SV *sv, U8 m)
3153 char *s = SvPV(sv, len);
3157 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3158 SV *tmpNew = newSVpv("0000000000", 10);
3160 sv_catsv(tmpNew, sv);
3161 SvREFCNT_dec(sv); /* free old sv */
3166 while (!*t) /* trailing '\0'? */
3169 i = ((*t - '0') << 7) + m;
3170 *(t--) = '0' + (i % 10);
3176 /* Explosives and implosives. */
3178 static const char uuemap[] =
3179 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3180 static char uudmap[256]; /* Initialised on first use */
3181 #if 'I' == 73 && 'J' == 74
3182 /* On an ASCII/ISO kind of system */
3183 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3186 Some other sort of character set - use memchr() so we don't match
3189 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3197 I32 gimme = GIMME_V;
3201 register char *pat = SvPV(left, llen);
3202 register char *s = SvPV(right, rlen);
3203 char *strend = s + rlen;
3205 register char *patend = pat + llen;
3210 /* These must not be in registers: */
3227 register U32 culong;
3229 static char* bitcount = 0;
3232 if (gimme != G_ARRAY) { /* arrange to do first one only */
3234 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3235 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3237 while (isDIGIT(*patend) || *patend == '*')
3243 while (pat < patend) {
3245 datumtype = *pat++ & 0xFF;
3246 if (isSPACE(datumtype))
3250 else if (*pat == '*') {
3251 len = strend - strbeg; /* long enough */
3254 else if (isDIGIT(*pat)) {
3256 while (isDIGIT(*pat))
3257 len = (len * 10) + (*pat++ - '0');
3260 len = (datumtype != '@');
3263 croak("Invalid type in unpack: '%c'", (int)datumtype);
3264 case ',': /* grandfather in commas but with a warning */
3265 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3266 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3269 if (len == 1 && pat[-1] != '1')
3278 if (len > strend - strbeg)
3279 DIE("@ outside of string");
3283 if (len > s - strbeg)
3284 DIE("X outside of string");
3288 if (len > strend - s)
3289 DIE("x outside of string");
3294 if (len > strend - s)
3297 goto uchar_checksum;
3298 sv = NEWSV(35, len);
3299 sv_setpvn(sv, s, len);
3301 if (datumtype == 'A') {
3302 aptr = s; /* borrow register */
3303 s = SvPVX(sv) + len - 1;
3304 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3307 SvCUR_set(sv, s - SvPVX(sv));
3308 s = aptr; /* unborrow register */
3310 XPUSHs(sv_2mortal(sv));
3314 if (pat[-1] == '*' || len > (strend - s) * 8)
3315 len = (strend - s) * 8;
3318 Newz(601, bitcount, 256, char);
3319 for (bits = 1; bits < 256; bits++) {
3320 if (bits & 1) bitcount[bits]++;
3321 if (bits & 2) bitcount[bits]++;
3322 if (bits & 4) bitcount[bits]++;
3323 if (bits & 8) bitcount[bits]++;
3324 if (bits & 16) bitcount[bits]++;
3325 if (bits & 32) bitcount[bits]++;
3326 if (bits & 64) bitcount[bits]++;
3327 if (bits & 128) bitcount[bits]++;
3331 culong += bitcount[*(unsigned char*)s++];
3336 if (datumtype == 'b') {
3338 if (bits & 1) culong++;
3344 if (bits & 128) culong++;
3351 sv = NEWSV(35, len + 1);
3354 aptr = pat; /* borrow register */
3356 if (datumtype == 'b') {
3358 for (len = 0; len < aint; len++) {
3359 if (len & 7) /*SUPPRESS 595*/
3363 *pat++ = '0' + (bits & 1);
3368 for (len = 0; len < aint; len++) {
3373 *pat++ = '0' + ((bits & 128) != 0);
3377 pat = aptr; /* unborrow register */
3378 XPUSHs(sv_2mortal(sv));
3382 if (pat[-1] == '*' || len > (strend - s) * 2)
3383 len = (strend - s) * 2;
3384 sv = NEWSV(35, len + 1);
3387 aptr = pat; /* borrow register */
3389 if (datumtype == 'h') {
3391 for (len = 0; len < aint; len++) {
3396 *pat++ = PL_hexdigit[bits & 15];
3401 for (len = 0; len < aint; len++) {
3406 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3410 pat = aptr; /* unborrow register */
3411 XPUSHs(sv_2mortal(sv));
3414 if (len > strend - s)
3419 if (aint >= 128) /* fake up signed chars */
3429 if (aint >= 128) /* fake up signed chars */
3432 sv_setiv(sv, (IV)aint);
3433 PUSHs(sv_2mortal(sv));
3438 if (len > strend - s)
3453 sv_setiv(sv, (IV)auint);
3454 PUSHs(sv_2mortal(sv));
3459 if (len > strend - s)
3462 while (len-- > 0 && s < strend) {
3463 auint = utf8_to_uv((U8*)s, &along);
3466 cdouble += (double)auint;
3474 while (len-- > 0 && s < strend) {
3475 auint = utf8_to_uv((U8*)s, &along);
3478 sv_setuv(sv, (UV)auint);
3479 PUSHs(sv_2mortal(sv));
3484 along = (strend - s) / SIZE16;
3501 sv_setiv(sv, (IV)ashort);
3502 PUSHs(sv_2mortal(sv));
3509 along = (strend - s) / SIZE16;
3514 COPY16(s, &aushort);
3517 if (datumtype == 'n')
3518 aushort = PerlSock_ntohs(aushort);
3521 if (datumtype == 'v')
3522 aushort = vtohs(aushort);
3531 COPY16(s, &aushort);
3535 if (datumtype == 'n')
3536 aushort = PerlSock_ntohs(aushort);
3539 if (datumtype == 'v')
3540 aushort = vtohs(aushort);
3542 sv_setiv(sv, (IV)aushort);
3543 PUSHs(sv_2mortal(sv));
3548 along = (strend - s) / sizeof(int);
3553 Copy(s, &aint, 1, int);
3556 cdouble += (double)aint;
3565 Copy(s, &aint, 1, int);
3569 /* Without the dummy below unpack("i", pack("i",-1))
3570 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3571 * cc with optimization turned on */
3573 sv_setiv(sv, (IV)aint) :
3575 sv_setiv(sv, (IV)aint);
3576 PUSHs(sv_2mortal(sv));
3581 along = (strend - s) / sizeof(unsigned int);
3586 Copy(s, &auint, 1, unsigned int);
3587 s += sizeof(unsigned int);
3589 cdouble += (double)auint;
3598 Copy(s, &auint, 1, unsigned int);
3599 s += sizeof(unsigned int);
3601 sv_setuv(sv, (UV)auint);
3602 PUSHs(sv_2mortal(sv));
3607 along = (strend - s) / SIZE32;
3615 cdouble += (double)along;
3627 sv_setiv(sv, (IV)along);
3628 PUSHs(sv_2mortal(sv));
3635 along = (strend - s) / SIZE32;
3643 if (datumtype == 'N')
3644 aulong = PerlSock_ntohl(aulong);
3647 if (datumtype == 'V')
3648 aulong = vtohl(aulong);
3651 cdouble += (double)aulong;
3663 if (datumtype == 'N')
3664 aulong = PerlSock_ntohl(aulong);
3667 if (datumtype == 'V')
3668 aulong = vtohl(aulong);
3671 sv_setuv(sv, (UV)aulong);
3672 PUSHs(sv_2mortal(sv));
3677 along = (strend - s) / sizeof(char*);
3683 if (sizeof(char*) > strend - s)
3686 Copy(s, &aptr, 1, char*);
3692 PUSHs(sv_2mortal(sv));
3702 while ((len > 0) && (s < strend)) {
3703 auv = (auv << 7) | (*s & 0x7f);
3704 if (!(*s++ & 0x80)) {
3708 PUSHs(sv_2mortal(sv));
3712 else if (++bytes >= sizeof(UV)) { /* promote to string */
3716 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3717 while (s < strend) {
3718 sv = mul128(sv, *s & 0x7f);
3719 if (!(*s++ & 0x80)) {
3728 PUSHs(sv_2mortal(sv));
3733 if ((s >= strend) && bytes)
3734 croak("Unterminated compressed integer");
3739 if (sizeof(char*) > strend - s)
3742 Copy(s, &aptr, 1, char*);
3747 sv_setpvn(sv, aptr, len);
3748 PUSHs(sv_2mortal(sv));
3752 along = (strend - s) / sizeof(Quad_t);
3758 if (s + sizeof(Quad_t) > strend)
3761 Copy(s, &aquad, 1, Quad_t);
3762 s += sizeof(Quad_t);
3765 if (aquad >= IV_MIN && aquad <= IV_MAX)
3766 sv_setiv(sv, (IV)aquad);
3768 sv_setnv(sv, (double)aquad);
3769 PUSHs(sv_2mortal(sv));
3773 along = (strend - s) / sizeof(Quad_t);
3779 if (s + sizeof(Uquad_t) > strend)
3782 Copy(s, &auquad, 1, Uquad_t);
3783 s += sizeof(Uquad_t);
3786 if (auquad <= UV_MAX)
3787 sv_setuv(sv, (UV)auquad);
3789 sv_setnv(sv, (double)auquad);
3790 PUSHs(sv_2mortal(sv));
3794 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3797 along = (strend - s) / sizeof(float);
3802 Copy(s, &afloat, 1, float);
3811 Copy(s, &afloat, 1, float);
3814 sv_setnv(sv, (double)afloat);
3815 PUSHs(sv_2mortal(sv));
3821 along = (strend - s) / sizeof(double);
3826 Copy(s, &adouble, 1, double);
3827 s += sizeof(double);
3835 Copy(s, &adouble, 1, double);
3836 s += sizeof(double);
3838 sv_setnv(sv, (double)adouble);
3839 PUSHs(sv_2mortal(sv));
3845 * Initialise the decode mapping. By using a table driven
3846 * algorithm, the code will be character-set independent
3847 * (and just as fast as doing character arithmetic)
3849 if (uudmap['M'] == 0) {
3852 for (i = 0; i < sizeof(uuemap); i += 1)
3853 uudmap[uuemap[i]] = i;
3855 * Because ' ' and '`' map to the same value,
3856 * we need to decode them both the same.
3861 along = (strend - s) * 3 / 4;
3862 sv = NEWSV(42, along);
3865 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3870 len = uudmap[*s++] & 077;
3872 if (s < strend && ISUUCHAR(*s))
3873 a = uudmap[*s++] & 077;
3876 if (s < strend && ISUUCHAR(*s))
3877 b = uudmap[*s++] & 077;
3880 if (s < strend && ISUUCHAR(*s))
3881 c = uudmap[*s++] & 077;
3884 if (s < strend && ISUUCHAR(*s))
3885 d = uudmap[*s++] & 077;
3888 hunk[0] = (a << 2) | (b >> 4);
3889 hunk[1] = (b << 4) | (c >> 2);
3890 hunk[2] = (c << 6) | d;
3891 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3896 else if (s[1] == '\n') /* possible checksum byte */
3899 XPUSHs(sv_2mortal(sv));
3904 if (strchr("fFdD", datumtype) ||
3905 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3909 while (checksum >= 16) {
3913 while (checksum >= 4) {
3919 along = (1 << checksum) - 1;
3920 while (cdouble < 0.0)
3922 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3923 sv_setnv(sv, cdouble);
3926 if (checksum < 32) {
3927 aulong = (1 << checksum) - 1;
3930 sv_setuv(sv, (UV)culong);
3932 XPUSHs(sv_2mortal(sv));
3936 if (SP == oldsp && gimme == G_SCALAR)
3937 PUSHs(&PL_sv_undef);
3942 doencodes(register SV *sv, register char *s, register I32 len)
3946 *hunk = uuemap[len];
3947 sv_catpvn(sv, hunk, 1);
3950 hunk[0] = uuemap[(077 & (*s >> 2))];
3951 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3952 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3953 hunk[3] = uuemap[(077 & (s[2] & 077))];
3954 sv_catpvn(sv, hunk, 4);
3959 char r = (len > 1 ? s[1] : '\0');
3960 hunk[0] = uuemap[(077 & (*s >> 2))];
3961 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3962 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3963 hunk[3] = uuemap[0];
3964 sv_catpvn(sv, hunk, 4);
3966 sv_catpvn(sv, "\n", 1);
3970 is_an_int(char *s, STRLEN l)
3973 SV *result = newSVpv("", l);
3974 char *result_c = SvPV(result, n_a); /* convenience */
3975 char *out = result_c;
3985 SvREFCNT_dec(result);
4008 SvREFCNT_dec(result);
4014 SvCUR_set(result, out - result_c);
4019 div128(SV *pnum, bool *done)
4020 /* must be '\0' terminated */
4024 char *s = SvPV(pnum, len);
4033 i = m * 10 + (*t - '0');
4035 r = (i >> 7); /* r < 10 */
4042 SvCUR_set(pnum, (STRLEN) (t - s));
4049 djSP; dMARK; dORIGMARK; dTARGET;
4050 register SV *cat = TARG;
4053 register char *pat = SvPVx(*++MARK, fromlen);
4054 register char *patend = pat + fromlen;
4059 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4060 static char *space10 = " ";
4062 /* These must not be in registers: */
4080 sv_setpvn(cat, "", 0);
4081 while (pat < patend) {
4082 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4083 datumtype = *pat++ & 0xFF;
4084 if (isSPACE(datumtype))
4087 len = strchr("@Xxu", datumtype) ? 0 : items;
4090 else if (isDIGIT(*pat)) {
4092 while (isDIGIT(*pat))
4093 len = (len * 10) + (*pat++ - '0');
4099 croak("Invalid type in pack: '%c'", (int)datumtype);
4100 case ',': /* grandfather in commas but with a warning */
4101 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4102 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4105 DIE("%% may only be used in unpack");
4116 if (SvCUR(cat) < len)
4117 DIE("X outside of string");
4124 sv_catpvn(cat, null10, 10);
4127 sv_catpvn(cat, null10, len);
4132 aptr = SvPV(fromstr, fromlen);
4136 sv_catpvn(cat, aptr, len);
4138 sv_catpvn(cat, aptr, fromlen);
4140 if (datumtype == 'A') {
4142 sv_catpvn(cat, space10, 10);
4145 sv_catpvn(cat, space10, len);
4149 sv_catpvn(cat, null10, 10);
4152 sv_catpvn(cat, null10, len);
4159 char *savepat = pat;
4164 aptr = SvPV(fromstr, fromlen);
4169 SvCUR(cat) += (len+7)/8;
4170 SvGROW(cat, SvCUR(cat) + 1);
4171 aptr = SvPVX(cat) + aint;
4176 if (datumtype == 'B') {
4177 for (len = 0; len++ < aint;) {
4178 items |= *pat++ & 1;
4182 *aptr++ = items & 0xff;
4188 for (len = 0; len++ < aint;) {
4194 *aptr++ = items & 0xff;
4200 if (datumtype == 'B')
4201 items <<= 7 - (aint & 7);
4203 items >>= 7 - (aint & 7);
4204 *aptr++ = items & 0xff;
4206 pat = SvPVX(cat) + SvCUR(cat);
4217 char *savepat = pat;
4222 aptr = SvPV(fromstr, fromlen);
4227 SvCUR(cat) += (len+1)/2;
4228 SvGROW(cat, SvCUR(cat) + 1);
4229 aptr = SvPVX(cat) + aint;
4234 if (datumtype == 'H') {
4235 for (len = 0; len++ < aint;) {
4237 items |= ((*pat++ & 15) + 9) & 15;
4239 items |= *pat++ & 15;
4243 *aptr++ = items & 0xff;
4249 for (len = 0; len++ < aint;) {
4251 items |= (((*pat++ & 15) + 9) & 15) << 4;
4253 items |= (*pat++ & 15) << 4;
4257 *aptr++ = items & 0xff;
4263 *aptr++ = items & 0xff;
4264 pat = SvPVX(cat) + SvCUR(cat);
4276 aint = SvIV(fromstr);
4278 sv_catpvn(cat, &achar, sizeof(char));
4284 auint = SvUV(fromstr);
4285 SvGROW(cat, SvCUR(cat) + 10);
4286 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4291 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4296 afloat = (float)SvNV(fromstr);
4297 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4304 adouble = (double)SvNV(fromstr);
4305 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4311 ashort = (I16)SvIV(fromstr);
4313 ashort = PerlSock_htons(ashort);
4315 CAT16(cat, &ashort);
4321 ashort = (I16)SvIV(fromstr);
4323 ashort = htovs(ashort);
4325 CAT16(cat, &ashort);
4332 ashort = (I16)SvIV(fromstr);
4333 CAT16(cat, &ashort);
4339 auint = SvUV(fromstr);
4340 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4346 adouble = floor(SvNV(fromstr));
4349 croak("Cannot compress negative numbers");
4355 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4356 adouble <= UV_MAX_cxux
4363 char buf[1 + sizeof(UV)];
4364 char *in = buf + sizeof(buf);
4365 UV auv = U_V(adouble);;
4368 *--in = (auv & 0x7f) | 0x80;
4371 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4372 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4374 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4375 char *from, *result, *in;
4380 /* Copy string and check for compliance */
4381 from = SvPV(fromstr, len);
4382 if ((norm = is_an_int(from, len)) == NULL)
4383 croak("can compress only unsigned integer");
4385 New('w', result, len, char);
4389 *--in = div128(norm, &done) | 0x80;
4390 result[len - 1] &= 0x7F; /* clear continue bit */
4391 sv_catpvn(cat, in, (result + len) - in);
4393 SvREFCNT_dec(norm); /* free norm */
4395 else if (SvNOKp(fromstr)) {
4396 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4397 char *in = buf + sizeof(buf);
4400 double next = floor(adouble / 128);
4401 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4402 if (--in < buf) /* this cannot happen ;-) */
4403 croak ("Cannot compress integer");
4405 } while (adouble > 0);
4406 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4407 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4410 croak("Cannot compress non integer");
4416 aint = SvIV(fromstr);
4417 sv_catpvn(cat, (char*)&aint, sizeof(int));
4423 aulong = SvUV(fromstr);
4425 aulong = PerlSock_htonl(aulong);
4427 CAT32(cat, &aulong);
4433 aulong = SvUV(fromstr);
4435 aulong = htovl(aulong);
4437 CAT32(cat, &aulong);
4443 aulong = SvUV(fromstr);
4444 CAT32(cat, &aulong);
4450 along = SvIV(fromstr);
4458 auquad = (Uquad_t)SvIV(fromstr);
4459 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4465 aquad = (Quad_t)SvIV(fromstr);
4466 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4469 #endif /* HAS_QUAD */
4471 len = 1; /* assume SV is correct length */
4476 if (fromstr == &PL_sv_undef)
4480 /* XXX better yet, could spirit away the string to
4481 * a safe spot and hang on to it until the result
4482 * of pack() (and all copies of the result) are
4485 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4487 "Attempt to pack pointer to temporary value");
4488 if (SvPOK(fromstr) || SvNIOK(fromstr))
4489 aptr = SvPV(fromstr,n_a);
4491 aptr = SvPV_force(fromstr,n_a);
4493 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4498 aptr = SvPV(fromstr, fromlen);
4499 SvGROW(cat, fromlen * 4 / 3);
4504 while (fromlen > 0) {
4511 doencodes(cat, aptr, todo);
4530 register I32 limit = POPi; /* note, negative is forever */
4533 register char *s = SvPV(sv, len);
4534 char *strend = s + len;
4536 register REGEXP *rx;
4540 I32 maxiters = (strend - s) + 10;
4543 I32 origlimit = limit;
4546 AV *oldstack = PL_curstack;
4547 I32 gimme = GIMME_V;
4548 I32 oldsave = PL_savestack_ix;
4549 I32 make_mortal = 1;
4550 MAGIC *mg = (MAGIC *) NULL;
4553 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4558 DIE("panic: do_split");
4559 rx = pm->op_pmregexp;
4561 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4562 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4564 if (pm->op_pmreplroot)
4565 ary = GvAVn((GV*)pm->op_pmreplroot);
4566 else if (gimme != G_ARRAY)
4568 ary = (AV*)PL_curpad[0];
4570 ary = GvAVn(PL_defgv);
4571 #endif /* USE_THREADS */
4574 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4580 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4582 XPUSHs(SvTIED_obj((SV*)ary, mg));
4587 for (i = AvFILLp(ary); i >= 0; i--)
4588 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4590 /* temporarily switch stacks */
4591 SWITCHSTACK(PL_curstack, ary);
4595 base = SP - PL_stack_base;
4597 if (pm->op_pmflags & PMf_SKIPWHITE) {
4598 if (pm->op_pmflags & PMf_LOCALE) {
4599 while (isSPACE_LC(*s))
4607 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4608 SAVEINT(PL_multiline);
4609 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4613 limit = maxiters + 2;
4614 if (pm->op_pmflags & PMf_WHITE) {
4617 while (m < strend &&
4618 !((pm->op_pmflags & PMf_LOCALE)
4619 ? isSPACE_LC(*m) : isSPACE(*m)))
4624 dstr = NEWSV(30, m-s);
4625 sv_setpvn(dstr, s, m-s);
4631 while (s < strend &&
4632 ((pm->op_pmflags & PMf_LOCALE)
4633 ? isSPACE_LC(*s) : isSPACE(*s)))
4637 else if (strEQ("^", rx->precomp)) {
4640 for (m = s; m < strend && *m != '\n'; m++) ;
4644 dstr = NEWSV(30, m-s);
4645 sv_setpvn(dstr, s, m-s);
4652 else if (rx->check_substr && !rx->nparens
4653 && (rx->reganch & ROPT_CHECK_ALL)
4654 && !(rx->reganch & ROPT_ANCH)) {
4655 i = SvCUR(rx->check_substr);
4656 if (i == 1 && !SvTAIL(rx->check_substr)) {
4657 i = *SvPVX(rx->check_substr);
4660 for (m = s; m < strend && *m != i; m++) ;
4663 dstr = NEWSV(30, m-s);
4664 sv_setpvn(dstr, s, m-s);
4673 while (s < strend && --limit &&
4674 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4675 rx->check_substr, 0)) )
4678 dstr = NEWSV(31, m-s);
4679 sv_setpvn(dstr, s, m-s);
4688 maxiters += (strend - s) * rx->nparens;
4689 while (s < strend && --limit &&
4690 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4692 TAINT_IF(RX_MATCH_TAINTED(rx));
4694 && rx->subbase != orig) {
4699 strend = s + (strend - m);
4702 dstr = NEWSV(32, m-s);
4703 sv_setpvn(dstr, s, m-s);
4708 for (i = 1; i <= rx->nparens; i++) {
4712 dstr = NEWSV(33, m-s);
4713 sv_setpvn(dstr, s, m-s);
4716 dstr = NEWSV(33, 0);
4726 LEAVE_SCOPE(oldsave);
4727 iters = (SP - PL_stack_base) - base;
4728 if (iters > maxiters)
4731 /* keep field after final delim? */
4732 if (s < strend || (iters && origlimit)) {
4733 dstr = NEWSV(34, strend-s);
4734 sv_setpvn(dstr, s, strend-s);
4740 else if (!origlimit) {
4741 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4747 SWITCHSTACK(ary, oldstack);
4748 if (SvSMAGICAL(ary)) {
4753 if (gimme == G_ARRAY) {
4755 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4763 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4766 if (gimme == G_ARRAY) {
4767 /* EXTEND should not be needed - we just popped them */
4769 for (i=0; i < iters; i++) {
4770 SV **svp = av_fetch(ary, i, FALSE);
4771 PUSHs((svp) ? *svp : &PL_sv_undef);
4778 if (gimme == G_ARRAY)
4781 if (iters || !pm->op_pmreplroot) {
4791 unlock_condpair(void *svv)
4794 MAGIC *mg = mg_find((SV*)svv, 'm');
4797 croak("panic: unlock_condpair unlocking non-mutex");
4798 MUTEX_LOCK(MgMUTEXP(mg));
4799 if (MgOWNER(mg) != thr)
4800 croak("panic: unlock_condpair unlocking mutex that we don't own");
4802 COND_SIGNAL(MgOWNERCONDP(mg));
4803 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4804 (unsigned long)thr, (unsigned long)svv);)
4805 MUTEX_UNLOCK(MgMUTEXP(mg));
4807 #endif /* USE_THREADS */
4820 mg = condpair_magic(sv);
4821 MUTEX_LOCK(MgMUTEXP(mg));
4822 if (MgOWNER(mg) == thr)
4823 MUTEX_UNLOCK(MgMUTEXP(mg));
4826 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4828 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4829 (unsigned long)thr, (unsigned long)sv);)
4830 MUTEX_UNLOCK(MgMUTEXP(mg));
4831 save_destructor(unlock_condpair, sv);
4833 #endif /* USE_THREADS */
4834 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4835 || SvTYPE(retsv) == SVt_PVCV) {
4836 retsv = refto(retsv);
4847 if (PL_op->op_private & OPpLVAL_INTRO)
4848 PUSHs(*save_threadsv(PL_op->op_targ));
4850 PUSHs(THREADSV(PL_op->op_targ));
4853 DIE("tried to access per-thread data in non-threaded perl");
4854 #endif /* USE_THREADS */