3 * Copyright (c) 1991-1997, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
19 * The compiler on Concurrent CX/UX systems has a subtle bug which only
20 * seems to show up when compiling pp.c - it generates the wrong double
21 * precision constant value for (double)UV_MAX when used inline in the body
22 * of the code below, so this makes a static variable up front (which the
23 * compiler seems to get correct) and uses it in place of UV_MAX below.
25 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
26 static double UV_MAX_cxux = ((double)UV_MAX);
30 * Types used in bitwise operations.
32 * Normally we'd just use IV and UV. However, some hardware and
33 * software combinations (e.g. Alpha and current OSF/1) don't have a
34 * floating-point type to use for NV that has adequate bits to fully
35 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
37 * It just so happens that "int" is the right size almost everywhere.
43 * Mask used after bitwise operations.
45 * There is at least one realm (Cray word machines) that doesn't
46 * have an integral type (except char) small enough to be represented
47 * in a double without loss; that is, it has no 32-bit type.
49 #if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
51 # define BW_MASK ((1 << BW_BITS) - 1)
52 # define BW_SIGN (1 << (BW_BITS - 1))
53 # define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
54 # define BWu(u) ((u) & BW_MASK)
61 * Offset for integer pack/unpack.
63 * On architectures where I16 and I32 aren't really 16 and 32 bits,
64 * which for now are all Crays, pack and unpack have to play games.
68 * These values are required for portability of pack() output.
69 * If they're not right on your machine, then pack() and unpack()
70 * wouldn't work right anyway; you'll need to apply the Cray hack.
71 * (I'd like to check them with #if, but you can't use sizeof() in
72 * the preprocessor.) --???
75 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
76 defines are now in config.h. --Andy Dougherty April 1998
81 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
82 # if BYTEORDER == 0x12345678
83 # define OFF16(p) (char*)(p)
84 # define OFF32(p) (char*)(p)
86 # if BYTEORDER == 0x87654321
87 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
88 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
90 }}}} bad cray byte order
93 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
94 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
95 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
96 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
98 # define COPY16(s,p) Copy(s, p, SIZE16, char)
99 # define COPY32(s,p) Copy(s, p, SIZE32, char)
100 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
101 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
105 static void doencodes _((SV* sv, char* s, I32 len));
106 static SV* refto _((SV* sv));
107 static U32 seed _((void));
110 static bool srand_called = FALSE;
112 /* variations on pp_null */
118 /* XXX I can't imagine anyone who doesn't have this actually _needs_
119 it, since pid_t is an integral type.
122 #ifdef NEED_GETPID_PROTO
123 extern Pid_t getpid (void);
129 if (GIMME_V == G_SCALAR)
130 XPUSHs(&PL_sv_undef);
144 if (PL_op->op_private & OPpLVAL_INTRO)
145 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
147 if (PL_op->op_flags & OPf_REF) {
151 if (GIMME == G_ARRAY) {
152 I32 maxarg = AvFILL((AV*)TARG) + 1;
154 if (SvMAGICAL(TARG)) {
156 for (i=0; i < maxarg; i++) {
157 SV **svp = av_fetch((AV*)TARG, i, FALSE);
158 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
162 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
167 SV* sv = sv_newmortal();
168 I32 maxarg = AvFILL((AV*)TARG) + 1;
169 sv_setiv(sv, maxarg);
181 if (PL_op->op_private & OPpLVAL_INTRO)
182 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
183 if (PL_op->op_flags & OPf_REF)
186 if (gimme == G_ARRAY) {
187 RETURNOP(do_kv(ARGS));
189 else if (gimme == G_SCALAR) {
190 SV* sv = sv_newmortal();
191 if (HvFILL((HV*)TARG))
192 sv_setpvf(sv, "%ld/%ld",
193 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
203 DIE("NOT IMPL LINE %d",__LINE__);
214 tryAMAGICunDEREF(to_gv);
217 if (SvTYPE(sv) == SVt_PVIO) {
218 GV *gv = (GV*) sv_newmortal();
219 gv_init(gv, 0, "", 0, 0);
220 GvIOp(gv) = (IO *)sv;
221 (void)SvREFCNT_inc(sv);
223 } else if (SvTYPE(sv) != SVt_PVGV)
224 DIE("Not a GLOB reference");
227 if (SvTYPE(sv) != SVt_PVGV) {
231 if (SvGMAGICAL(sv)) {
237 if (PL_op->op_flags & OPf_REF ||
238 PL_op->op_private & HINT_STRICT_REFS)
239 DIE(PL_no_usym, "a symbol");
240 if (ckWARN(WARN_UNINITIALIZED))
241 warner(WARN_UNINITIALIZED, PL_warn_uninit);
245 if (PL_op->op_private & HINT_STRICT_REFS)
246 DIE(PL_no_symref, sym, "a symbol");
247 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
250 if (PL_op->op_private & OPpLVAL_INTRO)
251 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
262 tryAMAGICunDEREF(to_sv);
265 switch (SvTYPE(sv)) {
269 DIE("Not a SCALAR reference");
277 if (SvTYPE(gv) != SVt_PVGV) {
278 if (SvGMAGICAL(sv)) {
284 if (PL_op->op_flags & OPf_REF ||
285 PL_op->op_private & HINT_STRICT_REFS)
286 DIE(PL_no_usym, "a SCALAR");
287 if (ckWARN(WARN_UNINITIALIZED))
288 warner(WARN_UNINITIALIZED, PL_warn_uninit);
292 if (PL_op->op_private & HINT_STRICT_REFS)
293 DIE(PL_no_symref, sym, "a SCALAR");
294 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
298 if (PL_op->op_flags & OPf_MOD) {
299 if (PL_op->op_private & OPpLVAL_INTRO)
300 sv = save_scalar((GV*)TOPs);
301 else if (PL_op->op_private & OPpDEREF)
302 vivify_ref(sv, PL_op->op_private & OPpDEREF);
312 SV *sv = AvARYLEN(av);
314 AvARYLEN(av) = sv = NEWSV(0,0);
315 sv_upgrade(sv, SVt_IV);
316 sv_magic(sv, (SV*)av, '#', Nullch, 0);
324 djSP; dTARGET; dPOPss;
326 if (PL_op->op_flags & OPf_MOD) {
327 if (SvTYPE(TARG) < SVt_PVLV) {
328 sv_upgrade(TARG, SVt_PVLV);
329 sv_magic(TARG, Nullsv, '.', Nullch, 0);
333 if (LvTARG(TARG) != sv) {
335 SvREFCNT_dec(LvTARG(TARG));
336 LvTARG(TARG) = SvREFCNT_inc(sv);
338 PUSHs(TARG); /* no SvSETMAGIC */
344 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
345 mg = mg_find(sv, 'g');
346 if (mg && mg->mg_len >= 0) {
350 PUSHi(i + PL_curcop->cop_arybase);
364 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
365 /* (But not in defined().) */
366 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
369 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
372 cv = (CV*)&PL_sv_undef;
386 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
387 char *s = SvPVX(TOPs);
388 if (strnEQ(s, "CORE::", 6)) {
391 code = keyword(s + 6, SvCUR(TOPs) - 6);
392 if (code < 0) { /* Overridable. */
393 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
394 int i = 0, n = 0, seen_question = 0;
396 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
398 while (i < MAXO) { /* The slow way. */
399 if (strEQ(s + 6, PL_op_name[i])
400 || strEQ(s + 6, PL_op_desc[i]))
406 goto nonesuch; /* Should not happen... */
408 oa = PL_opargs[i] >> OASHIFT;
410 if (oa & OA_OPTIONAL) {
413 } else if (seen_question)
414 goto set; /* XXXX system, exec */
415 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
416 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
419 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
420 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
424 ret = sv_2mortal(newSVpv(str, n - 1));
425 } else if (code) /* Non-Overridable */
427 else { /* None such */
429 croak("Cannot find an opnumber for \"%s\"", s+6);
433 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
435 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
444 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
446 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
462 if (GIMME != G_ARRAY) {
466 *MARK = &PL_sv_undef;
467 *MARK = refto(*MARK);
471 EXTEND_MORTAL(SP - MARK);
473 *MARK = refto(*MARK);
482 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
485 if (!(sv = LvTARG(sv)))
488 else if (SvPADTMP(sv))
492 (void)SvREFCNT_inc(sv);
495 sv_upgrade(rv, SVt_RV);
509 if (sv && SvGMAGICAL(sv))
512 if (!sv || !SvROK(sv))
516 pv = sv_reftype(sv,TRUE);
517 PUSHp(pv, strlen(pv));
527 stash = PL_curcop->cop_stash;
531 char *ptr = SvPV(ssv,len);
532 if (ckWARN(WARN_UNSAFE) && len == 0)
534 "Explicit blessing to '' (assuming package main)");
535 stash = gv_stashpvn(ptr, len, TRUE);
538 (void)sv_bless(TOPs, stash);
552 elem = SvPV(sv, n_a);
556 switch (elem ? *elem : '\0')
559 if (strEQ(elem, "ARRAY"))
560 tmpRef = (SV*)GvAV(gv);
563 if (strEQ(elem, "CODE"))
564 tmpRef = (SV*)GvCVu(gv);
567 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
568 tmpRef = (SV*)GvIOp(gv);
571 if (strEQ(elem, "GLOB"))
575 if (strEQ(elem, "HASH"))
576 tmpRef = (SV*)GvHV(gv);
579 if (strEQ(elem, "IO"))
580 tmpRef = (SV*)GvIOp(gv);
583 if (strEQ(elem, "NAME"))
584 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
587 if (strEQ(elem, "PACKAGE"))
588 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
591 if (strEQ(elem, "SCALAR"))
605 /* Pattern matching */
610 register UNOP *unop = cUNOP;
611 register unsigned char *s;
614 register I32 *sfirst;
618 if (sv == PL_lastscream) {
624 SvSCREAM_off(PL_lastscream);
625 SvREFCNT_dec(PL_lastscream);
627 PL_lastscream = SvREFCNT_inc(sv);
630 s = (unsigned char*)(SvPV(sv, len));
634 if (pos > PL_maxscream) {
635 if (PL_maxscream < 0) {
636 PL_maxscream = pos + 80;
637 New(301, PL_screamfirst, 256, I32);
638 New(302, PL_screamnext, PL_maxscream, I32);
641 PL_maxscream = pos + pos / 4;
642 Renew(PL_screamnext, PL_maxscream, I32);
646 sfirst = PL_screamfirst;
647 snext = PL_screamnext;
649 if (!sfirst || !snext)
650 DIE("do_study: out of memory");
652 for (ch = 256; ch; --ch)
659 snext[pos] = sfirst[ch] - pos;
666 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
675 if (PL_op->op_flags & OPf_STACKED)
681 TARG = sv_newmortal();
686 /* Lvalue operators. */
698 djSP; dMARK; dTARGET;
708 SETi(do_chomp(TOPs));
714 djSP; dMARK; dTARGET;
715 register I32 count = 0;
718 count += do_chomp(POPs);
729 if (!sv || !SvANY(sv))
731 switch (SvTYPE(sv)) {
733 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
737 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
741 if (CvROOT(sv) || CvXSUB(sv))
758 if (!PL_op->op_private) {
767 if (SvTHINKFIRST(sv)) {
768 if (SvREADONLY(sv)) {
770 if (PL_curcop != &PL_compiling)
777 switch (SvTYPE(sv)) {
787 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
788 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
789 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
792 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
794 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
798 SvSetMagicSV(sv, &PL_sv_undef);
802 Newz(602, gp, 1, GP);
803 GvGP(sv) = gp_ref(gp);
804 GvSV(sv) = NEWSV(72,0);
805 GvLINE(sv) = PL_curcop->cop_line;
811 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
814 SvPV_set(sv, Nullch);
827 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
829 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
830 SvIVX(TOPs) != IV_MIN)
833 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
844 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
846 sv_setsv(TARG, TOPs);
847 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
848 SvIVX(TOPs) != IV_MAX)
851 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
865 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
867 sv_setsv(TARG, TOPs);
868 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
869 SvIVX(TOPs) != IV_MIN)
872 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
881 /* Ordinary operators. */
885 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
888 SETn( pow( left, right) );
895 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
898 SETn( left * right );
905 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
910 DIE("Illegal division by zero");
912 /* insure that 20./5. == 4. */
915 if ((double)I_V(left) == left &&
916 (double)I_V(right) == right &&
917 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
920 value = left / right;
924 value = left / right;
933 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
941 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
943 right = (right_neg = (i < 0)) ? -i : i;
947 right = U_V((right_neg = (n < 0)) ? -n : n);
950 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
952 left = (left_neg = (i < 0)) ? -i : i;
956 left = U_V((left_neg = (n < 0)) ? -n : n);
960 DIE("Illegal modulus zero");
963 if ((left_neg != right_neg) && ans)
966 /* XXX may warn: unary minus operator applied to unsigned type */
967 /* could change -foo to be (~foo)+1 instead */
968 if (ans <= ~((UV)IV_MAX)+1)
969 sv_setiv(TARG, ~ans+1);
971 sv_setnv(TARG, -(double)ans);
982 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
984 register I32 count = POPi;
985 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
987 I32 items = SP - MARK;
999 repeatcpy((char*)(MARK + items), (char*)MARK,
1000 items * sizeof(SV*), count - 1);
1003 else if (count <= 0)
1006 else { /* Note: mark already snarfed by pp_list */
1011 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1012 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1013 DIE("Can't x= to readonly value");
1017 SvSetSV(TARG, tmpstr);
1018 SvPV_force(TARG, len);
1023 SvGROW(TARG, (count * len) + 1);
1024 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1025 SvCUR(TARG) *= count;
1027 *SvEND(TARG) = '\0';
1029 (void)SvPOK_only(TARG);
1038 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1041 SETn( left - right );
1048 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1051 if (PL_op->op_private & HINT_INTEGER) {
1053 i = BWi(i) << shift;
1067 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1070 if (PL_op->op_private & HINT_INTEGER) {
1072 i = BWi(i) >> shift;
1086 djSP; tryAMAGICbinSET(lt,0);
1089 SETs(boolSV(TOPn < value));
1096 djSP; tryAMAGICbinSET(gt,0);
1099 SETs(boolSV(TOPn > value));
1106 djSP; tryAMAGICbinSET(le,0);
1109 SETs(boolSV(TOPn <= value));
1116 djSP; tryAMAGICbinSET(ge,0);
1119 SETs(boolSV(TOPn >= value));
1126 djSP; tryAMAGICbinSET(ne,0);
1129 SETs(boolSV(TOPn != value));
1136 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1143 else if (left < right)
1145 else if (left > right)
1158 djSP; tryAMAGICbinSET(slt,0);
1161 int cmp = ((PL_op->op_private & OPpLOCALE)
1162 ? sv_cmp_locale(left, right)
1163 : sv_cmp(left, right));
1164 SETs(boolSV(cmp < 0));
1171 djSP; tryAMAGICbinSET(sgt,0);
1174 int cmp = ((PL_op->op_private & OPpLOCALE)
1175 ? sv_cmp_locale(left, right)
1176 : sv_cmp(left, right));
1177 SETs(boolSV(cmp > 0));
1184 djSP; tryAMAGICbinSET(sle,0);
1187 int cmp = ((PL_op->op_private & OPpLOCALE)
1188 ? sv_cmp_locale(left, right)
1189 : sv_cmp(left, right));
1190 SETs(boolSV(cmp <= 0));
1197 djSP; tryAMAGICbinSET(sge,0);
1200 int cmp = ((PL_op->op_private & OPpLOCALE)
1201 ? sv_cmp_locale(left, right)
1202 : sv_cmp(left, right));
1203 SETs(boolSV(cmp >= 0));
1210 djSP; tryAMAGICbinSET(seq,0);
1213 SETs(boolSV(sv_eq(left, right)));
1220 djSP; tryAMAGICbinSET(sne,0);
1223 SETs(boolSV(!sv_eq(left, right)));
1230 djSP; dTARGET; tryAMAGICbin(scmp,0);
1233 int cmp = ((PL_op->op_private & OPpLOCALE)
1234 ? sv_cmp_locale(left, right)
1235 : sv_cmp(left, right));
1243 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1246 if (SvNIOKp(left) || SvNIOKp(right)) {
1247 if (PL_op->op_private & HINT_INTEGER) {
1248 IBW value = SvIV(left) & SvIV(right);
1252 UBW value = SvUV(left) & SvUV(right);
1257 do_vop(PL_op->op_type, TARG, left, right);
1266 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1269 if (SvNIOKp(left) || SvNIOKp(right)) {
1270 if (PL_op->op_private & HINT_INTEGER) {
1271 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1275 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1280 do_vop(PL_op->op_type, TARG, left, right);
1289 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1292 if (SvNIOKp(left) || SvNIOKp(right)) {
1293 if (PL_op->op_private & HINT_INTEGER) {
1294 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1298 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1303 do_vop(PL_op->op_type, TARG, left, right);
1312 djSP; dTARGET; tryAMAGICun(neg);
1317 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1319 else if (SvNIOKp(sv))
1321 else if (SvPOKp(sv)) {
1323 char *s = SvPV(sv, len);
1324 if (isIDFIRST(*s)) {
1325 sv_setpvn(TARG, "-", 1);
1328 else if (*s == '+' || *s == '-') {
1330 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1332 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1333 sv_setpvn(TARG, "-", 1);
1337 sv_setnv(TARG, -SvNV(sv));
1349 djSP; tryAMAGICunSET(not);
1350 #endif /* OVERLOAD */
1351 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1357 djSP; dTARGET; tryAMAGICun(compl);
1361 if (PL_op->op_private & HINT_INTEGER) {
1362 IBW value = ~SvIV(sv);
1366 UBW value = ~SvUV(sv);
1371 register char *tmps;
1372 register long *tmpl;
1377 tmps = SvPV_force(TARG, len);
1380 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1383 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1387 for ( ; anum > 0; anum--, tmps++)
1396 /* integer versions of some of the above */
1400 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1403 SETi( left * right );
1410 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1414 DIE("Illegal division by zero");
1415 value = POPi / value;
1423 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1427 DIE("Illegal modulus zero");
1428 SETi( left % right );
1435 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1438 SETi( left + right );
1445 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1448 SETi( left - right );
1455 djSP; tryAMAGICbinSET(lt,0);
1458 SETs(boolSV(left < right));
1465 djSP; tryAMAGICbinSET(gt,0);
1468 SETs(boolSV(left > right));
1475 djSP; tryAMAGICbinSET(le,0);
1478 SETs(boolSV(left <= right));
1485 djSP; tryAMAGICbinSET(ge,0);
1488 SETs(boolSV(left >= right));
1495 djSP; tryAMAGICbinSET(eq,0);
1498 SETs(boolSV(left == right));
1505 djSP; tryAMAGICbinSET(ne,0);
1508 SETs(boolSV(left != right));
1515 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1522 else if (left < right)
1533 djSP; dTARGET; tryAMAGICun(neg);
1538 /* High falutin' math. */
1542 djSP; dTARGET; tryAMAGICbin(atan2,0);
1545 SETn(atan2(left, right));
1552 djSP; dTARGET; tryAMAGICun(sin);
1564 djSP; dTARGET; tryAMAGICun(cos);
1574 /* Support Configure command-line overrides for rand() functions.
1575 After 5.005, perhaps we should replace this by Configure support
1576 for drand48(), random(), or rand(). For 5.005, though, maintain
1577 compatibility by calling rand() but allow the user to override it.
1578 See INSTALL for details. --Andy Dougherty 15 July 1998
1580 /* Now it's after 5.005, and Configure supports drand48() and random(),
1581 in addition to rand(). So the overrides should not be needed any more.
1582 --Jarkko Hietaniemi 27 September 1998
1585 #ifndef HAS_DRAND48_PROTO
1586 extern double drand48 _((void));
1599 if (!srand_called) {
1600 (void)seedDrand01((Rand_seed_t)seed());
1601 srand_called = TRUE;
1616 (void)seedDrand01((Rand_seed_t)anum);
1617 srand_called = TRUE;
1626 * This is really just a quick hack which grabs various garbage
1627 * values. It really should be a real hash algorithm which
1628 * spreads the effect of every input bit onto every output bit,
1629 * if someone who knows about such things would bother to write it.
1630 * Might be a good idea to add that function to CORE as well.
1631 * No numbers below come from careful analysis or anything here,
1632 * except they are primes and SEED_C1 > 1E6 to get a full-width
1633 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1634 * probably be bigger too.
1637 # define SEED_C1 1000003
1638 #define SEED_C4 73819
1640 # define SEED_C1 25747
1641 #define SEED_C4 20639
1645 #define SEED_C5 26107
1648 #ifndef PERL_NO_DEV_RANDOM
1653 # include <starlet.h>
1654 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1655 * in 100-ns units, typically incremented ever 10 ms. */
1656 unsigned int when[2];
1658 # ifdef HAS_GETTIMEOFDAY
1659 struct timeval when;
1665 /* This test is an escape hatch, this symbol isn't set by Configure. */
1666 #ifndef PERL_NO_DEV_RANDOM
1667 #ifndef PERL_RANDOM_DEVICE
1668 /* /dev/random isn't used by default because reads from it will block
1669 * if there isn't enough entropy available. You can compile with
1670 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1671 * is enough real entropy to fill the seed. */
1672 # define PERL_RANDOM_DEVICE "/dev/urandom"
1674 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1676 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1685 _ckvmssts(sys$gettim(when));
1686 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1688 # ifdef HAS_GETTIMEOFDAY
1689 gettimeofday(&when,(struct timezone *) 0);
1690 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1693 u = (U32)SEED_C1 * when;
1696 u += SEED_C3 * (U32)getpid();
1697 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1698 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1699 u += SEED_C5 * (U32)(UV)&when;
1706 djSP; dTARGET; tryAMAGICun(exp);
1718 djSP; dTARGET; tryAMAGICun(log);
1723 SET_NUMERIC_STANDARD();
1724 DIE("Can't take log of %g", value);
1734 djSP; dTARGET; tryAMAGICun(sqrt);
1739 SET_NUMERIC_STANDARD();
1740 DIE("Can't take sqrt of %g", value);
1742 value = sqrt(value);
1752 double value = TOPn;
1755 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1761 (void)modf(value, &value);
1763 (void)modf(-value, &value);
1778 djSP; dTARGET; tryAMAGICun(abs);
1780 double value = TOPn;
1783 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1784 (iv = SvIVX(TOPs)) != IV_MIN) {
1806 XPUSHu(scan_hex(tmps, 99, &argtype));
1819 while (*tmps && isSPACE(*tmps))
1824 value = scan_hex(++tmps, 99, &argtype);
1825 else if (*tmps == 'b')
1826 value = scan_bin(++tmps, 99, &argtype);
1828 value = scan_oct(tmps, 99, &argtype);
1840 SETi( sv_len_utf8(TOPs) );
1844 SETi( sv_len(TOPs) );
1858 I32 lvalue = PL_op->op_flags & OPf_MOD;
1860 I32 arybase = PL_curcop->cop_arybase;
1864 SvTAINTED_off(TARG); /* decontaminate */
1868 repl = SvPV(sv, repl_len);
1875 tmps = SvPV(sv, curlen);
1877 utfcurlen = sv_len_utf8(sv);
1878 if (utfcurlen == curlen)
1886 if (pos >= arybase) {
1904 else if (len >= 0) {
1906 if (rem > (I32)curlen)
1920 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1921 warner(WARN_SUBSTR, "substr outside of string");
1926 sv_pos_u2b(sv, &pos, &rem);
1928 sv_setpvn(TARG, tmps, rem);
1929 if (lvalue) { /* it's an lvalue! */
1930 if (!SvGMAGICAL(sv)) {
1934 if (ckWARN(WARN_SUBSTR))
1936 "Attempt to use reference as lvalue in substr");
1938 if (SvOK(sv)) /* is it defined ? */
1939 (void)SvPOK_only(sv);
1941 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1944 if (SvTYPE(TARG) < SVt_PVLV) {
1945 sv_upgrade(TARG, SVt_PVLV);
1946 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1950 if (LvTARG(TARG) != sv) {
1952 SvREFCNT_dec(LvTARG(TARG));
1953 LvTARG(TARG) = SvREFCNT_inc(sv);
1955 LvTARGOFF(TARG) = pos;
1956 LvTARGLEN(TARG) = rem;
1959 sv_insert(sv, pos, rem, repl, repl_len);
1962 PUSHs(TARG); /* avoid SvSETMAGIC here */
1969 register I32 size = POPi;
1970 register I32 offset = POPi;
1971 register SV *src = POPs;
1972 I32 lvalue = PL_op->op_flags & OPf_MOD;
1974 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1975 unsigned long retnum;
1978 SvTAINTED_off(TARG); /* decontaminate */
1979 offset *= size; /* turn into bit offset */
1980 len = (offset + size + 7) / 8;
1981 if (offset < 0 || size < 1)
1984 if (lvalue) { /* it's an lvalue! */
1985 if (SvTYPE(TARG) < SVt_PVLV) {
1986 sv_upgrade(TARG, SVt_PVLV);
1987 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1991 if (LvTARG(TARG) != src) {
1993 SvREFCNT_dec(LvTARG(TARG));
1994 LvTARG(TARG) = SvREFCNT_inc(src);
1996 LvTARGOFF(TARG) = offset;
1997 LvTARGLEN(TARG) = size;
2005 if (offset >= srclen)
2008 retnum = (unsigned long) s[offset] << 8;
2010 else if (size == 32) {
2011 if (offset >= srclen)
2013 else if (offset + 1 >= srclen)
2014 retnum = (unsigned long) s[offset] << 24;
2015 else if (offset + 2 >= srclen)
2016 retnum = ((unsigned long) s[offset] << 24) +
2017 ((unsigned long) s[offset + 1] << 16);
2019 retnum = ((unsigned long) s[offset] << 24) +
2020 ((unsigned long) s[offset + 1] << 16) +
2021 (s[offset + 2] << 8);
2026 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2031 else if (size == 16)
2032 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2033 else if (size == 32)
2034 retnum = ((unsigned long) s[offset] << 24) +
2035 ((unsigned long) s[offset + 1] << 16) +
2036 (s[offset + 2] << 8) + s[offset+3];
2040 sv_setuv(TARG, (UV)retnum);
2055 I32 arybase = PL_curcop->cop_arybase;
2060 offset = POPi - arybase;
2063 tmps = SvPV(big, biglen);
2064 if (IN_UTF8 && offset > 0)
2065 sv_pos_u2b(big, &offset, 0);
2068 else if (offset > biglen)
2070 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2071 (unsigned char*)tmps + biglen, little, 0)))
2074 retval = tmps2 - tmps;
2075 if (IN_UTF8 && retval > 0)
2076 sv_pos_b2u(big, &retval);
2077 PUSHi(retval + arybase);
2092 I32 arybase = PL_curcop->cop_arybase;
2098 tmps2 = SvPV(little, llen);
2099 tmps = SvPV(big, blen);
2103 if (IN_UTF8 && offset > 0)
2104 sv_pos_u2b(big, &offset, 0);
2105 offset = offset - arybase + llen;
2109 else if (offset > blen)
2111 if (!(tmps2 = rninstr(tmps, tmps + offset,
2112 tmps2, tmps2 + llen)))
2115 retval = tmps2 - tmps;
2116 if (IN_UTF8 && retval > 0)
2117 sv_pos_b2u(big, &retval);
2118 PUSHi(retval + arybase);
2124 djSP; dMARK; dORIGMARK; dTARGET;
2125 #ifdef USE_LOCALE_NUMERIC
2126 if (PL_op->op_private & OPpLOCALE)
2127 SET_NUMERIC_LOCAL();
2129 SET_NUMERIC_STANDARD();
2131 do_sprintf(TARG, SP-MARK, MARK+1);
2132 TAINT_IF(SvTAINTED(TARG));
2143 U8 *tmps = (U8*)POPpx;
2146 if (IN_UTF8 && (*tmps & 0x80))
2147 value = utf8_to_uv(tmps, &retlen);
2149 value = (UV)(*tmps & 255);
2160 (void)SvUPGRADE(TARG,SVt_PV);
2162 if (IN_UTF8 && value >= 128) {
2165 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2166 SvCUR_set(TARG, tmps - SvPVX(TARG));
2168 (void)SvPOK_only(TARG);
2178 (void)SvPOK_only(TARG);
2185 djSP; dTARGET; dPOPTOPssrl;
2188 char *tmps = SvPV(left, n_a);
2190 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2192 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2196 "The crypt() function is unimplemented due to excessive paranoia.");
2209 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2213 UV uv = utf8_to_uv(s, &ulen);
2215 if (PL_op->op_private & OPpLOCALE) {
2218 uv = toTITLE_LC_uni(uv);
2221 uv = toTITLE_utf8(s);
2223 tend = uv_to_utf8(tmpbuf, uv);
2225 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2227 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2228 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2232 s = (U8*)SvPV_force(sv, slen);
2233 Copy(tmpbuf, s, ulen, U8);
2238 if (!SvPADTMP(sv)) {
2244 s = (U8*)SvPV_force(sv, slen);
2246 if (PL_op->op_private & OPpLOCALE) {
2249 *s = toUPPER_LC(*s);
2265 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2269 UV uv = utf8_to_uv(s, &ulen);
2271 if (PL_op->op_private & OPpLOCALE) {
2274 uv = toLOWER_LC_uni(uv);
2277 uv = toLOWER_utf8(s);
2279 tend = uv_to_utf8(tmpbuf, uv);
2281 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2283 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2284 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2288 s = (U8*)SvPV_force(sv, slen);
2289 Copy(tmpbuf, s, ulen, U8);
2294 if (!SvPADTMP(sv)) {
2300 s = (U8*)SvPV_force(sv, slen);
2302 if (PL_op->op_private & OPpLOCALE) {
2305 *s = toLOWER_LC(*s);
2328 s = (U8*)SvPV(sv,len);
2330 sv_setpvn(TARG, "", 0);
2335 (void)SvUPGRADE(TARG, SVt_PV);
2336 SvGROW(TARG, (len * 2) + 1);
2337 (void)SvPOK_only(TARG);
2338 d = (U8*)SvPVX(TARG);
2340 if (PL_op->op_private & OPpLOCALE) {
2344 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2350 d = uv_to_utf8(d, toUPPER_utf8( s ));
2355 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2360 if (!SvPADTMP(sv)) {
2367 s = (U8*)SvPV_force(sv, len);
2369 register U8 *send = s + len;
2371 if (PL_op->op_private & OPpLOCALE) {
2374 for (; s < send; s++)
2375 *s = toUPPER_LC(*s);
2378 for (; s < send; s++)
2398 s = (U8*)SvPV(sv,len);
2400 sv_setpvn(TARG, "", 0);
2405 (void)SvUPGRADE(TARG, SVt_PV);
2406 SvGROW(TARG, (len * 2) + 1);
2407 (void)SvPOK_only(TARG);
2408 d = (U8*)SvPVX(TARG);
2410 if (PL_op->op_private & OPpLOCALE) {
2414 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2420 d = uv_to_utf8(d, toLOWER_utf8(s));
2425 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2430 if (!SvPADTMP(sv)) {
2437 s = (U8*)SvPV_force(sv, len);
2439 register U8 *send = s + len;
2441 if (PL_op->op_private & OPpLOCALE) {
2444 for (; s < send; s++)
2445 *s = toLOWER_LC(*s);
2448 for (; s < send; s++)
2460 register char *s = SvPV(sv,len);
2464 (void)SvUPGRADE(TARG, SVt_PV);
2465 SvGROW(TARG, (len * 2) + 1);
2470 STRLEN ulen = UTF8SKIP(s);
2493 SvCUR_set(TARG, d - SvPVX(TARG));
2494 (void)SvPOK_only(TARG);
2497 sv_setpvn(TARG, s, len);
2506 djSP; dMARK; dORIGMARK;
2508 register AV* av = (AV*)POPs;
2509 register I32 lval = PL_op->op_flags & OPf_MOD;
2510 I32 arybase = PL_curcop->cop_arybase;
2513 if (SvTYPE(av) == SVt_PVAV) {
2514 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2516 for (svp = MARK + 1; svp <= SP; svp++) {
2521 if (max > AvMAX(av))
2524 while (++MARK <= SP) {
2525 elem = SvIVx(*MARK);
2529 svp = av_fetch(av, elem, lval);
2531 if (!svp || *svp == &PL_sv_undef)
2532 DIE(PL_no_aelem, elem);
2533 if (PL_op->op_private & OPpLVAL_INTRO)
2534 save_aelem(av, elem, svp);
2536 *MARK = svp ? *svp : &PL_sv_undef;
2539 if (GIMME != G_ARRAY) {
2547 /* Associative arrays. */
2552 HV *hash = (HV*)POPs;
2554 I32 gimme = GIMME_V;
2555 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2558 /* might clobber stack_sp */
2559 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2564 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2565 if (gimme == G_ARRAY) {
2567 /* might clobber stack_sp */
2568 sv_setsv(TARG, realhv ?
2569 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2574 else if (gimme == G_SCALAR)
2593 I32 gimme = GIMME_V;
2594 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2598 if (PL_op->op_private & OPpSLICE) {
2602 hvtype = SvTYPE(hv);
2603 while (++MARK <= SP) {
2604 if (hvtype == SVt_PVHV)
2605 sv = hv_delete_ent(hv, *MARK, discard, 0);
2607 DIE("Not a HASH reference");
2608 *MARK = sv ? sv : &PL_sv_undef;
2612 else if (gimme == G_SCALAR) {
2621 if (SvTYPE(hv) == SVt_PVHV)
2622 sv = hv_delete_ent(hv, keysv, discard, 0);
2624 DIE("Not a HASH reference");
2638 if (SvTYPE(hv) == SVt_PVHV) {
2639 if (hv_exists_ent(hv, tmpsv, 0))
2641 } else if (SvTYPE(hv) == SVt_PVAV) {
2642 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2645 DIE("Not a HASH reference");
2652 djSP; dMARK; dORIGMARK;
2653 register HV *hv = (HV*)POPs;
2654 register I32 lval = PL_op->op_flags & OPf_MOD;
2655 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2657 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2658 DIE("Can't localize pseudo-hash element");
2660 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2661 while (++MARK <= SP) {
2665 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2666 svp = he ? &HeVAL(he) : 0;
2668 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2671 if (!svp || *svp == &PL_sv_undef) {
2673 DIE(PL_no_helem, SvPV(keysv, n_a));
2675 if (PL_op->op_private & OPpLVAL_INTRO)
2676 save_helem(hv, keysv, svp);
2678 *MARK = svp ? *svp : &PL_sv_undef;
2681 if (GIMME != G_ARRAY) {
2689 /* List operators. */
2694 if (GIMME != G_ARRAY) {
2696 *MARK = *SP; /* unwanted list, return last item */
2698 *MARK = &PL_sv_undef;
2707 SV **lastrelem = PL_stack_sp;
2708 SV **lastlelem = PL_stack_base + POPMARK;
2709 SV **firstlelem = PL_stack_base + POPMARK + 1;
2710 register SV **firstrelem = lastlelem + 1;
2711 I32 arybase = PL_curcop->cop_arybase;
2712 I32 lval = PL_op->op_flags & OPf_MOD;
2713 I32 is_something_there = lval;
2715 register I32 max = lastrelem - lastlelem;
2716 register SV **lelem;
2719 if (GIMME != G_ARRAY) {
2720 ix = SvIVx(*lastlelem);
2725 if (ix < 0 || ix >= max)
2726 *firstlelem = &PL_sv_undef;
2728 *firstlelem = firstrelem[ix];
2734 SP = firstlelem - 1;
2738 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2743 *lelem = &PL_sv_undef;
2744 else if (!(*lelem = firstrelem[ix]))
2745 *lelem = &PL_sv_undef;
2749 if (ix >= max || !(*lelem = firstrelem[ix]))
2750 *lelem = &PL_sv_undef;
2752 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2753 is_something_there = TRUE;
2755 if (is_something_there)
2758 SP = firstlelem - 1;
2764 djSP; dMARK; dORIGMARK;
2765 I32 items = SP - MARK;
2766 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2767 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2774 djSP; dMARK; dORIGMARK;
2775 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2779 SV *val = NEWSV(46, 0);
2781 sv_setsv(val, *++MARK);
2782 else if (ckWARN(WARN_UNSAFE))
2783 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2784 (void)hv_store_ent(hv,key,val,0);
2793 djSP; dMARK; dORIGMARK;
2794 register AV *ary = (AV*)*++MARK;
2798 register I32 offset;
2799 register I32 length;
2806 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2807 *MARK-- = SvTIED_obj((SV*)ary, mg);
2811 perl_call_method("SPLICE",GIMME_V);
2820 offset = i = SvIVx(*MARK);
2822 offset += AvFILLp(ary) + 1;
2824 offset -= PL_curcop->cop_arybase;
2826 DIE(PL_no_aelem, i);
2828 length = SvIVx(*MARK++);
2830 length += AvFILLp(ary) - offset + 1;
2836 length = AvMAX(ary) + 1; /* close enough to infinity */
2840 length = AvMAX(ary) + 1;
2842 if (offset > AvFILLp(ary) + 1)
2843 offset = AvFILLp(ary) + 1;
2844 after = AvFILLp(ary) + 1 - (offset + length);
2845 if (after < 0) { /* not that much array */
2846 length += after; /* offset+length now in array */
2852 /* At this point, MARK .. SP-1 is our new LIST */
2855 diff = newlen - length;
2856 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2859 if (diff < 0) { /* shrinking the area */
2861 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2862 Copy(MARK, tmparyval, newlen, SV*);
2865 MARK = ORIGMARK + 1;
2866 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2867 MEXTEND(MARK, length);
2868 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2870 EXTEND_MORTAL(length);
2871 for (i = length, dst = MARK; i; i--) {
2872 sv_2mortal(*dst); /* free them eventualy */
2879 *MARK = AvARRAY(ary)[offset+length-1];
2882 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2883 SvREFCNT_dec(*dst++); /* free them now */
2886 AvFILLp(ary) += diff;
2888 /* pull up or down? */
2890 if (offset < after) { /* easier to pull up */
2891 if (offset) { /* esp. if nothing to pull */
2892 src = &AvARRAY(ary)[offset-1];
2893 dst = src - diff; /* diff is negative */
2894 for (i = offset; i > 0; i--) /* can't trust Copy */
2898 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2902 if (after) { /* anything to pull down? */
2903 src = AvARRAY(ary) + offset + length;
2904 dst = src + diff; /* diff is negative */
2905 Move(src, dst, after, SV*);
2907 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2908 /* avoid later double free */
2912 dst[--i] = &PL_sv_undef;
2915 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2917 *dst = NEWSV(46, 0);
2918 sv_setsv(*dst++, *src++);
2920 Safefree(tmparyval);
2923 else { /* no, expanding (or same) */
2925 New(452, tmparyval, length, SV*); /* so remember deletion */
2926 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2929 if (diff > 0) { /* expanding */
2931 /* push up or down? */
2933 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2937 Move(src, dst, offset, SV*);
2939 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2941 AvFILLp(ary) += diff;
2944 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2945 av_extend(ary, AvFILLp(ary) + diff);
2946 AvFILLp(ary) += diff;
2949 dst = AvARRAY(ary) + AvFILLp(ary);
2951 for (i = after; i; i--) {
2958 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2959 *dst = NEWSV(46, 0);
2960 sv_setsv(*dst++, *src++);
2962 MARK = ORIGMARK + 1;
2963 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2965 Copy(tmparyval, MARK, length, SV*);
2967 EXTEND_MORTAL(length);
2968 for (i = length, dst = MARK; i; i--) {
2969 sv_2mortal(*dst); /* free them eventualy */
2973 Safefree(tmparyval);
2977 else if (length--) {
2978 *MARK = tmparyval[length];
2981 while (length-- > 0)
2982 SvREFCNT_dec(tmparyval[length]);
2984 Safefree(tmparyval);
2987 *MARK = &PL_sv_undef;
2995 djSP; dMARK; dORIGMARK; dTARGET;
2996 register AV *ary = (AV*)*++MARK;
2997 register SV *sv = &PL_sv_undef;
3000 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3001 *MARK-- = SvTIED_obj((SV*)ary, mg);
3005 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3010 /* Why no pre-extend of ary here ? */
3011 for (++MARK; MARK <= SP; MARK++) {
3014 sv_setsv(sv, *MARK);
3019 PUSHi( AvFILL(ary) + 1 );
3027 SV *sv = av_pop(av);
3029 (void)sv_2mortal(sv);
3038 SV *sv = av_shift(av);
3043 (void)sv_2mortal(sv);
3050 djSP; dMARK; dORIGMARK; dTARGET;
3051 register AV *ary = (AV*)*++MARK;
3056 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3057 *MARK-- = SvTIED_obj((SV*)ary, mg);
3061 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3066 av_unshift(ary, SP - MARK);
3069 sv_setsv(sv, *++MARK);
3070 (void)av_store(ary, i++, sv);
3074 PUSHi( AvFILL(ary) + 1 );
3084 if (GIMME == G_ARRAY) {
3095 register char *down;
3101 do_join(TARG, &PL_sv_no, MARK, SP);
3103 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3104 up = SvPV_force(TARG, len);
3106 if (IN_UTF8) { /* first reverse each character */
3107 U8* s = (U8*)SvPVX(TARG);
3108 U8* send = (U8*)(s + len);
3117 down = (char*)(s - 1);
3118 if (s > send || !((*down & 0xc0) == 0x80)) {
3119 warn("Malformed UTF-8 character");
3131 down = SvPVX(TARG) + len - 1;
3137 (void)SvPOK_only(TARG);
3146 mul128(SV *sv, U8 m)
3149 char *s = SvPV(sv, len);
3153 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3154 SV *tmpNew = newSVpv("0000000000", 10);
3156 sv_catsv(tmpNew, sv);
3157 SvREFCNT_dec(sv); /* free old sv */
3162 while (!*t) /* trailing '\0'? */
3165 i = ((*t - '0') << 7) + m;
3166 *(t--) = '0' + (i % 10);
3172 /* Explosives and implosives. */
3174 static const char uuemap[] =
3175 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3176 static char uudmap[256]; /* Initialised on first use */
3177 #if 'I' == 73 && 'J' == 74
3178 /* On an ASCII/ISO kind of system */
3179 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3182 Some other sort of character set - use memchr() so we don't match
3185 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3193 I32 gimme = GIMME_V;
3197 register char *pat = SvPV(left, llen);
3198 register char *s = SvPV(right, rlen);
3199 char *strend = s + rlen;
3201 register char *patend = pat + llen;
3206 /* These must not be in registers: */
3223 register U32 culong;
3225 static char* bitcount = 0;
3228 if (gimme != G_ARRAY) { /* arrange to do first one only */
3230 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3231 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3233 while (isDIGIT(*patend) || *patend == '*')
3239 while (pat < patend) {
3241 datumtype = *pat++ & 0xFF;
3242 if (isSPACE(datumtype))
3246 else if (*pat == '*') {
3247 len = strend - strbeg; /* long enough */
3250 else if (isDIGIT(*pat)) {
3252 while (isDIGIT(*pat))
3253 len = (len * 10) + (*pat++ - '0');
3256 len = (datumtype != '@');
3259 croak("Invalid type in unpack: '%c'", (int)datumtype);
3260 case ',': /* grandfather in commas but with a warning */
3261 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3262 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3265 if (len == 1 && pat[-1] != '1')
3274 if (len > strend - strbeg)
3275 DIE("@ outside of string");
3279 if (len > s - strbeg)
3280 DIE("X outside of string");
3284 if (len > strend - s)
3285 DIE("x outside of string");
3290 if (len > strend - s)
3293 goto uchar_checksum;
3294 sv = NEWSV(35, len);
3295 sv_setpvn(sv, s, len);
3297 if (datumtype == 'A') {
3298 aptr = s; /* borrow register */
3299 s = SvPVX(sv) + len - 1;
3300 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3303 SvCUR_set(sv, s - SvPVX(sv));
3304 s = aptr; /* unborrow register */
3306 XPUSHs(sv_2mortal(sv));
3310 if (pat[-1] == '*' || len > (strend - s) * 8)
3311 len = (strend - s) * 8;
3314 Newz(601, bitcount, 256, char);
3315 for (bits = 1; bits < 256; bits++) {
3316 if (bits & 1) bitcount[bits]++;
3317 if (bits & 2) bitcount[bits]++;
3318 if (bits & 4) bitcount[bits]++;
3319 if (bits & 8) bitcount[bits]++;
3320 if (bits & 16) bitcount[bits]++;
3321 if (bits & 32) bitcount[bits]++;
3322 if (bits & 64) bitcount[bits]++;
3323 if (bits & 128) bitcount[bits]++;
3327 culong += bitcount[*(unsigned char*)s++];
3332 if (datumtype == 'b') {
3334 if (bits & 1) culong++;
3340 if (bits & 128) culong++;
3347 sv = NEWSV(35, len + 1);
3350 aptr = pat; /* borrow register */
3352 if (datumtype == 'b') {
3354 for (len = 0; len < aint; len++) {
3355 if (len & 7) /*SUPPRESS 595*/
3359 *pat++ = '0' + (bits & 1);
3364 for (len = 0; len < aint; len++) {
3369 *pat++ = '0' + ((bits & 128) != 0);
3373 pat = aptr; /* unborrow register */
3374 XPUSHs(sv_2mortal(sv));
3378 if (pat[-1] == '*' || len > (strend - s) * 2)
3379 len = (strend - s) * 2;
3380 sv = NEWSV(35, len + 1);
3383 aptr = pat; /* borrow register */
3385 if (datumtype == 'h') {
3387 for (len = 0; len < aint; len++) {
3392 *pat++ = PL_hexdigit[bits & 15];
3397 for (len = 0; len < aint; len++) {
3402 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3406 pat = aptr; /* unborrow register */
3407 XPUSHs(sv_2mortal(sv));
3410 if (len > strend - s)
3415 if (aint >= 128) /* fake up signed chars */
3425 if (aint >= 128) /* fake up signed chars */
3428 sv_setiv(sv, (IV)aint);
3429 PUSHs(sv_2mortal(sv));
3434 if (len > strend - s)
3449 sv_setiv(sv, (IV)auint);
3450 PUSHs(sv_2mortal(sv));
3455 if (len > strend - s)
3458 while (len-- > 0 && s < strend) {
3459 auint = utf8_to_uv((U8*)s, &along);
3462 cdouble += (double)auint;
3470 while (len-- > 0 && s < strend) {
3471 auint = utf8_to_uv((U8*)s, &along);
3474 sv_setuv(sv, (UV)auint);
3475 PUSHs(sv_2mortal(sv));
3480 along = (strend - s) / SIZE16;
3497 sv_setiv(sv, (IV)ashort);
3498 PUSHs(sv_2mortal(sv));
3505 along = (strend - s) / SIZE16;
3510 COPY16(s, &aushort);
3513 if (datumtype == 'n')
3514 aushort = PerlSock_ntohs(aushort);
3517 if (datumtype == 'v')
3518 aushort = vtohs(aushort);
3527 COPY16(s, &aushort);
3531 if (datumtype == 'n')
3532 aushort = PerlSock_ntohs(aushort);
3535 if (datumtype == 'v')
3536 aushort = vtohs(aushort);
3538 sv_setiv(sv, (IV)aushort);
3539 PUSHs(sv_2mortal(sv));
3544 along = (strend - s) / sizeof(int);
3549 Copy(s, &aint, 1, int);
3552 cdouble += (double)aint;
3561 Copy(s, &aint, 1, int);
3565 /* Without the dummy below unpack("i", pack("i",-1))
3566 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3567 * cc with optimization turned on */
3569 sv_setiv(sv, (IV)aint) :
3571 sv_setiv(sv, (IV)aint);
3572 PUSHs(sv_2mortal(sv));
3577 along = (strend - s) / sizeof(unsigned int);
3582 Copy(s, &auint, 1, unsigned int);
3583 s += sizeof(unsigned int);
3585 cdouble += (double)auint;
3594 Copy(s, &auint, 1, unsigned int);
3595 s += sizeof(unsigned int);
3598 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3599 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3600 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3601 * with optimization turned on.
3602 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3603 * does not have this problem even with -O4)
3606 sv_setuv(sv, (UV)auint) :
3608 sv_setuv(sv, (UV)auint);
3609 PUSHs(sv_2mortal(sv));
3614 along = (strend - s) / SIZE32;
3622 cdouble += (double)along;
3634 sv_setiv(sv, (IV)along);
3635 PUSHs(sv_2mortal(sv));
3642 along = (strend - s) / SIZE32;
3650 if (datumtype == 'N')
3651 aulong = PerlSock_ntohl(aulong);
3654 if (datumtype == 'V')
3655 aulong = vtohl(aulong);
3658 cdouble += (double)aulong;
3670 if (datumtype == 'N')
3671 aulong = PerlSock_ntohl(aulong);
3674 if (datumtype == 'V')
3675 aulong = vtohl(aulong);
3678 sv_setuv(sv, (UV)aulong);
3679 PUSHs(sv_2mortal(sv));
3684 along = (strend - s) / sizeof(char*);
3690 if (sizeof(char*) > strend - s)
3693 Copy(s, &aptr, 1, char*);
3699 PUSHs(sv_2mortal(sv));
3709 while ((len > 0) && (s < strend)) {
3710 auv = (auv << 7) | (*s & 0x7f);
3711 if (!(*s++ & 0x80)) {
3715 PUSHs(sv_2mortal(sv));
3719 else if (++bytes >= sizeof(UV)) { /* promote to string */
3723 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3724 while (s < strend) {
3725 sv = mul128(sv, *s & 0x7f);
3726 if (!(*s++ & 0x80)) {
3735 PUSHs(sv_2mortal(sv));
3740 if ((s >= strend) && bytes)
3741 croak("Unterminated compressed integer");
3746 if (sizeof(char*) > strend - s)
3749 Copy(s, &aptr, 1, char*);
3754 sv_setpvn(sv, aptr, len);
3755 PUSHs(sv_2mortal(sv));
3759 along = (strend - s) / sizeof(Quad_t);
3765 if (s + sizeof(Quad_t) > strend)
3768 Copy(s, &aquad, 1, Quad_t);
3769 s += sizeof(Quad_t);
3772 if (aquad >= IV_MIN && aquad <= IV_MAX)
3773 sv_setiv(sv, (IV)aquad);
3775 sv_setnv(sv, (double)aquad);
3776 PUSHs(sv_2mortal(sv));
3780 along = (strend - s) / sizeof(Quad_t);
3786 if (s + sizeof(Uquad_t) > strend)
3789 Copy(s, &auquad, 1, Uquad_t);
3790 s += sizeof(Uquad_t);
3793 if (auquad <= UV_MAX)
3794 sv_setuv(sv, (UV)auquad);
3796 sv_setnv(sv, (double)auquad);
3797 PUSHs(sv_2mortal(sv));
3801 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3804 along = (strend - s) / sizeof(float);
3809 Copy(s, &afloat, 1, float);
3818 Copy(s, &afloat, 1, float);
3821 sv_setnv(sv, (double)afloat);
3822 PUSHs(sv_2mortal(sv));
3828 along = (strend - s) / sizeof(double);
3833 Copy(s, &adouble, 1, double);
3834 s += sizeof(double);
3842 Copy(s, &adouble, 1, double);
3843 s += sizeof(double);
3845 sv_setnv(sv, (double)adouble);
3846 PUSHs(sv_2mortal(sv));
3852 * Initialise the decode mapping. By using a table driven
3853 * algorithm, the code will be character-set independent
3854 * (and just as fast as doing character arithmetic)
3856 if (uudmap['M'] == 0) {
3859 for (i = 0; i < sizeof(uuemap); i += 1)
3860 uudmap[uuemap[i]] = i;
3862 * Because ' ' and '`' map to the same value,
3863 * we need to decode them both the same.
3868 along = (strend - s) * 3 / 4;
3869 sv = NEWSV(42, along);
3872 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3877 len = uudmap[*s++] & 077;
3879 if (s < strend && ISUUCHAR(*s))
3880 a = uudmap[*s++] & 077;
3883 if (s < strend && ISUUCHAR(*s))
3884 b = uudmap[*s++] & 077;
3887 if (s < strend && ISUUCHAR(*s))
3888 c = uudmap[*s++] & 077;
3891 if (s < strend && ISUUCHAR(*s))
3892 d = uudmap[*s++] & 077;
3895 hunk[0] = (a << 2) | (b >> 4);
3896 hunk[1] = (b << 4) | (c >> 2);
3897 hunk[2] = (c << 6) | d;
3898 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3903 else if (s[1] == '\n') /* possible checksum byte */
3906 XPUSHs(sv_2mortal(sv));
3911 if (strchr("fFdD", datumtype) ||
3912 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3916 while (checksum >= 16) {
3920 while (checksum >= 4) {
3926 along = (1 << checksum) - 1;
3927 while (cdouble < 0.0)
3929 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3930 sv_setnv(sv, cdouble);
3933 if (checksum < 32) {
3934 aulong = (1 << checksum) - 1;
3937 sv_setuv(sv, (UV)culong);
3939 XPUSHs(sv_2mortal(sv));
3943 if (SP == oldsp && gimme == G_SCALAR)
3944 PUSHs(&PL_sv_undef);
3949 doencodes(register SV *sv, register char *s, register I32 len)
3953 *hunk = uuemap[len];
3954 sv_catpvn(sv, hunk, 1);
3957 hunk[0] = uuemap[(077 & (*s >> 2))];
3958 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3959 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3960 hunk[3] = uuemap[(077 & (s[2] & 077))];
3961 sv_catpvn(sv, hunk, 4);
3966 char r = (len > 1 ? s[1] : '\0');
3967 hunk[0] = uuemap[(077 & (*s >> 2))];
3968 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3969 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3970 hunk[3] = uuemap[0];
3971 sv_catpvn(sv, hunk, 4);
3973 sv_catpvn(sv, "\n", 1);
3977 is_an_int(char *s, STRLEN l)
3980 SV *result = newSVpv("", l);
3981 char *result_c = SvPV(result, n_a); /* convenience */
3982 char *out = result_c;
3992 SvREFCNT_dec(result);
4015 SvREFCNT_dec(result);
4021 SvCUR_set(result, out - result_c);
4026 div128(SV *pnum, bool *done)
4027 /* must be '\0' terminated */
4031 char *s = SvPV(pnum, len);
4040 i = m * 10 + (*t - '0');
4042 r = (i >> 7); /* r < 10 */
4049 SvCUR_set(pnum, (STRLEN) (t - s));
4056 djSP; dMARK; dORIGMARK; dTARGET;
4057 register SV *cat = TARG;
4060 register char *pat = SvPVx(*++MARK, fromlen);
4061 register char *patend = pat + fromlen;
4066 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4067 static char *space10 = " ";
4069 /* These must not be in registers: */
4087 sv_setpvn(cat, "", 0);
4088 while (pat < patend) {
4089 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4090 datumtype = *pat++ & 0xFF;
4091 if (isSPACE(datumtype))
4094 len = strchr("@Xxu", datumtype) ? 0 : items;
4097 else if (isDIGIT(*pat)) {
4099 while (isDIGIT(*pat))
4100 len = (len * 10) + (*pat++ - '0');
4106 croak("Invalid type in pack: '%c'", (int)datumtype);
4107 case ',': /* grandfather in commas but with a warning */
4108 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4109 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4112 DIE("%% may only be used in unpack");
4123 if (SvCUR(cat) < len)
4124 DIE("X outside of string");
4131 sv_catpvn(cat, null10, 10);
4134 sv_catpvn(cat, null10, len);
4139 aptr = SvPV(fromstr, fromlen);
4143 sv_catpvn(cat, aptr, len);
4145 sv_catpvn(cat, aptr, fromlen);
4147 if (datumtype == 'A') {
4149 sv_catpvn(cat, space10, 10);
4152 sv_catpvn(cat, space10, len);
4156 sv_catpvn(cat, null10, 10);
4159 sv_catpvn(cat, null10, len);
4166 char *savepat = pat;
4171 aptr = SvPV(fromstr, fromlen);
4176 SvCUR(cat) += (len+7)/8;
4177 SvGROW(cat, SvCUR(cat) + 1);
4178 aptr = SvPVX(cat) + aint;
4183 if (datumtype == 'B') {
4184 for (len = 0; len++ < aint;) {
4185 items |= *pat++ & 1;
4189 *aptr++ = items & 0xff;
4195 for (len = 0; len++ < aint;) {
4201 *aptr++ = items & 0xff;
4207 if (datumtype == 'B')
4208 items <<= 7 - (aint & 7);
4210 items >>= 7 - (aint & 7);
4211 *aptr++ = items & 0xff;
4213 pat = SvPVX(cat) + SvCUR(cat);
4224 char *savepat = pat;
4229 aptr = SvPV(fromstr, fromlen);
4234 SvCUR(cat) += (len+1)/2;
4235 SvGROW(cat, SvCUR(cat) + 1);
4236 aptr = SvPVX(cat) + aint;
4241 if (datumtype == 'H') {
4242 for (len = 0; len++ < aint;) {
4244 items |= ((*pat++ & 15) + 9) & 15;
4246 items |= *pat++ & 15;
4250 *aptr++ = items & 0xff;
4256 for (len = 0; len++ < aint;) {
4258 items |= (((*pat++ & 15) + 9) & 15) << 4;
4260 items |= (*pat++ & 15) << 4;
4264 *aptr++ = items & 0xff;
4270 *aptr++ = items & 0xff;
4271 pat = SvPVX(cat) + SvCUR(cat);
4283 aint = SvIV(fromstr);
4285 sv_catpvn(cat, &achar, sizeof(char));
4291 auint = SvUV(fromstr);
4292 SvGROW(cat, SvCUR(cat) + 10);
4293 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4298 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4303 afloat = (float)SvNV(fromstr);
4304 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4311 adouble = (double)SvNV(fromstr);
4312 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4318 ashort = (I16)SvIV(fromstr);
4320 ashort = PerlSock_htons(ashort);
4322 CAT16(cat, &ashort);
4328 ashort = (I16)SvIV(fromstr);
4330 ashort = htovs(ashort);
4332 CAT16(cat, &ashort);
4339 ashort = (I16)SvIV(fromstr);
4340 CAT16(cat, &ashort);
4346 auint = SvUV(fromstr);
4347 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4353 adouble = floor(SvNV(fromstr));
4356 croak("Cannot compress negative numbers");
4362 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4363 adouble <= UV_MAX_cxux
4370 char buf[1 + sizeof(UV)];
4371 char *in = buf + sizeof(buf);
4372 UV auv = U_V(adouble);;
4375 *--in = (auv & 0x7f) | 0x80;
4378 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4379 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4381 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4382 char *from, *result, *in;
4387 /* Copy string and check for compliance */
4388 from = SvPV(fromstr, len);
4389 if ((norm = is_an_int(from, len)) == NULL)
4390 croak("can compress only unsigned integer");
4392 New('w', result, len, char);
4396 *--in = div128(norm, &done) | 0x80;
4397 result[len - 1] &= 0x7F; /* clear continue bit */
4398 sv_catpvn(cat, in, (result + len) - in);
4400 SvREFCNT_dec(norm); /* free norm */
4402 else if (SvNOKp(fromstr)) {
4403 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4404 char *in = buf + sizeof(buf);
4407 double next = floor(adouble / 128);
4408 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4409 if (--in < buf) /* this cannot happen ;-) */
4410 croak ("Cannot compress integer");
4412 } while (adouble > 0);
4413 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4414 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4417 croak("Cannot compress non integer");
4423 aint = SvIV(fromstr);
4424 sv_catpvn(cat, (char*)&aint, sizeof(int));
4430 aulong = SvUV(fromstr);
4432 aulong = PerlSock_htonl(aulong);
4434 CAT32(cat, &aulong);
4440 aulong = SvUV(fromstr);
4442 aulong = htovl(aulong);
4444 CAT32(cat, &aulong);
4450 aulong = SvUV(fromstr);
4451 CAT32(cat, &aulong);
4457 along = SvIV(fromstr);
4465 auquad = (Uquad_t)SvIV(fromstr);
4466 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4472 aquad = (Quad_t)SvIV(fromstr);
4473 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4476 #endif /* HAS_QUAD */
4478 len = 1; /* assume SV is correct length */
4483 if (fromstr == &PL_sv_undef)
4487 /* XXX better yet, could spirit away the string to
4488 * a safe spot and hang on to it until the result
4489 * of pack() (and all copies of the result) are
4492 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4494 "Attempt to pack pointer to temporary value");
4495 if (SvPOK(fromstr) || SvNIOK(fromstr))
4496 aptr = SvPV(fromstr,n_a);
4498 aptr = SvPV_force(fromstr,n_a);
4500 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4505 aptr = SvPV(fromstr, fromlen);
4506 SvGROW(cat, fromlen * 4 / 3);
4511 while (fromlen > 0) {
4518 doencodes(cat, aptr, todo);
4537 register I32 limit = POPi; /* note, negative is forever */
4540 register char *s = SvPV(sv, len);
4541 char *strend = s + len;
4543 register REGEXP *rx;
4547 I32 maxiters = (strend - s) + 10;
4550 I32 origlimit = limit;
4553 AV *oldstack = PL_curstack;
4554 I32 gimme = GIMME_V;
4555 I32 oldsave = PL_savestack_ix;
4556 I32 make_mortal = 1;
4557 MAGIC *mg = (MAGIC *) NULL;
4560 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4565 DIE("panic: do_split");
4566 rx = pm->op_pmregexp;
4568 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4569 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4571 if (pm->op_pmreplroot)
4572 ary = GvAVn((GV*)pm->op_pmreplroot);
4573 else if (gimme != G_ARRAY)
4575 ary = (AV*)PL_curpad[0];
4577 ary = GvAVn(PL_defgv);
4578 #endif /* USE_THREADS */
4581 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4587 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4589 XPUSHs(SvTIED_obj((SV*)ary, mg));
4594 for (i = AvFILLp(ary); i >= 0; i--)
4595 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4597 /* temporarily switch stacks */
4598 SWITCHSTACK(PL_curstack, ary);
4602 base = SP - PL_stack_base;
4604 if (pm->op_pmflags & PMf_SKIPWHITE) {
4605 if (pm->op_pmflags & PMf_LOCALE) {
4606 while (isSPACE_LC(*s))
4614 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4615 SAVEINT(PL_multiline);
4616 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4620 limit = maxiters + 2;
4621 if (pm->op_pmflags & PMf_WHITE) {
4624 while (m < strend &&
4625 !((pm->op_pmflags & PMf_LOCALE)
4626 ? isSPACE_LC(*m) : isSPACE(*m)))
4631 dstr = NEWSV(30, m-s);
4632 sv_setpvn(dstr, s, m-s);
4638 while (s < strend &&
4639 ((pm->op_pmflags & PMf_LOCALE)
4640 ? isSPACE_LC(*s) : isSPACE(*s)))
4644 else if (strEQ("^", rx->precomp)) {
4647 for (m = s; m < strend && *m != '\n'; m++) ;
4651 dstr = NEWSV(30, m-s);
4652 sv_setpvn(dstr, s, m-s);
4659 else if (rx->check_substr && !rx->nparens
4660 && (rx->reganch & ROPT_CHECK_ALL)
4661 && !(rx->reganch & ROPT_ANCH)) {
4662 i = SvCUR(rx->check_substr);
4663 if (i == 1 && !SvTAIL(rx->check_substr)) {
4664 i = *SvPVX(rx->check_substr);
4667 for (m = s; m < strend && *m != i; m++) ;
4670 dstr = NEWSV(30, m-s);
4671 sv_setpvn(dstr, s, m-s);
4680 while (s < strend && --limit &&
4681 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4682 rx->check_substr, 0)) )
4685 dstr = NEWSV(31, m-s);
4686 sv_setpvn(dstr, s, m-s);
4695 maxiters += (strend - s) * rx->nparens;
4696 while (s < strend && --limit &&
4697 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4699 TAINT_IF(RX_MATCH_TAINTED(rx));
4701 && rx->subbase != orig) {
4706 strend = s + (strend - m);
4709 dstr = NEWSV(32, m-s);
4710 sv_setpvn(dstr, s, m-s);
4715 for (i = 1; i <= rx->nparens; i++) {
4719 dstr = NEWSV(33, m-s);
4720 sv_setpvn(dstr, s, m-s);
4723 dstr = NEWSV(33, 0);
4733 LEAVE_SCOPE(oldsave);
4734 iters = (SP - PL_stack_base) - base;
4735 if (iters > maxiters)
4738 /* keep field after final delim? */
4739 if (s < strend || (iters && origlimit)) {
4740 dstr = NEWSV(34, strend-s);
4741 sv_setpvn(dstr, s, strend-s);
4747 else if (!origlimit) {
4748 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4754 SWITCHSTACK(ary, oldstack);
4755 if (SvSMAGICAL(ary)) {
4760 if (gimme == G_ARRAY) {
4762 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4770 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4773 if (gimme == G_ARRAY) {
4774 /* EXTEND should not be needed - we just popped them */
4776 for (i=0; i < iters; i++) {
4777 SV **svp = av_fetch(ary, i, FALSE);
4778 PUSHs((svp) ? *svp : &PL_sv_undef);
4785 if (gimme == G_ARRAY)
4788 if (iters || !pm->op_pmreplroot) {
4798 unlock_condpair(void *svv)
4801 MAGIC *mg = mg_find((SV*)svv, 'm');
4804 croak("panic: unlock_condpair unlocking non-mutex");
4805 MUTEX_LOCK(MgMUTEXP(mg));
4806 if (MgOWNER(mg) != thr)
4807 croak("panic: unlock_condpair unlocking mutex that we don't own");
4809 COND_SIGNAL(MgOWNERCONDP(mg));
4810 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4811 (unsigned long)thr, (unsigned long)svv);)
4812 MUTEX_UNLOCK(MgMUTEXP(mg));
4814 #endif /* USE_THREADS */
4827 mg = condpair_magic(sv);
4828 MUTEX_LOCK(MgMUTEXP(mg));
4829 if (MgOWNER(mg) == thr)
4830 MUTEX_UNLOCK(MgMUTEXP(mg));
4833 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4835 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4836 (unsigned long)thr, (unsigned long)sv);)
4837 MUTEX_UNLOCK(MgMUTEXP(mg));
4838 save_destructor(unlock_condpair, sv);
4840 #endif /* USE_THREADS */
4841 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4842 || SvTYPE(retsv) == SVt_PVCV) {
4843 retsv = refto(retsv);
4854 if (PL_op->op_private & OPpLVAL_INTRO)
4855 PUSHs(*save_threadsv(PL_op->op_targ));
4857 PUSHs(THREADSV(PL_op->op_targ));
4860 DIE("tried to access per-thread data in non-threaded perl");
4861 #endif /* USE_THREADS */