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 /* variations on pp_null */
116 /* XXX I can't imagine anyone who doesn't have this actually _needs_
117 it, since pid_t is an integral type.
120 #ifdef NEED_GETPID_PROTO
121 extern Pid_t getpid (void);
127 if (GIMME_V == G_SCALAR)
128 XPUSHs(&PL_sv_undef);
142 if (PL_op->op_private & OPpLVAL_INTRO)
143 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
145 if (PL_op->op_flags & OPf_REF) {
149 if (GIMME == G_ARRAY) {
150 I32 maxarg = AvFILL((AV*)TARG) + 1;
152 if (SvMAGICAL(TARG)) {
154 for (i=0; i < maxarg; i++) {
155 SV **svp = av_fetch((AV*)TARG, i, FALSE);
156 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
160 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
165 SV* sv = sv_newmortal();
166 I32 maxarg = AvFILL((AV*)TARG) + 1;
167 sv_setiv(sv, maxarg);
179 if (PL_op->op_private & OPpLVAL_INTRO)
180 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
181 if (PL_op->op_flags & OPf_REF)
184 if (gimme == G_ARRAY) {
185 RETURNOP(do_kv(ARGS));
187 else if (gimme == G_SCALAR) {
188 SV* sv = sv_newmortal();
189 if (HvFILL((HV*)TARG))
190 sv_setpvf(sv, "%ld/%ld",
191 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
201 DIE("NOT IMPL LINE %d",__LINE__);
212 tryAMAGICunDEREF(to_gv);
215 if (SvTYPE(sv) == SVt_PVIO) {
216 GV *gv = (GV*) sv_newmortal();
217 gv_init(gv, 0, "", 0, 0);
218 GvIOp(gv) = (IO *)sv;
219 (void)SvREFCNT_inc(sv);
221 } else if (SvTYPE(sv) != SVt_PVGV)
222 DIE("Not a GLOB reference");
225 if (SvTYPE(sv) != SVt_PVGV) {
229 if (SvGMAGICAL(sv)) {
235 if (PL_op->op_flags & OPf_REF ||
236 PL_op->op_private & HINT_STRICT_REFS)
237 DIE(PL_no_usym, "a symbol");
238 if (ckWARN(WARN_UNINITIALIZED))
239 warner(WARN_UNINITIALIZED, PL_warn_uninit);
243 if (PL_op->op_private & HINT_STRICT_REFS)
244 DIE(PL_no_symref, sym, "a symbol");
245 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
248 if (PL_op->op_private & OPpLVAL_INTRO)
249 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
260 tryAMAGICunDEREF(to_sv);
263 switch (SvTYPE(sv)) {
267 DIE("Not a SCALAR reference");
275 if (SvTYPE(gv) != SVt_PVGV) {
276 if (SvGMAGICAL(sv)) {
282 if (PL_op->op_flags & OPf_REF ||
283 PL_op->op_private & HINT_STRICT_REFS)
284 DIE(PL_no_usym, "a SCALAR");
285 if (ckWARN(WARN_UNINITIALIZED))
286 warner(WARN_UNINITIALIZED, PL_warn_uninit);
290 if (PL_op->op_private & HINT_STRICT_REFS)
291 DIE(PL_no_symref, sym, "a SCALAR");
292 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
296 if (PL_op->op_flags & OPf_MOD) {
297 if (PL_op->op_private & OPpLVAL_INTRO)
298 sv = save_scalar((GV*)TOPs);
299 else if (PL_op->op_private & OPpDEREF)
300 vivify_ref(sv, PL_op->op_private & OPpDEREF);
310 SV *sv = AvARYLEN(av);
312 AvARYLEN(av) = sv = NEWSV(0,0);
313 sv_upgrade(sv, SVt_IV);
314 sv_magic(sv, (SV*)av, '#', Nullch, 0);
322 djSP; dTARGET; dPOPss;
324 if (PL_op->op_flags & OPf_MOD) {
325 if (SvTYPE(TARG) < SVt_PVLV) {
326 sv_upgrade(TARG, SVt_PVLV);
327 sv_magic(TARG, Nullsv, '.', Nullch, 0);
331 if (LvTARG(TARG) != sv) {
333 SvREFCNT_dec(LvTARG(TARG));
334 LvTARG(TARG) = SvREFCNT_inc(sv);
336 PUSHs(TARG); /* no SvSETMAGIC */
342 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
343 mg = mg_find(sv, 'g');
344 if (mg && mg->mg_len >= 0) {
348 PUSHi(i + PL_curcop->cop_arybase);
362 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
363 /* (But not in defined().) */
364 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
367 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
370 cv = (CV*)&PL_sv_undef;
384 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
385 char *s = SvPVX(TOPs);
386 if (strnEQ(s, "CORE::", 6)) {
389 code = keyword(s + 6, SvCUR(TOPs) - 6);
390 if (code < 0) { /* Overridable. */
391 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
392 int i = 0, n = 0, seen_question = 0;
394 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
396 while (i < MAXO) { /* The slow way. */
397 if (strEQ(s + 6, PL_op_name[i])
398 || strEQ(s + 6, PL_op_desc[i]))
404 goto nonesuch; /* Should not happen... */
406 oa = PL_opargs[i] >> OASHIFT;
408 if (oa & OA_OPTIONAL) {
411 } else if (seen_question)
412 goto set; /* XXXX system, exec */
413 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
414 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
417 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
418 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
422 ret = sv_2mortal(newSVpv(str, n - 1));
423 } else if (code) /* Non-Overridable */
425 else { /* None such */
427 croak("Cannot find an opnumber for \"%s\"", s+6);
431 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
433 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
442 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
444 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
460 if (GIMME != G_ARRAY) {
464 *MARK = &PL_sv_undef;
465 *MARK = refto(*MARK);
469 EXTEND_MORTAL(SP - MARK);
471 *MARK = refto(*MARK);
480 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
483 if (!(sv = LvTARG(sv)))
486 else if (SvPADTMP(sv))
490 (void)SvREFCNT_inc(sv);
493 sv_upgrade(rv, SVt_RV);
507 if (sv && SvGMAGICAL(sv))
510 if (!sv || !SvROK(sv))
514 pv = sv_reftype(sv,TRUE);
515 PUSHp(pv, strlen(pv));
525 stash = PL_curcop->cop_stash;
529 char *ptr = SvPV(ssv,len);
530 if (ckWARN(WARN_UNSAFE) && len == 0)
532 "Explicit blessing to '' (assuming package main)");
533 stash = gv_stashpvn(ptr, len, TRUE);
536 (void)sv_bless(TOPs, stash);
550 elem = SvPV(sv, n_a);
554 switch (elem ? *elem : '\0')
557 if (strEQ(elem, "ARRAY"))
558 tmpRef = (SV*)GvAV(gv);
561 if (strEQ(elem, "CODE"))
562 tmpRef = (SV*)GvCVu(gv);
565 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
566 tmpRef = (SV*)GvIOp(gv);
569 if (strEQ(elem, "GLOB"))
573 if (strEQ(elem, "HASH"))
574 tmpRef = (SV*)GvHV(gv);
577 if (strEQ(elem, "IO"))
578 tmpRef = (SV*)GvIOp(gv);
581 if (strEQ(elem, "NAME"))
582 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
585 if (strEQ(elem, "PACKAGE"))
586 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
589 if (strEQ(elem, "SCALAR"))
603 /* Pattern matching */
608 register UNOP *unop = cUNOP;
609 register unsigned char *s;
612 register I32 *sfirst;
616 if (sv == PL_lastscream) {
622 SvSCREAM_off(PL_lastscream);
623 SvREFCNT_dec(PL_lastscream);
625 PL_lastscream = SvREFCNT_inc(sv);
628 s = (unsigned char*)(SvPV(sv, len));
632 if (pos > PL_maxscream) {
633 if (PL_maxscream < 0) {
634 PL_maxscream = pos + 80;
635 New(301, PL_screamfirst, 256, I32);
636 New(302, PL_screamnext, PL_maxscream, I32);
639 PL_maxscream = pos + pos / 4;
640 Renew(PL_screamnext, PL_maxscream, I32);
644 sfirst = PL_screamfirst;
645 snext = PL_screamnext;
647 if (!sfirst || !snext)
648 DIE("do_study: out of memory");
650 for (ch = 256; ch; --ch)
657 snext[pos] = sfirst[ch] - pos;
664 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
673 if (PL_op->op_flags & OPf_STACKED)
679 TARG = sv_newmortal();
684 /* Lvalue operators. */
696 djSP; dMARK; dTARGET;
706 SETi(do_chomp(TOPs));
712 djSP; dMARK; dTARGET;
713 register I32 count = 0;
716 count += do_chomp(POPs);
727 if (!sv || !SvANY(sv))
729 switch (SvTYPE(sv)) {
731 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
735 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
739 if (CvROOT(sv) || CvXSUB(sv))
756 if (!PL_op->op_private) {
765 if (SvTHINKFIRST(sv)) {
766 if (SvREADONLY(sv)) {
768 if (PL_curcop != &PL_compiling)
775 switch (SvTYPE(sv)) {
785 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
786 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
787 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
790 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
792 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
796 SvSetMagicSV(sv, &PL_sv_undef);
800 Newz(602, gp, 1, GP);
801 GvGP(sv) = gp_ref(gp);
802 GvSV(sv) = NEWSV(72,0);
803 GvLINE(sv) = PL_curcop->cop_line;
809 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
812 SvPV_set(sv, Nullch);
825 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
827 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
828 SvIVX(TOPs) != IV_MIN)
831 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
842 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
844 sv_setsv(TARG, TOPs);
845 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
846 SvIVX(TOPs) != IV_MAX)
849 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
863 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
865 sv_setsv(TARG, TOPs);
866 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
867 SvIVX(TOPs) != IV_MIN)
870 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
879 /* Ordinary operators. */
883 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
886 SETn( pow( left, right) );
893 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
896 SETn( left * right );
903 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
908 DIE("Illegal division by zero");
910 /* insure that 20./5. == 4. */
913 if ((double)I_V(left) == left &&
914 (double)I_V(right) == right &&
915 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
918 value = left / right;
922 value = left / right;
931 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
939 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
941 right = (right_neg = (i < 0)) ? -i : i;
945 right = U_V((right_neg = (n < 0)) ? -n : n);
948 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
950 left = (left_neg = (i < 0)) ? -i : i;
954 left = U_V((left_neg = (n < 0)) ? -n : n);
958 DIE("Illegal modulus zero");
961 if ((left_neg != right_neg) && ans)
964 /* XXX may warn: unary minus operator applied to unsigned type */
965 /* could change -foo to be (~foo)+1 instead */
966 if (ans <= ~((UV)IV_MAX)+1)
967 sv_setiv(TARG, ~ans+1);
969 sv_setnv(TARG, -(double)ans);
980 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
982 register I32 count = POPi;
983 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
985 I32 items = SP - MARK;
997 repeatcpy((char*)(MARK + items), (char*)MARK,
998 items * sizeof(SV*), count - 1);
1001 else if (count <= 0)
1004 else { /* Note: mark already snarfed by pp_list */
1009 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1010 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1011 DIE("Can't x= to readonly value");
1015 SvSetSV(TARG, tmpstr);
1016 SvPV_force(TARG, len);
1021 SvGROW(TARG, (count * len) + 1);
1022 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1023 SvCUR(TARG) *= count;
1025 *SvEND(TARG) = '\0';
1027 (void)SvPOK_only(TARG);
1036 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1039 SETn( left - right );
1046 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1049 if (PL_op->op_private & HINT_INTEGER) {
1051 i = BWi(i) << shift;
1065 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1068 if (PL_op->op_private & HINT_INTEGER) {
1070 i = BWi(i) >> shift;
1084 djSP; tryAMAGICbinSET(lt,0);
1087 SETs(boolSV(TOPn < value));
1094 djSP; tryAMAGICbinSET(gt,0);
1097 SETs(boolSV(TOPn > value));
1104 djSP; tryAMAGICbinSET(le,0);
1107 SETs(boolSV(TOPn <= value));
1114 djSP; tryAMAGICbinSET(ge,0);
1117 SETs(boolSV(TOPn >= value));
1124 djSP; tryAMAGICbinSET(ne,0);
1127 SETs(boolSV(TOPn != value));
1134 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1141 else if (left < right)
1143 else if (left > right)
1156 djSP; tryAMAGICbinSET(slt,0);
1159 int cmp = ((PL_op->op_private & OPpLOCALE)
1160 ? sv_cmp_locale(left, right)
1161 : sv_cmp(left, right));
1162 SETs(boolSV(cmp < 0));
1169 djSP; tryAMAGICbinSET(sgt,0);
1172 int cmp = ((PL_op->op_private & OPpLOCALE)
1173 ? sv_cmp_locale(left, right)
1174 : sv_cmp(left, right));
1175 SETs(boolSV(cmp > 0));
1182 djSP; tryAMAGICbinSET(sle,0);
1185 int cmp = ((PL_op->op_private & OPpLOCALE)
1186 ? sv_cmp_locale(left, right)
1187 : sv_cmp(left, right));
1188 SETs(boolSV(cmp <= 0));
1195 djSP; tryAMAGICbinSET(sge,0);
1198 int cmp = ((PL_op->op_private & OPpLOCALE)
1199 ? sv_cmp_locale(left, right)
1200 : sv_cmp(left, right));
1201 SETs(boolSV(cmp >= 0));
1208 djSP; tryAMAGICbinSET(seq,0);
1211 SETs(boolSV(sv_eq(left, right)));
1218 djSP; tryAMAGICbinSET(sne,0);
1221 SETs(boolSV(!sv_eq(left, right)));
1228 djSP; dTARGET; tryAMAGICbin(scmp,0);
1231 int cmp = ((PL_op->op_private & OPpLOCALE)
1232 ? sv_cmp_locale(left, right)
1233 : sv_cmp(left, right));
1241 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1244 if (SvNIOKp(left) || SvNIOKp(right)) {
1245 if (PL_op->op_private & HINT_INTEGER) {
1246 IBW value = SvIV(left) & SvIV(right);
1250 UBW value = SvUV(left) & SvUV(right);
1255 do_vop(PL_op->op_type, TARG, left, right);
1264 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1267 if (SvNIOKp(left) || SvNIOKp(right)) {
1268 if (PL_op->op_private & HINT_INTEGER) {
1269 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1273 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1278 do_vop(PL_op->op_type, TARG, left, right);
1287 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1290 if (SvNIOKp(left) || SvNIOKp(right)) {
1291 if (PL_op->op_private & HINT_INTEGER) {
1292 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1296 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1301 do_vop(PL_op->op_type, TARG, left, right);
1310 djSP; dTARGET; tryAMAGICun(neg);
1315 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1317 else if (SvNIOKp(sv))
1319 else if (SvPOKp(sv)) {
1321 char *s = SvPV(sv, len);
1322 if (isIDFIRST(*s)) {
1323 sv_setpvn(TARG, "-", 1);
1326 else if (*s == '+' || *s == '-') {
1328 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1330 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1331 sv_setpvn(TARG, "-", 1);
1335 sv_setnv(TARG, -SvNV(sv));
1347 djSP; tryAMAGICunSET(not);
1348 #endif /* OVERLOAD */
1349 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1355 djSP; dTARGET; tryAMAGICun(compl);
1359 if (PL_op->op_private & HINT_INTEGER) {
1360 IBW value = ~SvIV(sv);
1364 UBW value = ~SvUV(sv);
1369 register char *tmps;
1370 register long *tmpl;
1375 tmps = SvPV_force(TARG, len);
1378 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1381 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1385 for ( ; anum > 0; anum--, tmps++)
1394 /* integer versions of some of the above */
1398 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1401 SETi( left * right );
1408 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1412 DIE("Illegal division by zero");
1413 value = POPi / value;
1421 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1425 DIE("Illegal modulus zero");
1426 SETi( left % right );
1433 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1436 SETi( left + right );
1443 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1446 SETi( left - right );
1453 djSP; tryAMAGICbinSET(lt,0);
1456 SETs(boolSV(left < right));
1463 djSP; tryAMAGICbinSET(gt,0);
1466 SETs(boolSV(left > right));
1473 djSP; tryAMAGICbinSET(le,0);
1476 SETs(boolSV(left <= right));
1483 djSP; tryAMAGICbinSET(ge,0);
1486 SETs(boolSV(left >= right));
1493 djSP; tryAMAGICbinSET(eq,0);
1496 SETs(boolSV(left == right));
1503 djSP; tryAMAGICbinSET(ne,0);
1506 SETs(boolSV(left != right));
1513 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1520 else if (left < right)
1531 djSP; dTARGET; tryAMAGICun(neg);
1536 /* High falutin' math. */
1540 djSP; dTARGET; tryAMAGICbin(atan2,0);
1543 SETn(atan2(left, right));
1550 djSP; dTARGET; tryAMAGICun(sin);
1562 djSP; dTARGET; tryAMAGICun(cos);
1572 /* Support Configure command-line overrides for rand() functions.
1573 After 5.005, perhaps we should replace this by Configure support
1574 for drand48(), random(), or rand(). For 5.005, though, maintain
1575 compatibility by calling rand() but allow the user to override it.
1576 See INSTALL for details. --Andy Dougherty 15 July 1998
1578 /* Now it's after 5.005, and Configure supports drand48() and random(),
1579 in addition to rand(). So the overrides should not be needed any more.
1580 --Jarkko Hietaniemi 27 September 1998
1583 #ifndef HAS_DRAND48_PROTO
1584 extern double drand48 _((void));
1597 if (!PL_srand_called) {
1598 (void)seedDrand01((Rand_seed_t)seed());
1599 PL_srand_called = TRUE;
1614 (void)seedDrand01((Rand_seed_t)anum);
1615 PL_srand_called = TRUE;
1624 * This is really just a quick hack which grabs various garbage
1625 * values. It really should be a real hash algorithm which
1626 * spreads the effect of every input bit onto every output bit,
1627 * if someone who knows about such things would bother to write it.
1628 * Might be a good idea to add that function to CORE as well.
1629 * No numbers below come from careful analysis or anything here,
1630 * except they are primes and SEED_C1 > 1E6 to get a full-width
1631 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1632 * probably be bigger too.
1635 # define SEED_C1 1000003
1636 #define SEED_C4 73819
1638 # define SEED_C1 25747
1639 #define SEED_C4 20639
1643 #define SEED_C5 26107
1646 #ifndef PERL_NO_DEV_RANDOM
1651 # include <starlet.h>
1652 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1653 * in 100-ns units, typically incremented ever 10 ms. */
1654 unsigned int when[2];
1656 # ifdef HAS_GETTIMEOFDAY
1657 struct timeval when;
1663 /* This test is an escape hatch, this symbol isn't set by Configure. */
1664 #ifndef PERL_NO_DEV_RANDOM
1665 #ifndef PERL_RANDOM_DEVICE
1666 /* /dev/random isn't used by default because reads from it will block
1667 * if there isn't enough entropy available. You can compile with
1668 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1669 * is enough real entropy to fill the seed. */
1670 # define PERL_RANDOM_DEVICE "/dev/urandom"
1672 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1674 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1683 _ckvmssts(sys$gettim(when));
1684 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1686 # ifdef HAS_GETTIMEOFDAY
1687 gettimeofday(&when,(struct timezone *) 0);
1688 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1691 u = (U32)SEED_C1 * when;
1694 u += SEED_C3 * (U32)getpid();
1695 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1696 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1697 u += SEED_C5 * (U32)(UV)&when;
1704 djSP; dTARGET; tryAMAGICun(exp);
1716 djSP; dTARGET; tryAMAGICun(log);
1721 SET_NUMERIC_STANDARD();
1722 DIE("Can't take log of %g", value);
1732 djSP; dTARGET; tryAMAGICun(sqrt);
1737 SET_NUMERIC_STANDARD();
1738 DIE("Can't take sqrt of %g", value);
1740 value = sqrt(value);
1750 double value = TOPn;
1753 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1759 (void)modf(value, &value);
1761 (void)modf(-value, &value);
1776 djSP; dTARGET; tryAMAGICun(abs);
1778 double value = TOPn;
1781 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1782 (iv = SvIVX(TOPs)) != IV_MIN) {
1804 XPUSHu(scan_hex(tmps, 99, &argtype));
1817 while (*tmps && isSPACE(*tmps))
1822 value = scan_hex(++tmps, 99, &argtype);
1823 else if (*tmps == 'b')
1824 value = scan_bin(++tmps, 99, &argtype);
1826 value = scan_oct(tmps, 99, &argtype);
1838 SETi( sv_len_utf8(TOPs) );
1842 SETi( sv_len(TOPs) );
1856 I32 lvalue = PL_op->op_flags & OPf_MOD;
1858 I32 arybase = PL_curcop->cop_arybase;
1862 SvTAINTED_off(TARG); /* decontaminate */
1866 repl = SvPV(sv, repl_len);
1873 tmps = SvPV(sv, curlen);
1875 utfcurlen = sv_len_utf8(sv);
1876 if (utfcurlen == curlen)
1884 if (pos >= arybase) {
1902 else if (len >= 0) {
1904 if (rem > (I32)curlen)
1918 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1919 warner(WARN_SUBSTR, "substr outside of string");
1924 sv_pos_u2b(sv, &pos, &rem);
1926 sv_setpvn(TARG, tmps, rem);
1927 if (lvalue) { /* it's an lvalue! */
1928 if (!SvGMAGICAL(sv)) {
1932 if (ckWARN(WARN_SUBSTR))
1934 "Attempt to use reference as lvalue in substr");
1936 if (SvOK(sv)) /* is it defined ? */
1937 (void)SvPOK_only(sv);
1939 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1942 if (SvTYPE(TARG) < SVt_PVLV) {
1943 sv_upgrade(TARG, SVt_PVLV);
1944 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1948 if (LvTARG(TARG) != sv) {
1950 SvREFCNT_dec(LvTARG(TARG));
1951 LvTARG(TARG) = SvREFCNT_inc(sv);
1953 LvTARGOFF(TARG) = pos;
1954 LvTARGLEN(TARG) = rem;
1957 sv_insert(sv, pos, rem, repl, repl_len);
1960 PUSHs(TARG); /* avoid SvSETMAGIC here */
1967 register I32 size = POPi;
1968 register I32 offset = POPi;
1969 register SV *src = POPs;
1970 I32 lvalue = PL_op->op_flags & OPf_MOD;
1972 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1973 unsigned long retnum;
1976 SvTAINTED_off(TARG); /* decontaminate */
1977 offset *= size; /* turn into bit offset */
1978 len = (offset + size + 7) / 8;
1979 if (offset < 0 || size < 1)
1982 if (lvalue) { /* it's an lvalue! */
1983 if (SvTYPE(TARG) < SVt_PVLV) {
1984 sv_upgrade(TARG, SVt_PVLV);
1985 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1989 if (LvTARG(TARG) != src) {
1991 SvREFCNT_dec(LvTARG(TARG));
1992 LvTARG(TARG) = SvREFCNT_inc(src);
1994 LvTARGOFF(TARG) = offset;
1995 LvTARGLEN(TARG) = size;
2003 if (offset >= srclen)
2006 retnum = (unsigned long) s[offset] << 8;
2008 else if (size == 32) {
2009 if (offset >= srclen)
2011 else if (offset + 1 >= srclen)
2012 retnum = (unsigned long) s[offset] << 24;
2013 else if (offset + 2 >= srclen)
2014 retnum = ((unsigned long) s[offset] << 24) +
2015 ((unsigned long) s[offset + 1] << 16);
2017 retnum = ((unsigned long) s[offset] << 24) +
2018 ((unsigned long) s[offset + 1] << 16) +
2019 (s[offset + 2] << 8);
2024 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2029 else if (size == 16)
2030 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2031 else if (size == 32)
2032 retnum = ((unsigned long) s[offset] << 24) +
2033 ((unsigned long) s[offset + 1] << 16) +
2034 (s[offset + 2] << 8) + s[offset+3];
2038 sv_setuv(TARG, (UV)retnum);
2053 I32 arybase = PL_curcop->cop_arybase;
2058 offset = POPi - arybase;
2061 tmps = SvPV(big, biglen);
2062 if (IN_UTF8 && offset > 0)
2063 sv_pos_u2b(big, &offset, 0);
2066 else if (offset > biglen)
2068 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2069 (unsigned char*)tmps + biglen, little, 0)))
2072 retval = tmps2 - tmps;
2073 if (IN_UTF8 && retval > 0)
2074 sv_pos_b2u(big, &retval);
2075 PUSHi(retval + arybase);
2090 I32 arybase = PL_curcop->cop_arybase;
2096 tmps2 = SvPV(little, llen);
2097 tmps = SvPV(big, blen);
2101 if (IN_UTF8 && offset > 0)
2102 sv_pos_u2b(big, &offset, 0);
2103 offset = offset - arybase + llen;
2107 else if (offset > blen)
2109 if (!(tmps2 = rninstr(tmps, tmps + offset,
2110 tmps2, tmps2 + llen)))
2113 retval = tmps2 - tmps;
2114 if (IN_UTF8 && retval > 0)
2115 sv_pos_b2u(big, &retval);
2116 PUSHi(retval + arybase);
2122 djSP; dMARK; dORIGMARK; dTARGET;
2123 #ifdef USE_LOCALE_NUMERIC
2124 if (PL_op->op_private & OPpLOCALE)
2125 SET_NUMERIC_LOCAL();
2127 SET_NUMERIC_STANDARD();
2129 do_sprintf(TARG, SP-MARK, MARK+1);
2130 TAINT_IF(SvTAINTED(TARG));
2141 U8 *tmps = (U8*)POPpx;
2144 if (IN_UTF8 && (*tmps & 0x80))
2145 value = utf8_to_uv(tmps, &retlen);
2147 value = (UV)(*tmps & 255);
2158 (void)SvUPGRADE(TARG,SVt_PV);
2160 if (IN_UTF8 && value >= 128) {
2163 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2164 SvCUR_set(TARG, tmps - SvPVX(TARG));
2166 (void)SvPOK_only(TARG);
2176 (void)SvPOK_only(TARG);
2183 djSP; dTARGET; dPOPTOPssrl;
2186 char *tmps = SvPV(left, n_a);
2188 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2190 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2194 "The crypt() function is unimplemented due to excessive paranoia.");
2207 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2211 UV uv = utf8_to_uv(s, &ulen);
2213 if (PL_op->op_private & OPpLOCALE) {
2216 uv = toTITLE_LC_uni(uv);
2219 uv = toTITLE_utf8(s);
2221 tend = uv_to_utf8(tmpbuf, uv);
2223 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2225 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2226 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2230 s = (U8*)SvPV_force(sv, slen);
2231 Copy(tmpbuf, s, ulen, U8);
2236 if (!SvPADTMP(sv)) {
2242 s = (U8*)SvPV_force(sv, slen);
2244 if (PL_op->op_private & OPpLOCALE) {
2247 *s = toUPPER_LC(*s);
2263 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2267 UV uv = utf8_to_uv(s, &ulen);
2269 if (PL_op->op_private & OPpLOCALE) {
2272 uv = toLOWER_LC_uni(uv);
2275 uv = toLOWER_utf8(s);
2277 tend = uv_to_utf8(tmpbuf, uv);
2279 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2281 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2282 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2286 s = (U8*)SvPV_force(sv, slen);
2287 Copy(tmpbuf, s, ulen, U8);
2292 if (!SvPADTMP(sv)) {
2298 s = (U8*)SvPV_force(sv, slen);
2300 if (PL_op->op_private & OPpLOCALE) {
2303 *s = toLOWER_LC(*s);
2326 s = (U8*)SvPV(sv,len);
2328 sv_setpvn(TARG, "", 0);
2333 (void)SvUPGRADE(TARG, SVt_PV);
2334 SvGROW(TARG, (len * 2) + 1);
2335 (void)SvPOK_only(TARG);
2336 d = (U8*)SvPVX(TARG);
2338 if (PL_op->op_private & OPpLOCALE) {
2342 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2348 d = uv_to_utf8(d, toUPPER_utf8( s ));
2353 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2358 if (!SvPADTMP(sv)) {
2365 s = (U8*)SvPV_force(sv, len);
2367 register U8 *send = s + len;
2369 if (PL_op->op_private & OPpLOCALE) {
2372 for (; s < send; s++)
2373 *s = toUPPER_LC(*s);
2376 for (; s < send; s++)
2396 s = (U8*)SvPV(sv,len);
2398 sv_setpvn(TARG, "", 0);
2403 (void)SvUPGRADE(TARG, SVt_PV);
2404 SvGROW(TARG, (len * 2) + 1);
2405 (void)SvPOK_only(TARG);
2406 d = (U8*)SvPVX(TARG);
2408 if (PL_op->op_private & OPpLOCALE) {
2412 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2418 d = uv_to_utf8(d, toLOWER_utf8(s));
2423 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2428 if (!SvPADTMP(sv)) {
2435 s = (U8*)SvPV_force(sv, len);
2437 register U8 *send = s + len;
2439 if (PL_op->op_private & OPpLOCALE) {
2442 for (; s < send; s++)
2443 *s = toLOWER_LC(*s);
2446 for (; s < send; s++)
2458 register char *s = SvPV(sv,len);
2462 (void)SvUPGRADE(TARG, SVt_PV);
2463 SvGROW(TARG, (len * 2) + 1);
2468 STRLEN ulen = UTF8SKIP(s);
2491 SvCUR_set(TARG, d - SvPVX(TARG));
2492 (void)SvPOK_only(TARG);
2495 sv_setpvn(TARG, s, len);
2504 djSP; dMARK; dORIGMARK;
2506 register AV* av = (AV*)POPs;
2507 register I32 lval = PL_op->op_flags & OPf_MOD;
2508 I32 arybase = PL_curcop->cop_arybase;
2511 if (SvTYPE(av) == SVt_PVAV) {
2512 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2514 for (svp = MARK + 1; svp <= SP; svp++) {
2519 if (max > AvMAX(av))
2522 while (++MARK <= SP) {
2523 elem = SvIVx(*MARK);
2527 svp = av_fetch(av, elem, lval);
2529 if (!svp || *svp == &PL_sv_undef)
2530 DIE(PL_no_aelem, elem);
2531 if (PL_op->op_private & OPpLVAL_INTRO)
2532 save_aelem(av, elem, svp);
2534 *MARK = svp ? *svp : &PL_sv_undef;
2537 if (GIMME != G_ARRAY) {
2545 /* Associative arrays. */
2550 HV *hash = (HV*)POPs;
2552 I32 gimme = GIMME_V;
2553 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2556 /* might clobber stack_sp */
2557 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2562 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2563 if (gimme == G_ARRAY) {
2565 /* might clobber stack_sp */
2566 sv_setsv(TARG, realhv ?
2567 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2572 else if (gimme == G_SCALAR)
2591 I32 gimme = GIMME_V;
2592 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2596 if (PL_op->op_private & OPpSLICE) {
2600 hvtype = SvTYPE(hv);
2601 while (++MARK <= SP) {
2602 if (hvtype == SVt_PVHV)
2603 sv = hv_delete_ent(hv, *MARK, discard, 0);
2605 DIE("Not a HASH reference");
2606 *MARK = sv ? sv : &PL_sv_undef;
2610 else if (gimme == G_SCALAR) {
2619 if (SvTYPE(hv) == SVt_PVHV)
2620 sv = hv_delete_ent(hv, keysv, discard, 0);
2622 DIE("Not a HASH reference");
2636 if (SvTYPE(hv) == SVt_PVHV) {
2637 if (hv_exists_ent(hv, tmpsv, 0))
2639 } else if (SvTYPE(hv) == SVt_PVAV) {
2640 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2643 DIE("Not a HASH reference");
2650 djSP; dMARK; dORIGMARK;
2651 register HV *hv = (HV*)POPs;
2652 register I32 lval = PL_op->op_flags & OPf_MOD;
2653 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2655 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2656 DIE("Can't localize pseudo-hash element");
2658 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2659 while (++MARK <= SP) {
2663 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2664 svp = he ? &HeVAL(he) : 0;
2666 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2669 if (!svp || *svp == &PL_sv_undef) {
2671 DIE(PL_no_helem, SvPV(keysv, n_a));
2673 if (PL_op->op_private & OPpLVAL_INTRO)
2674 save_helem(hv, keysv, svp);
2676 *MARK = svp ? *svp : &PL_sv_undef;
2679 if (GIMME != G_ARRAY) {
2687 /* List operators. */
2692 if (GIMME != G_ARRAY) {
2694 *MARK = *SP; /* unwanted list, return last item */
2696 *MARK = &PL_sv_undef;
2705 SV **lastrelem = PL_stack_sp;
2706 SV **lastlelem = PL_stack_base + POPMARK;
2707 SV **firstlelem = PL_stack_base + POPMARK + 1;
2708 register SV **firstrelem = lastlelem + 1;
2709 I32 arybase = PL_curcop->cop_arybase;
2710 I32 lval = PL_op->op_flags & OPf_MOD;
2711 I32 is_something_there = lval;
2713 register I32 max = lastrelem - lastlelem;
2714 register SV **lelem;
2717 if (GIMME != G_ARRAY) {
2718 ix = SvIVx(*lastlelem);
2723 if (ix < 0 || ix >= max)
2724 *firstlelem = &PL_sv_undef;
2726 *firstlelem = firstrelem[ix];
2732 SP = firstlelem - 1;
2736 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2741 *lelem = &PL_sv_undef;
2742 else if (!(*lelem = firstrelem[ix]))
2743 *lelem = &PL_sv_undef;
2747 if (ix >= max || !(*lelem = firstrelem[ix]))
2748 *lelem = &PL_sv_undef;
2750 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2751 is_something_there = TRUE;
2753 if (is_something_there)
2756 SP = firstlelem - 1;
2762 djSP; dMARK; dORIGMARK;
2763 I32 items = SP - MARK;
2764 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2765 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2772 djSP; dMARK; dORIGMARK;
2773 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2777 SV *val = NEWSV(46, 0);
2779 sv_setsv(val, *++MARK);
2780 else if (ckWARN(WARN_UNSAFE))
2781 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2782 (void)hv_store_ent(hv,key,val,0);
2791 djSP; dMARK; dORIGMARK;
2792 register AV *ary = (AV*)*++MARK;
2796 register I32 offset;
2797 register I32 length;
2804 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2805 *MARK-- = SvTIED_obj((SV*)ary, mg);
2809 perl_call_method("SPLICE",GIMME_V);
2818 offset = i = SvIVx(*MARK);
2820 offset += AvFILLp(ary) + 1;
2822 offset -= PL_curcop->cop_arybase;
2824 DIE(PL_no_aelem, i);
2826 length = SvIVx(*MARK++);
2828 length += AvFILLp(ary) - offset + 1;
2834 length = AvMAX(ary) + 1; /* close enough to infinity */
2838 length = AvMAX(ary) + 1;
2840 if (offset > AvFILLp(ary) + 1)
2841 offset = AvFILLp(ary) + 1;
2842 after = AvFILLp(ary) + 1 - (offset + length);
2843 if (after < 0) { /* not that much array */
2844 length += after; /* offset+length now in array */
2850 /* At this point, MARK .. SP-1 is our new LIST */
2853 diff = newlen - length;
2854 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2857 if (diff < 0) { /* shrinking the area */
2859 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2860 Copy(MARK, tmparyval, newlen, SV*);
2863 MARK = ORIGMARK + 1;
2864 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2865 MEXTEND(MARK, length);
2866 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2868 EXTEND_MORTAL(length);
2869 for (i = length, dst = MARK; i; i--) {
2870 sv_2mortal(*dst); /* free them eventualy */
2877 *MARK = AvARRAY(ary)[offset+length-1];
2880 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2881 SvREFCNT_dec(*dst++); /* free them now */
2884 AvFILLp(ary) += diff;
2886 /* pull up or down? */
2888 if (offset < after) { /* easier to pull up */
2889 if (offset) { /* esp. if nothing to pull */
2890 src = &AvARRAY(ary)[offset-1];
2891 dst = src - diff; /* diff is negative */
2892 for (i = offset; i > 0; i--) /* can't trust Copy */
2896 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2900 if (after) { /* anything to pull down? */
2901 src = AvARRAY(ary) + offset + length;
2902 dst = src + diff; /* diff is negative */
2903 Move(src, dst, after, SV*);
2905 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2906 /* avoid later double free */
2910 dst[--i] = &PL_sv_undef;
2913 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2915 *dst = NEWSV(46, 0);
2916 sv_setsv(*dst++, *src++);
2918 Safefree(tmparyval);
2921 else { /* no, expanding (or same) */
2923 New(452, tmparyval, length, SV*); /* so remember deletion */
2924 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2927 if (diff > 0) { /* expanding */
2929 /* push up or down? */
2931 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2935 Move(src, dst, offset, SV*);
2937 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2939 AvFILLp(ary) += diff;
2942 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2943 av_extend(ary, AvFILLp(ary) + diff);
2944 AvFILLp(ary) += diff;
2947 dst = AvARRAY(ary) + AvFILLp(ary);
2949 for (i = after; i; i--) {
2956 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2957 *dst = NEWSV(46, 0);
2958 sv_setsv(*dst++, *src++);
2960 MARK = ORIGMARK + 1;
2961 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2963 Copy(tmparyval, MARK, length, SV*);
2965 EXTEND_MORTAL(length);
2966 for (i = length, dst = MARK; i; i--) {
2967 sv_2mortal(*dst); /* free them eventualy */
2971 Safefree(tmparyval);
2975 else if (length--) {
2976 *MARK = tmparyval[length];
2979 while (length-- > 0)
2980 SvREFCNT_dec(tmparyval[length]);
2982 Safefree(tmparyval);
2985 *MARK = &PL_sv_undef;
2993 djSP; dMARK; dORIGMARK; dTARGET;
2994 register AV *ary = (AV*)*++MARK;
2995 register SV *sv = &PL_sv_undef;
2998 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2999 *MARK-- = SvTIED_obj((SV*)ary, mg);
3003 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3008 /* Why no pre-extend of ary here ? */
3009 for (++MARK; MARK <= SP; MARK++) {
3012 sv_setsv(sv, *MARK);
3017 PUSHi( AvFILL(ary) + 1 );
3025 SV *sv = av_pop(av);
3027 (void)sv_2mortal(sv);
3036 SV *sv = av_shift(av);
3041 (void)sv_2mortal(sv);
3048 djSP; dMARK; dORIGMARK; dTARGET;
3049 register AV *ary = (AV*)*++MARK;
3054 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3055 *MARK-- = SvTIED_obj((SV*)ary, mg);
3059 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3064 av_unshift(ary, SP - MARK);
3067 sv_setsv(sv, *++MARK);
3068 (void)av_store(ary, i++, sv);
3072 PUSHi( AvFILL(ary) + 1 );
3082 if (GIMME == G_ARRAY) {
3093 register char *down;
3099 do_join(TARG, &PL_sv_no, MARK, SP);
3101 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3102 up = SvPV_force(TARG, len);
3104 if (IN_UTF8) { /* first reverse each character */
3105 U8* s = (U8*)SvPVX(TARG);
3106 U8* send = (U8*)(s + len);
3115 down = (char*)(s - 1);
3116 if (s > send || !((*down & 0xc0) == 0x80)) {
3117 warn("Malformed UTF-8 character");
3129 down = SvPVX(TARG) + len - 1;
3135 (void)SvPOK_only(TARG);
3144 mul128(SV *sv, U8 m)
3147 char *s = SvPV(sv, len);
3151 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3152 SV *tmpNew = newSVpv("0000000000", 10);
3154 sv_catsv(tmpNew, sv);
3155 SvREFCNT_dec(sv); /* free old sv */
3160 while (!*t) /* trailing '\0'? */
3163 i = ((*t - '0') << 7) + m;
3164 *(t--) = '0' + (i % 10);
3170 /* Explosives and implosives. */
3172 #if 'I' == 73 && 'J' == 74
3173 /* On an ASCII/ISO kind of system */
3174 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3177 Some other sort of character set - use memchr() so we don't match
3180 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3188 I32 gimme = GIMME_V;
3192 register char *pat = SvPV(left, llen);
3193 register char *s = SvPV(right, rlen);
3194 char *strend = s + rlen;
3196 register char *patend = pat + llen;
3201 /* These must not be in registers: */
3218 register U32 culong;
3222 if (gimme != G_ARRAY) { /* arrange to do first one only */
3224 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3225 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3227 while (isDIGIT(*patend) || *patend == '*')
3233 while (pat < patend) {
3235 datumtype = *pat++ & 0xFF;
3236 if (isSPACE(datumtype))
3240 else if (*pat == '*') {
3241 len = strend - strbeg; /* long enough */
3244 else if (isDIGIT(*pat)) {
3246 while (isDIGIT(*pat))
3247 len = (len * 10) + (*pat++ - '0');
3250 len = (datumtype != '@');
3253 croak("Invalid type in unpack: '%c'", (int)datumtype);
3254 case ',': /* grandfather in commas but with a warning */
3255 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3256 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3259 if (len == 1 && pat[-1] != '1')
3268 if (len > strend - strbeg)
3269 DIE("@ outside of string");
3273 if (len > s - strbeg)
3274 DIE("X outside of string");
3278 if (len > strend - s)
3279 DIE("x outside of string");
3284 if (len > strend - s)
3287 goto uchar_checksum;
3288 sv = NEWSV(35, len);
3289 sv_setpvn(sv, s, len);
3291 if (datumtype == 'A') {
3292 aptr = s; /* borrow register */
3293 s = SvPVX(sv) + len - 1;
3294 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3297 SvCUR_set(sv, s - SvPVX(sv));
3298 s = aptr; /* unborrow register */
3300 XPUSHs(sv_2mortal(sv));
3304 if (pat[-1] == '*' || len > (strend - s) * 8)
3305 len = (strend - s) * 8;
3308 Newz(601, PL_bitcount, 256, char);
3309 for (bits = 1; bits < 256; bits++) {
3310 if (bits & 1) PL_bitcount[bits]++;
3311 if (bits & 2) PL_bitcount[bits]++;
3312 if (bits & 4) PL_bitcount[bits]++;
3313 if (bits & 8) PL_bitcount[bits]++;
3314 if (bits & 16) PL_bitcount[bits]++;
3315 if (bits & 32) PL_bitcount[bits]++;
3316 if (bits & 64) PL_bitcount[bits]++;
3317 if (bits & 128) PL_bitcount[bits]++;
3321 culong += PL_bitcount[*(unsigned char*)s++];
3326 if (datumtype == 'b') {
3328 if (bits & 1) culong++;
3334 if (bits & 128) culong++;
3341 sv = NEWSV(35, len + 1);
3344 aptr = pat; /* borrow register */
3346 if (datumtype == 'b') {
3348 for (len = 0; len < aint; len++) {
3349 if (len & 7) /*SUPPRESS 595*/
3353 *pat++ = '0' + (bits & 1);
3358 for (len = 0; len < aint; len++) {
3363 *pat++ = '0' + ((bits & 128) != 0);
3367 pat = aptr; /* unborrow register */
3368 XPUSHs(sv_2mortal(sv));
3372 if (pat[-1] == '*' || len > (strend - s) * 2)
3373 len = (strend - s) * 2;
3374 sv = NEWSV(35, len + 1);
3377 aptr = pat; /* borrow register */
3379 if (datumtype == 'h') {
3381 for (len = 0; len < aint; len++) {
3386 *pat++ = PL_hexdigit[bits & 15];
3391 for (len = 0; len < aint; len++) {
3396 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3400 pat = aptr; /* unborrow register */
3401 XPUSHs(sv_2mortal(sv));
3404 if (len > strend - s)
3409 if (aint >= 128) /* fake up signed chars */
3419 if (aint >= 128) /* fake up signed chars */
3422 sv_setiv(sv, (IV)aint);
3423 PUSHs(sv_2mortal(sv));
3428 if (len > strend - s)
3443 sv_setiv(sv, (IV)auint);
3444 PUSHs(sv_2mortal(sv));
3449 if (len > strend - s)
3452 while (len-- > 0 && s < strend) {
3453 auint = utf8_to_uv((U8*)s, &along);
3456 cdouble += (double)auint;
3464 while (len-- > 0 && s < strend) {
3465 auint = utf8_to_uv((U8*)s, &along);
3468 sv_setuv(sv, (UV)auint);
3469 PUSHs(sv_2mortal(sv));
3474 along = (strend - s) / SIZE16;
3491 sv_setiv(sv, (IV)ashort);
3492 PUSHs(sv_2mortal(sv));
3499 along = (strend - s) / SIZE16;
3504 COPY16(s, &aushort);
3507 if (datumtype == 'n')
3508 aushort = PerlSock_ntohs(aushort);
3511 if (datumtype == 'v')
3512 aushort = vtohs(aushort);
3521 COPY16(s, &aushort);
3525 if (datumtype == 'n')
3526 aushort = PerlSock_ntohs(aushort);
3529 if (datumtype == 'v')
3530 aushort = vtohs(aushort);
3532 sv_setiv(sv, (IV)aushort);
3533 PUSHs(sv_2mortal(sv));
3538 along = (strend - s) / sizeof(int);
3543 Copy(s, &aint, 1, int);
3546 cdouble += (double)aint;
3555 Copy(s, &aint, 1, int);
3559 /* Without the dummy below unpack("i", pack("i",-1))
3560 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3561 * cc with optimization turned on */
3563 sv_setiv(sv, (IV)aint) :
3565 sv_setiv(sv, (IV)aint);
3566 PUSHs(sv_2mortal(sv));
3571 along = (strend - s) / sizeof(unsigned int);
3576 Copy(s, &auint, 1, unsigned int);
3577 s += sizeof(unsigned int);
3579 cdouble += (double)auint;
3588 Copy(s, &auint, 1, unsigned int);
3589 s += sizeof(unsigned int);
3592 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3593 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3594 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3595 * with optimization turned on.
3596 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3597 * does not have this problem even with -O4)
3600 sv_setuv(sv, (UV)auint) :
3602 sv_setuv(sv, (UV)auint);
3603 PUSHs(sv_2mortal(sv));
3608 along = (strend - s) / SIZE32;
3616 cdouble += (double)along;
3628 sv_setiv(sv, (IV)along);
3629 PUSHs(sv_2mortal(sv));
3636 along = (strend - s) / SIZE32;
3644 if (datumtype == 'N')
3645 aulong = PerlSock_ntohl(aulong);
3648 if (datumtype == 'V')
3649 aulong = vtohl(aulong);
3652 cdouble += (double)aulong;
3664 if (datumtype == 'N')
3665 aulong = PerlSock_ntohl(aulong);
3668 if (datumtype == 'V')
3669 aulong = vtohl(aulong);
3672 sv_setuv(sv, (UV)aulong);
3673 PUSHs(sv_2mortal(sv));
3678 along = (strend - s) / sizeof(char*);
3684 if (sizeof(char*) > strend - s)
3687 Copy(s, &aptr, 1, char*);
3693 PUSHs(sv_2mortal(sv));
3703 while ((len > 0) && (s < strend)) {
3704 auv = (auv << 7) | (*s & 0x7f);
3705 if (!(*s++ & 0x80)) {
3709 PUSHs(sv_2mortal(sv));
3713 else if (++bytes >= sizeof(UV)) { /* promote to string */
3717 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3718 while (s < strend) {
3719 sv = mul128(sv, *s & 0x7f);
3720 if (!(*s++ & 0x80)) {
3729 PUSHs(sv_2mortal(sv));
3734 if ((s >= strend) && bytes)
3735 croak("Unterminated compressed integer");
3740 if (sizeof(char*) > strend - s)
3743 Copy(s, &aptr, 1, char*);
3748 sv_setpvn(sv, aptr, len);
3749 PUSHs(sv_2mortal(sv));
3753 along = (strend - s) / sizeof(Quad_t);
3759 if (s + sizeof(Quad_t) > strend)
3762 Copy(s, &aquad, 1, Quad_t);
3763 s += sizeof(Quad_t);
3766 if (aquad >= IV_MIN && aquad <= IV_MAX)
3767 sv_setiv(sv, (IV)aquad);
3769 sv_setnv(sv, (double)aquad);
3770 PUSHs(sv_2mortal(sv));
3774 along = (strend - s) / sizeof(Quad_t);
3780 if (s + sizeof(Uquad_t) > strend)
3783 Copy(s, &auquad, 1, Uquad_t);
3784 s += sizeof(Uquad_t);
3787 if (auquad <= UV_MAX)
3788 sv_setuv(sv, (UV)auquad);
3790 sv_setnv(sv, (double)auquad);
3791 PUSHs(sv_2mortal(sv));
3795 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3798 along = (strend - s) / sizeof(float);
3803 Copy(s, &afloat, 1, float);
3812 Copy(s, &afloat, 1, float);
3815 sv_setnv(sv, (double)afloat);
3816 PUSHs(sv_2mortal(sv));
3822 along = (strend - s) / sizeof(double);
3827 Copy(s, &adouble, 1, double);
3828 s += sizeof(double);
3836 Copy(s, &adouble, 1, double);
3837 s += sizeof(double);
3839 sv_setnv(sv, (double)adouble);
3840 PUSHs(sv_2mortal(sv));
3846 * Initialise the decode mapping. By using a table driven
3847 * algorithm, the code will be character-set independent
3848 * (and just as fast as doing character arithmetic)
3850 if (PL_uudmap['M'] == 0) {
3853 for (i = 0; i < sizeof(PL_uuemap); i += 1)
3854 PL_uudmap[PL_uuemap[i]] = i;
3856 * Because ' ' and '`' map to the same value,
3857 * we need to decode them both the same.
3862 along = (strend - s) * 3 / 4;
3863 sv = NEWSV(42, along);
3866 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3871 len = PL_uudmap[*s++] & 077;
3873 if (s < strend && ISUUCHAR(*s))
3874 a = PL_uudmap[*s++] & 077;
3877 if (s < strend && ISUUCHAR(*s))
3878 b = PL_uudmap[*s++] & 077;
3881 if (s < strend && ISUUCHAR(*s))
3882 c = PL_uudmap[*s++] & 077;
3885 if (s < strend && ISUUCHAR(*s))
3886 d = PL_uudmap[*s++] & 077;
3889 hunk[0] = (a << 2) | (b >> 4);
3890 hunk[1] = (b << 4) | (c >> 2);
3891 hunk[2] = (c << 6) | d;
3892 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3897 else if (s[1] == '\n') /* possible checksum byte */
3900 XPUSHs(sv_2mortal(sv));
3905 if (strchr("fFdD", datumtype) ||
3906 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3910 while (checksum >= 16) {
3914 while (checksum >= 4) {
3920 along = (1 << checksum) - 1;
3921 while (cdouble < 0.0)
3923 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3924 sv_setnv(sv, cdouble);
3927 if (checksum < 32) {
3928 aulong = (1 << checksum) - 1;
3931 sv_setuv(sv, (UV)culong);
3933 XPUSHs(sv_2mortal(sv));
3937 if (SP == oldsp && gimme == G_SCALAR)
3938 PUSHs(&PL_sv_undef);
3943 doencodes(register SV *sv, register char *s, register I32 len)
3947 *hunk = PL_uuemap[len];
3948 sv_catpvn(sv, hunk, 1);
3951 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
3952 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3953 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3954 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
3955 sv_catpvn(sv, hunk, 4);
3960 char r = (len > 1 ? s[1] : '\0');
3961 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
3962 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3963 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
3964 hunk[3] = PL_uuemap[0];
3965 sv_catpvn(sv, hunk, 4);
3967 sv_catpvn(sv, "\n", 1);
3971 is_an_int(char *s, STRLEN l)
3974 SV *result = newSVpv("", l);
3975 char *result_c = SvPV(result, n_a); /* convenience */
3976 char *out = result_c;
3986 SvREFCNT_dec(result);
4009 SvREFCNT_dec(result);
4015 SvCUR_set(result, out - result_c);
4020 div128(SV *pnum, bool *done)
4021 /* must be '\0' terminated */
4025 char *s = SvPV(pnum, len);
4034 i = m * 10 + (*t - '0');
4036 r = (i >> 7); /* r < 10 */
4043 SvCUR_set(pnum, (STRLEN) (t - s));
4050 djSP; dMARK; dORIGMARK; dTARGET;
4051 register SV *cat = TARG;
4054 register char *pat = SvPVx(*++MARK, fromlen);
4055 register char *patend = pat + fromlen;
4060 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4061 static char *space10 = " ";
4063 /* These must not be in registers: */
4081 sv_setpvn(cat, "", 0);
4082 while (pat < patend) {
4083 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4084 datumtype = *pat++ & 0xFF;
4085 if (isSPACE(datumtype))
4088 len = strchr("@Xxu", datumtype) ? 0 : items;
4091 else if (isDIGIT(*pat)) {
4093 while (isDIGIT(*pat))
4094 len = (len * 10) + (*pat++ - '0');
4100 croak("Invalid type in pack: '%c'", (int)datumtype);
4101 case ',': /* grandfather in commas but with a warning */
4102 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4103 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4106 DIE("%% may only be used in unpack");
4117 if (SvCUR(cat) < len)
4118 DIE("X outside of string");
4125 sv_catpvn(cat, null10, 10);
4128 sv_catpvn(cat, null10, len);
4133 aptr = SvPV(fromstr, fromlen);
4137 sv_catpvn(cat, aptr, len);
4139 sv_catpvn(cat, aptr, fromlen);
4141 if (datumtype == 'A') {
4143 sv_catpvn(cat, space10, 10);
4146 sv_catpvn(cat, space10, len);
4150 sv_catpvn(cat, null10, 10);
4153 sv_catpvn(cat, null10, len);
4160 char *savepat = pat;
4165 aptr = SvPV(fromstr, fromlen);
4170 SvCUR(cat) += (len+7)/8;
4171 SvGROW(cat, SvCUR(cat) + 1);
4172 aptr = SvPVX(cat) + aint;
4177 if (datumtype == 'B') {
4178 for (len = 0; len++ < aint;) {
4179 items |= *pat++ & 1;
4183 *aptr++ = items & 0xff;
4189 for (len = 0; len++ < aint;) {
4195 *aptr++ = items & 0xff;
4201 if (datumtype == 'B')
4202 items <<= 7 - (aint & 7);
4204 items >>= 7 - (aint & 7);
4205 *aptr++ = items & 0xff;
4207 pat = SvPVX(cat) + SvCUR(cat);
4218 char *savepat = pat;
4223 aptr = SvPV(fromstr, fromlen);
4228 SvCUR(cat) += (len+1)/2;
4229 SvGROW(cat, SvCUR(cat) + 1);
4230 aptr = SvPVX(cat) + aint;
4235 if (datumtype == 'H') {
4236 for (len = 0; len++ < aint;) {
4238 items |= ((*pat++ & 15) + 9) & 15;
4240 items |= *pat++ & 15;
4244 *aptr++ = items & 0xff;
4250 for (len = 0; len++ < aint;) {
4252 items |= (((*pat++ & 15) + 9) & 15) << 4;
4254 items |= (*pat++ & 15) << 4;
4258 *aptr++ = items & 0xff;
4264 *aptr++ = items & 0xff;
4265 pat = SvPVX(cat) + SvCUR(cat);
4277 aint = SvIV(fromstr);
4279 sv_catpvn(cat, &achar, sizeof(char));
4285 auint = SvUV(fromstr);
4286 SvGROW(cat, SvCUR(cat) + 10);
4287 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4292 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4297 afloat = (float)SvNV(fromstr);
4298 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4305 adouble = (double)SvNV(fromstr);
4306 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4312 ashort = (I16)SvIV(fromstr);
4314 ashort = PerlSock_htons(ashort);
4316 CAT16(cat, &ashort);
4322 ashort = (I16)SvIV(fromstr);
4324 ashort = htovs(ashort);
4326 CAT16(cat, &ashort);
4333 ashort = (I16)SvIV(fromstr);
4334 CAT16(cat, &ashort);
4340 auint = SvUV(fromstr);
4341 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4347 adouble = floor(SvNV(fromstr));
4350 croak("Cannot compress negative numbers");
4356 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4357 adouble <= UV_MAX_cxux
4364 char buf[1 + sizeof(UV)];
4365 char *in = buf + sizeof(buf);
4366 UV auv = U_V(adouble);;
4369 *--in = (auv & 0x7f) | 0x80;
4372 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4373 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4375 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4376 char *from, *result, *in;
4381 /* Copy string and check for compliance */
4382 from = SvPV(fromstr, len);
4383 if ((norm = is_an_int(from, len)) == NULL)
4384 croak("can compress only unsigned integer");
4386 New('w', result, len, char);
4390 *--in = div128(norm, &done) | 0x80;
4391 result[len - 1] &= 0x7F; /* clear continue bit */
4392 sv_catpvn(cat, in, (result + len) - in);
4394 SvREFCNT_dec(norm); /* free norm */
4396 else if (SvNOKp(fromstr)) {
4397 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4398 char *in = buf + sizeof(buf);
4401 double next = floor(adouble / 128);
4402 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4403 if (--in < buf) /* this cannot happen ;-) */
4404 croak ("Cannot compress integer");
4406 } while (adouble > 0);
4407 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4408 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4411 croak("Cannot compress non integer");
4417 aint = SvIV(fromstr);
4418 sv_catpvn(cat, (char*)&aint, sizeof(int));
4424 aulong = SvUV(fromstr);
4426 aulong = PerlSock_htonl(aulong);
4428 CAT32(cat, &aulong);
4434 aulong = SvUV(fromstr);
4436 aulong = htovl(aulong);
4438 CAT32(cat, &aulong);
4444 aulong = SvUV(fromstr);
4445 CAT32(cat, &aulong);
4451 along = SvIV(fromstr);
4459 auquad = (Uquad_t)SvIV(fromstr);
4460 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4466 aquad = (Quad_t)SvIV(fromstr);
4467 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4470 #endif /* HAS_QUAD */
4472 len = 1; /* assume SV is correct length */
4477 if (fromstr == &PL_sv_undef)
4481 /* XXX better yet, could spirit away the string to
4482 * a safe spot and hang on to it until the result
4483 * of pack() (and all copies of the result) are
4486 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4488 "Attempt to pack pointer to temporary value");
4489 if (SvPOK(fromstr) || SvNIOK(fromstr))
4490 aptr = SvPV(fromstr,n_a);
4492 aptr = SvPV_force(fromstr,n_a);
4494 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4499 aptr = SvPV(fromstr, fromlen);
4500 SvGROW(cat, fromlen * 4 / 3);
4505 while (fromlen > 0) {
4512 doencodes(cat, aptr, todo);
4531 register I32 limit = POPi; /* note, negative is forever */
4534 register char *s = SvPV(sv, len);
4535 char *strend = s + len;
4537 register REGEXP *rx;
4541 I32 maxiters = (strend - s) + 10;
4544 I32 origlimit = limit;
4547 AV *oldstack = PL_curstack;
4548 I32 gimme = GIMME_V;
4549 I32 oldsave = PL_savestack_ix;
4550 I32 make_mortal = 1;
4551 MAGIC *mg = (MAGIC *) NULL;
4554 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4559 DIE("panic: do_split");
4560 rx = pm->op_pmregexp;
4562 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4563 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4565 if (pm->op_pmreplroot)
4566 ary = GvAVn((GV*)pm->op_pmreplroot);
4567 else if (gimme != G_ARRAY)
4569 ary = (AV*)PL_curpad[0];
4571 ary = GvAVn(PL_defgv);
4572 #endif /* USE_THREADS */
4575 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4581 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4583 XPUSHs(SvTIED_obj((SV*)ary, mg));
4588 for (i = AvFILLp(ary); i >= 0; i--)
4589 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4591 /* temporarily switch stacks */
4592 SWITCHSTACK(PL_curstack, ary);
4596 base = SP - PL_stack_base;
4598 if (pm->op_pmflags & PMf_SKIPWHITE) {
4599 if (pm->op_pmflags & PMf_LOCALE) {
4600 while (isSPACE_LC(*s))
4608 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4609 SAVEINT(PL_multiline);
4610 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4614 limit = maxiters + 2;
4615 if (pm->op_pmflags & PMf_WHITE) {
4618 while (m < strend &&
4619 !((pm->op_pmflags & PMf_LOCALE)
4620 ? isSPACE_LC(*m) : isSPACE(*m)))
4625 dstr = NEWSV(30, m-s);
4626 sv_setpvn(dstr, s, m-s);
4632 while (s < strend &&
4633 ((pm->op_pmflags & PMf_LOCALE)
4634 ? isSPACE_LC(*s) : isSPACE(*s)))
4638 else if (strEQ("^", rx->precomp)) {
4641 for (m = s; m < strend && *m != '\n'; m++) ;
4645 dstr = NEWSV(30, m-s);
4646 sv_setpvn(dstr, s, m-s);
4653 else if (rx->check_substr && !rx->nparens
4654 && (rx->reganch & ROPT_CHECK_ALL)
4655 && !(rx->reganch & ROPT_ANCH)) {
4656 i = SvCUR(rx->check_substr);
4657 if (i == 1 && !SvTAIL(rx->check_substr)) {
4658 i = *SvPVX(rx->check_substr);
4661 for (m = s; m < strend && *m != i; m++) ;
4664 dstr = NEWSV(30, m-s);
4665 sv_setpvn(dstr, s, m-s);
4674 while (s < strend && --limit &&
4675 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4676 rx->check_substr, 0)) )
4679 dstr = NEWSV(31, m-s);
4680 sv_setpvn(dstr, s, m-s);
4689 maxiters += (strend - s) * rx->nparens;
4690 while (s < strend && --limit &&
4691 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4693 TAINT_IF(RX_MATCH_TAINTED(rx));
4695 && rx->subbase != orig) {
4700 strend = s + (strend - m);
4703 dstr = NEWSV(32, m-s);
4704 sv_setpvn(dstr, s, m-s);
4709 for (i = 1; i <= rx->nparens; i++) {
4713 dstr = NEWSV(33, m-s);
4714 sv_setpvn(dstr, s, m-s);
4717 dstr = NEWSV(33, 0);
4727 LEAVE_SCOPE(oldsave);
4728 iters = (SP - PL_stack_base) - base;
4729 if (iters > maxiters)
4732 /* keep field after final delim? */
4733 if (s < strend || (iters && origlimit)) {
4734 dstr = NEWSV(34, strend-s);
4735 sv_setpvn(dstr, s, strend-s);
4741 else if (!origlimit) {
4742 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4748 SWITCHSTACK(ary, oldstack);
4749 if (SvSMAGICAL(ary)) {
4754 if (gimme == G_ARRAY) {
4756 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4764 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4767 if (gimme == G_ARRAY) {
4768 /* EXTEND should not be needed - we just popped them */
4770 for (i=0; i < iters; i++) {
4771 SV **svp = av_fetch(ary, i, FALSE);
4772 PUSHs((svp) ? *svp : &PL_sv_undef);
4779 if (gimme == G_ARRAY)
4782 if (iters || !pm->op_pmreplroot) {
4792 unlock_condpair(void *svv)
4795 MAGIC *mg = mg_find((SV*)svv, 'm');
4798 croak("panic: unlock_condpair unlocking non-mutex");
4799 MUTEX_LOCK(MgMUTEXP(mg));
4800 if (MgOWNER(mg) != thr)
4801 croak("panic: unlock_condpair unlocking mutex that we don't own");
4803 COND_SIGNAL(MgOWNERCONDP(mg));
4804 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4805 (unsigned long)thr, (unsigned long)svv);)
4806 MUTEX_UNLOCK(MgMUTEXP(mg));
4808 #endif /* USE_THREADS */
4821 mg = condpair_magic(sv);
4822 MUTEX_LOCK(MgMUTEXP(mg));
4823 if (MgOWNER(mg) == thr)
4824 MUTEX_UNLOCK(MgMUTEXP(mg));
4827 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4829 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4830 (unsigned long)thr, (unsigned long)sv);)
4831 MUTEX_UNLOCK(MgMUTEXP(mg));
4832 save_destructor(unlock_condpair, sv);
4834 #endif /* USE_THREADS */
4835 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4836 || SvTYPE(retsv) == SVt_PVCV) {
4837 retsv = refto(retsv);
4848 if (PL_op->op_private & OPpLVAL_INTRO)
4849 PUSHs(*save_threadsv(PL_op->op_targ));
4851 PUSHs(THREADSV(PL_op->op_targ));
4854 DIE("tried to access per-thread data in non-threaded perl");
4855 #endif /* USE_THREADS */