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("aAZbBhHP", *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");
3285 if (len > strend - s)
3288 goto uchar_checksum;
3289 sv = NEWSV(35, len);
3290 sv_setpvn(sv, s, len);
3292 if (datumtype == 'A' || datumtype == 'Z') {
3293 aptr = s; /* borrow register */
3294 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3299 else { /* 'A' strips both nulls and spaces */
3300 s = SvPVX(sv) + len - 1;
3301 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3305 SvCUR_set(sv, s - SvPVX(sv));
3306 s = aptr; /* unborrow register */
3308 XPUSHs(sv_2mortal(sv));
3312 if (pat[-1] == '*' || len > (strend - s) * 8)
3313 len = (strend - s) * 8;
3316 Newz(601, PL_bitcount, 256, char);
3317 for (bits = 1; bits < 256; bits++) {
3318 if (bits & 1) PL_bitcount[bits]++;
3319 if (bits & 2) PL_bitcount[bits]++;
3320 if (bits & 4) PL_bitcount[bits]++;
3321 if (bits & 8) PL_bitcount[bits]++;
3322 if (bits & 16) PL_bitcount[bits]++;
3323 if (bits & 32) PL_bitcount[bits]++;
3324 if (bits & 64) PL_bitcount[bits]++;
3325 if (bits & 128) PL_bitcount[bits]++;
3329 culong += PL_bitcount[*(unsigned char*)s++];
3334 if (datumtype == 'b') {
3336 if (bits & 1) culong++;
3342 if (bits & 128) culong++;
3349 sv = NEWSV(35, len + 1);
3352 aptr = pat; /* borrow register */
3354 if (datumtype == 'b') {
3356 for (len = 0; len < aint; len++) {
3357 if (len & 7) /*SUPPRESS 595*/
3361 *pat++ = '0' + (bits & 1);
3366 for (len = 0; len < aint; len++) {
3371 *pat++ = '0' + ((bits & 128) != 0);
3375 pat = aptr; /* unborrow register */
3376 XPUSHs(sv_2mortal(sv));
3380 if (pat[-1] == '*' || len > (strend - s) * 2)
3381 len = (strend - s) * 2;
3382 sv = NEWSV(35, len + 1);
3385 aptr = pat; /* borrow register */
3387 if (datumtype == 'h') {
3389 for (len = 0; len < aint; len++) {
3394 *pat++ = PL_hexdigit[bits & 15];
3399 for (len = 0; len < aint; len++) {
3404 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3408 pat = aptr; /* unborrow register */
3409 XPUSHs(sv_2mortal(sv));
3412 if (len > strend - s)
3417 if (aint >= 128) /* fake up signed chars */
3427 if (aint >= 128) /* fake up signed chars */
3430 sv_setiv(sv, (IV)aint);
3431 PUSHs(sv_2mortal(sv));
3436 if (len > strend - s)
3451 sv_setiv(sv, (IV)auint);
3452 PUSHs(sv_2mortal(sv));
3457 if (len > strend - s)
3460 while (len-- > 0 && s < strend) {
3461 auint = utf8_to_uv((U8*)s, &along);
3464 cdouble += (double)auint;
3472 while (len-- > 0 && s < strend) {
3473 auint = utf8_to_uv((U8*)s, &along);
3476 sv_setuv(sv, (UV)auint);
3477 PUSHs(sv_2mortal(sv));
3482 along = (strend - s) / SIZE16;
3499 sv_setiv(sv, (IV)ashort);
3500 PUSHs(sv_2mortal(sv));
3507 along = (strend - s) / SIZE16;
3512 COPY16(s, &aushort);
3515 if (datumtype == 'n')
3516 aushort = PerlSock_ntohs(aushort);
3519 if (datumtype == 'v')
3520 aushort = vtohs(aushort);
3529 COPY16(s, &aushort);
3533 if (datumtype == 'n')
3534 aushort = PerlSock_ntohs(aushort);
3537 if (datumtype == 'v')
3538 aushort = vtohs(aushort);
3540 sv_setiv(sv, (IV)aushort);
3541 PUSHs(sv_2mortal(sv));
3546 along = (strend - s) / sizeof(int);
3551 Copy(s, &aint, 1, int);
3554 cdouble += (double)aint;
3563 Copy(s, &aint, 1, int);
3567 /* Without the dummy below unpack("i", pack("i",-1))
3568 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3569 * cc with optimization turned on */
3571 sv_setiv(sv, (IV)aint) :
3573 sv_setiv(sv, (IV)aint);
3574 PUSHs(sv_2mortal(sv));
3579 along = (strend - s) / sizeof(unsigned int);
3584 Copy(s, &auint, 1, unsigned int);
3585 s += sizeof(unsigned int);
3587 cdouble += (double)auint;
3596 Copy(s, &auint, 1, unsigned int);
3597 s += sizeof(unsigned int);
3600 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3601 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3602 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3603 * with optimization turned on.
3604 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3605 * does not have this problem even with -O4)
3608 sv_setuv(sv, (UV)auint) :
3610 sv_setuv(sv, (UV)auint);
3611 PUSHs(sv_2mortal(sv));
3616 along = (strend - s) / SIZE32;
3624 cdouble += (double)along;
3636 sv_setiv(sv, (IV)along);
3637 PUSHs(sv_2mortal(sv));
3644 along = (strend - s) / SIZE32;
3652 if (datumtype == 'N')
3653 aulong = PerlSock_ntohl(aulong);
3656 if (datumtype == 'V')
3657 aulong = vtohl(aulong);
3660 cdouble += (double)aulong;
3672 if (datumtype == 'N')
3673 aulong = PerlSock_ntohl(aulong);
3676 if (datumtype == 'V')
3677 aulong = vtohl(aulong);
3680 sv_setuv(sv, (UV)aulong);
3681 PUSHs(sv_2mortal(sv));
3686 along = (strend - s) / sizeof(char*);
3692 if (sizeof(char*) > strend - s)
3695 Copy(s, &aptr, 1, char*);
3701 PUSHs(sv_2mortal(sv));
3711 while ((len > 0) && (s < strend)) {
3712 auv = (auv << 7) | (*s & 0x7f);
3713 if (!(*s++ & 0x80)) {
3717 PUSHs(sv_2mortal(sv));
3721 else if (++bytes >= sizeof(UV)) { /* promote to string */
3725 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3726 while (s < strend) {
3727 sv = mul128(sv, *s & 0x7f);
3728 if (!(*s++ & 0x80)) {
3737 PUSHs(sv_2mortal(sv));
3742 if ((s >= strend) && bytes)
3743 croak("Unterminated compressed integer");
3748 if (sizeof(char*) > strend - s)
3751 Copy(s, &aptr, 1, char*);
3756 sv_setpvn(sv, aptr, len);
3757 PUSHs(sv_2mortal(sv));
3761 along = (strend - s) / sizeof(Quad_t);
3767 if (s + sizeof(Quad_t) > strend)
3770 Copy(s, &aquad, 1, Quad_t);
3771 s += sizeof(Quad_t);
3774 if (aquad >= IV_MIN && aquad <= IV_MAX)
3775 sv_setiv(sv, (IV)aquad);
3777 sv_setnv(sv, (double)aquad);
3778 PUSHs(sv_2mortal(sv));
3782 along = (strend - s) / sizeof(Quad_t);
3788 if (s + sizeof(Uquad_t) > strend)
3791 Copy(s, &auquad, 1, Uquad_t);
3792 s += sizeof(Uquad_t);
3795 if (auquad <= UV_MAX)
3796 sv_setuv(sv, (UV)auquad);
3798 sv_setnv(sv, (double)auquad);
3799 PUSHs(sv_2mortal(sv));
3803 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3806 along = (strend - s) / sizeof(float);
3811 Copy(s, &afloat, 1, float);
3820 Copy(s, &afloat, 1, float);
3823 sv_setnv(sv, (double)afloat);
3824 PUSHs(sv_2mortal(sv));
3830 along = (strend - s) / sizeof(double);
3835 Copy(s, &adouble, 1, double);
3836 s += sizeof(double);
3844 Copy(s, &adouble, 1, double);
3845 s += sizeof(double);
3847 sv_setnv(sv, (double)adouble);
3848 PUSHs(sv_2mortal(sv));
3854 * Initialise the decode mapping. By using a table driven
3855 * algorithm, the code will be character-set independent
3856 * (and just as fast as doing character arithmetic)
3858 if (PL_uudmap['M'] == 0) {
3861 for (i = 0; i < sizeof(PL_uuemap); i += 1)
3862 PL_uudmap[PL_uuemap[i]] = i;
3864 * Because ' ' and '`' map to the same value,
3865 * we need to decode them both the same.
3870 along = (strend - s) * 3 / 4;
3871 sv = NEWSV(42, along);
3874 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3879 len = PL_uudmap[*s++] & 077;
3881 if (s < strend && ISUUCHAR(*s))
3882 a = PL_uudmap[*s++] & 077;
3885 if (s < strend && ISUUCHAR(*s))
3886 b = PL_uudmap[*s++] & 077;
3889 if (s < strend && ISUUCHAR(*s))
3890 c = PL_uudmap[*s++] & 077;
3893 if (s < strend && ISUUCHAR(*s))
3894 d = PL_uudmap[*s++] & 077;
3897 hunk[0] = (a << 2) | (b >> 4);
3898 hunk[1] = (b << 4) | (c >> 2);
3899 hunk[2] = (c << 6) | d;
3900 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3905 else if (s[1] == '\n') /* possible checksum byte */
3908 XPUSHs(sv_2mortal(sv));
3913 if (strchr("fFdD", datumtype) ||
3914 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3918 while (checksum >= 16) {
3922 while (checksum >= 4) {
3928 along = (1 << checksum) - 1;
3929 while (cdouble < 0.0)
3931 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3932 sv_setnv(sv, cdouble);
3935 if (checksum < 32) {
3936 aulong = (1 << checksum) - 1;
3939 sv_setuv(sv, (UV)culong);
3941 XPUSHs(sv_2mortal(sv));
3945 if (SP == oldsp && gimme == G_SCALAR)
3946 PUSHs(&PL_sv_undef);
3951 doencodes(register SV *sv, register char *s, register I32 len)
3955 *hunk = PL_uuemap[len];
3956 sv_catpvn(sv, hunk, 1);
3959 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
3960 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3961 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3962 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
3963 sv_catpvn(sv, hunk, 4);
3968 char r = (len > 1 ? s[1] : '\0');
3969 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
3970 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3971 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
3972 hunk[3] = PL_uuemap[0];
3973 sv_catpvn(sv, hunk, 4);
3975 sv_catpvn(sv, "\n", 1);
3979 is_an_int(char *s, STRLEN l)
3982 SV *result = newSVpv("", l);
3983 char *result_c = SvPV(result, n_a); /* convenience */
3984 char *out = result_c;
3994 SvREFCNT_dec(result);
4017 SvREFCNT_dec(result);
4023 SvCUR_set(result, out - result_c);
4028 div128(SV *pnum, bool *done)
4029 /* must be '\0' terminated */
4033 char *s = SvPV(pnum, len);
4042 i = m * 10 + (*t - '0');
4044 r = (i >> 7); /* r < 10 */
4051 SvCUR_set(pnum, (STRLEN) (t - s));
4058 djSP; dMARK; dORIGMARK; dTARGET;
4059 register SV *cat = TARG;
4062 register char *pat = SvPVx(*++MARK, fromlen);
4063 register char *patend = pat + fromlen;
4068 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4069 static char *space10 = " ";
4071 /* These must not be in registers: */
4089 sv_setpvn(cat, "", 0);
4090 while (pat < patend) {
4091 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4092 datumtype = *pat++ & 0xFF;
4093 if (isSPACE(datumtype))
4096 len = strchr("@Xxu", datumtype) ? 0 : items;
4099 else if (isDIGIT(*pat)) {
4101 while (isDIGIT(*pat))
4102 len = (len * 10) + (*pat++ - '0');
4108 croak("Invalid type in pack: '%c'", (int)datumtype);
4109 case ',': /* grandfather in commas but with a warning */
4110 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4111 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4114 DIE("%% may only be used in unpack");
4125 if (SvCUR(cat) < len)
4126 DIE("X outside of string");
4133 sv_catpvn(cat, null10, 10);
4136 sv_catpvn(cat, null10, len);
4142 aptr = SvPV(fromstr, fromlen);
4146 sv_catpvn(cat, aptr, len);
4148 sv_catpvn(cat, aptr, fromlen);
4150 if (datumtype == 'A') {
4152 sv_catpvn(cat, space10, 10);
4155 sv_catpvn(cat, space10, len);
4159 sv_catpvn(cat, null10, 10);
4162 sv_catpvn(cat, null10, len);
4169 char *savepat = pat;
4174 aptr = SvPV(fromstr, fromlen);
4179 SvCUR(cat) += (len+7)/8;
4180 SvGROW(cat, SvCUR(cat) + 1);
4181 aptr = SvPVX(cat) + aint;
4186 if (datumtype == 'B') {
4187 for (len = 0; len++ < aint;) {
4188 items |= *pat++ & 1;
4192 *aptr++ = items & 0xff;
4198 for (len = 0; len++ < aint;) {
4204 *aptr++ = items & 0xff;
4210 if (datumtype == 'B')
4211 items <<= 7 - (aint & 7);
4213 items >>= 7 - (aint & 7);
4214 *aptr++ = items & 0xff;
4216 pat = SvPVX(cat) + SvCUR(cat);
4227 char *savepat = pat;
4232 aptr = SvPV(fromstr, fromlen);
4237 SvCUR(cat) += (len+1)/2;
4238 SvGROW(cat, SvCUR(cat) + 1);
4239 aptr = SvPVX(cat) + aint;
4244 if (datumtype == 'H') {
4245 for (len = 0; len++ < aint;) {
4247 items |= ((*pat++ & 15) + 9) & 15;
4249 items |= *pat++ & 15;
4253 *aptr++ = items & 0xff;
4259 for (len = 0; len++ < aint;) {
4261 items |= (((*pat++ & 15) + 9) & 15) << 4;
4263 items |= (*pat++ & 15) << 4;
4267 *aptr++ = items & 0xff;
4273 *aptr++ = items & 0xff;
4274 pat = SvPVX(cat) + SvCUR(cat);
4286 aint = SvIV(fromstr);
4288 sv_catpvn(cat, &achar, sizeof(char));
4294 auint = SvUV(fromstr);
4295 SvGROW(cat, SvCUR(cat) + 10);
4296 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4301 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4306 afloat = (float)SvNV(fromstr);
4307 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4314 adouble = (double)SvNV(fromstr);
4315 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4321 ashort = (I16)SvIV(fromstr);
4323 ashort = PerlSock_htons(ashort);
4325 CAT16(cat, &ashort);
4331 ashort = (I16)SvIV(fromstr);
4333 ashort = htovs(ashort);
4335 CAT16(cat, &ashort);
4342 ashort = (I16)SvIV(fromstr);
4343 CAT16(cat, &ashort);
4349 auint = SvUV(fromstr);
4350 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4356 adouble = floor(SvNV(fromstr));
4359 croak("Cannot compress negative numbers");
4365 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4366 adouble <= UV_MAX_cxux
4373 char buf[1 + sizeof(UV)];
4374 char *in = buf + sizeof(buf);
4375 UV auv = U_V(adouble);;
4378 *--in = (auv & 0x7f) | 0x80;
4381 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4382 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4384 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4385 char *from, *result, *in;
4390 /* Copy string and check for compliance */
4391 from = SvPV(fromstr, len);
4392 if ((norm = is_an_int(from, len)) == NULL)
4393 croak("can compress only unsigned integer");
4395 New('w', result, len, char);
4399 *--in = div128(norm, &done) | 0x80;
4400 result[len - 1] &= 0x7F; /* clear continue bit */
4401 sv_catpvn(cat, in, (result + len) - in);
4403 SvREFCNT_dec(norm); /* free norm */
4405 else if (SvNOKp(fromstr)) {
4406 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4407 char *in = buf + sizeof(buf);
4410 double next = floor(adouble / 128);
4411 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4412 if (--in < buf) /* this cannot happen ;-) */
4413 croak ("Cannot compress integer");
4415 } while (adouble > 0);
4416 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4417 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4420 croak("Cannot compress non integer");
4426 aint = SvIV(fromstr);
4427 sv_catpvn(cat, (char*)&aint, sizeof(int));
4433 aulong = SvUV(fromstr);
4435 aulong = PerlSock_htonl(aulong);
4437 CAT32(cat, &aulong);
4443 aulong = SvUV(fromstr);
4445 aulong = htovl(aulong);
4447 CAT32(cat, &aulong);
4453 aulong = SvUV(fromstr);
4454 CAT32(cat, &aulong);
4460 along = SvIV(fromstr);
4468 auquad = (Uquad_t)SvIV(fromstr);
4469 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4475 aquad = (Quad_t)SvIV(fromstr);
4476 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4479 #endif /* HAS_QUAD */
4481 len = 1; /* assume SV is correct length */
4486 if (fromstr == &PL_sv_undef)
4490 /* XXX better yet, could spirit away the string to
4491 * a safe spot and hang on to it until the result
4492 * of pack() (and all copies of the result) are
4495 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4497 "Attempt to pack pointer to temporary value");
4498 if (SvPOK(fromstr) || SvNIOK(fromstr))
4499 aptr = SvPV(fromstr,n_a);
4501 aptr = SvPV_force(fromstr,n_a);
4503 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4508 aptr = SvPV(fromstr, fromlen);
4509 SvGROW(cat, fromlen * 4 / 3);
4514 while (fromlen > 0) {
4521 doencodes(cat, aptr, todo);
4540 register I32 limit = POPi; /* note, negative is forever */
4543 register char *s = SvPV(sv, len);
4544 char *strend = s + len;
4546 register REGEXP *rx;
4550 I32 maxiters = (strend - s) + 10;
4553 I32 origlimit = limit;
4556 AV *oldstack = PL_curstack;
4557 I32 gimme = GIMME_V;
4558 I32 oldsave = PL_savestack_ix;
4559 I32 make_mortal = 1;
4560 MAGIC *mg = (MAGIC *) NULL;
4563 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4568 DIE("panic: do_split");
4569 rx = pm->op_pmregexp;
4571 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4572 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4574 if (pm->op_pmreplroot)
4575 ary = GvAVn((GV*)pm->op_pmreplroot);
4576 else if (gimme != G_ARRAY)
4578 ary = (AV*)PL_curpad[0];
4580 ary = GvAVn(PL_defgv);
4581 #endif /* USE_THREADS */
4584 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4590 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4592 XPUSHs(SvTIED_obj((SV*)ary, mg));
4597 for (i = AvFILLp(ary); i >= 0; i--)
4598 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4600 /* temporarily switch stacks */
4601 SWITCHSTACK(PL_curstack, ary);
4605 base = SP - PL_stack_base;
4607 if (pm->op_pmflags & PMf_SKIPWHITE) {
4608 if (pm->op_pmflags & PMf_LOCALE) {
4609 while (isSPACE_LC(*s))
4617 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4618 SAVEINT(PL_multiline);
4619 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4623 limit = maxiters + 2;
4624 if (pm->op_pmflags & PMf_WHITE) {
4627 while (m < strend &&
4628 !((pm->op_pmflags & PMf_LOCALE)
4629 ? isSPACE_LC(*m) : isSPACE(*m)))
4634 dstr = NEWSV(30, m-s);
4635 sv_setpvn(dstr, s, m-s);
4641 while (s < strend &&
4642 ((pm->op_pmflags & PMf_LOCALE)
4643 ? isSPACE_LC(*s) : isSPACE(*s)))
4647 else if (strEQ("^", rx->precomp)) {
4650 for (m = s; m < strend && *m != '\n'; m++) ;
4654 dstr = NEWSV(30, m-s);
4655 sv_setpvn(dstr, s, m-s);
4662 else if (rx->check_substr && !rx->nparens
4663 && (rx->reganch & ROPT_CHECK_ALL)
4664 && !(rx->reganch & ROPT_ANCH)) {
4665 i = SvCUR(rx->check_substr);
4666 if (i == 1 && !SvTAIL(rx->check_substr)) {
4667 i = *SvPVX(rx->check_substr);
4670 for (m = s; m < strend && *m != i; m++) ;
4673 dstr = NEWSV(30, m-s);
4674 sv_setpvn(dstr, s, m-s);
4683 while (s < strend && --limit &&
4684 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4685 rx->check_substr, 0)) )
4688 dstr = NEWSV(31, m-s);
4689 sv_setpvn(dstr, s, m-s);
4698 maxiters += (strend - s) * rx->nparens;
4699 while (s < strend && --limit &&
4700 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4702 TAINT_IF(RX_MATCH_TAINTED(rx));
4704 && rx->subbase != orig) {
4709 strend = s + (strend - m);
4712 dstr = NEWSV(32, m-s);
4713 sv_setpvn(dstr, s, m-s);
4718 for (i = 1; i <= rx->nparens; i++) {
4722 dstr = NEWSV(33, m-s);
4723 sv_setpvn(dstr, s, m-s);
4726 dstr = NEWSV(33, 0);
4736 LEAVE_SCOPE(oldsave);
4737 iters = (SP - PL_stack_base) - base;
4738 if (iters > maxiters)
4741 /* keep field after final delim? */
4742 if (s < strend || (iters && origlimit)) {
4743 dstr = NEWSV(34, strend-s);
4744 sv_setpvn(dstr, s, strend-s);
4750 else if (!origlimit) {
4751 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4757 SWITCHSTACK(ary, oldstack);
4758 if (SvSMAGICAL(ary)) {
4763 if (gimme == G_ARRAY) {
4765 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4773 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4776 if (gimme == G_ARRAY) {
4777 /* EXTEND should not be needed - we just popped them */
4779 for (i=0; i < iters; i++) {
4780 SV **svp = av_fetch(ary, i, FALSE);
4781 PUSHs((svp) ? *svp : &PL_sv_undef);
4788 if (gimme == G_ARRAY)
4791 if (iters || !pm->op_pmreplroot) {
4801 unlock_condpair(void *svv)
4804 MAGIC *mg = mg_find((SV*)svv, 'm');
4807 croak("panic: unlock_condpair unlocking non-mutex");
4808 MUTEX_LOCK(MgMUTEXP(mg));
4809 if (MgOWNER(mg) != thr)
4810 croak("panic: unlock_condpair unlocking mutex that we don't own");
4812 COND_SIGNAL(MgOWNERCONDP(mg));
4813 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4814 (unsigned long)thr, (unsigned long)svv);)
4815 MUTEX_UNLOCK(MgMUTEXP(mg));
4817 #endif /* USE_THREADS */
4830 mg = condpair_magic(sv);
4831 MUTEX_LOCK(MgMUTEXP(mg));
4832 if (MgOWNER(mg) == thr)
4833 MUTEX_UNLOCK(MgMUTEXP(mg));
4836 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4838 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4839 (unsigned long)thr, (unsigned long)sv);)
4840 MUTEX_UNLOCK(MgMUTEXP(mg));
4841 save_destructor(unlock_condpair, sv);
4843 #endif /* USE_THREADS */
4844 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4845 || SvTYPE(retsv) == SVt_PVCV) {
4846 retsv = refto(retsv);
4857 if (PL_op->op_private & OPpLVAL_INTRO)
4858 PUSHs(*save_threadsv(PL_op->op_targ));
4860 PUSHs(THREADSV(PL_op->op_targ));
4863 DIE("tried to access per-thread data in non-threaded perl");
4864 #endif /* USE_THREADS */