3 * Copyright (c) 1991-1997, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
19 * The compiler on Concurrent CX/UX systems has a subtle bug which only
20 * seems to show up when compiling pp.c - it generates the wrong double
21 * precision constant value for (double)UV_MAX when used inline in the body
22 * of the code below, so this makes a static variable up front (which the
23 * compiler seems to get correct) and uses it in place of UV_MAX below.
25 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
26 static double UV_MAX_cxux = ((double)UV_MAX);
30 * Types used in bitwise operations.
32 * Normally we'd just use IV and UV. However, some hardware and
33 * software combinations (e.g. Alpha and current OSF/1) don't have a
34 * floating-point type to use for NV that has adequate bits to fully
35 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
37 * It just so happens that "int" is the right size almost everywhere.
43 * Mask used after bitwise operations.
45 * There is at least one realm (Cray word machines) that doesn't
46 * have an integral type (except char) small enough to be represented
47 * in a double without loss; that is, it has no 32-bit type.
49 #if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
51 # define BW_MASK ((1 << BW_BITS) - 1)
52 # define BW_SIGN (1 << (BW_BITS - 1))
53 # define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
54 # define BWu(u) ((u) & BW_MASK)
61 * Offset for integer pack/unpack.
63 * On architectures where I16 and I32 aren't really 16 and 32 bits,
64 * which for now are all Crays, pack and unpack have to play games.
68 * These values are required for portability of pack() output.
69 * If they're not right on your machine, then pack() and unpack()
70 * wouldn't work right anyway; you'll need to apply the Cray hack.
71 * (I'd like to check them with #if, but you can't use sizeof() in
72 * the preprocessor.) --???
75 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
76 defines are now in config.h. --Andy Dougherty April 1998
81 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
82 # if BYTEORDER == 0x12345678
83 # define OFF16(p) (char*)(p)
84 # define OFF32(p) (char*)(p)
86 # if BYTEORDER == 0x87654321
87 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
88 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
90 }}}} bad cray byte order
93 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
94 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
95 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
96 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
98 # define COPY16(s,p) Copy(s, p, SIZE16, char)
99 # define COPY32(s,p) Copy(s, p, SIZE32, char)
100 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
101 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
105 static void doencodes _((SV* sv, char* s, I32 len));
106 static SV* refto _((SV* sv));
107 static U32 seed _((void));
110 static bool srand_called = FALSE;
112 /* variations on pp_null */
118 /* XXX I can't imagine anyone who doesn't have this actually _needs_
119 it, since pid_t is an integral type.
122 #ifdef NEED_GETPID_PROTO
123 extern Pid_t getpid (void);
129 if (GIMME_V == G_SCALAR)
130 XPUSHs(&PL_sv_undef);
144 if (PL_op->op_private & OPpLVAL_INTRO)
145 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
147 if (PL_op->op_flags & OPf_REF) {
151 if (GIMME == G_ARRAY) {
152 I32 maxarg = AvFILL((AV*)TARG) + 1;
154 if (SvMAGICAL(TARG)) {
156 for (i=0; i < maxarg; i++) {
157 SV **svp = av_fetch((AV*)TARG, i, FALSE);
158 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
162 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
167 SV* sv = sv_newmortal();
168 I32 maxarg = AvFILL((AV*)TARG) + 1;
169 sv_setiv(sv, maxarg);
181 if (PL_op->op_private & OPpLVAL_INTRO)
182 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
183 if (PL_op->op_flags & OPf_REF)
186 if (gimme == G_ARRAY) {
187 RETURNOP(do_kv(ARGS));
189 else if (gimme == G_SCALAR) {
190 SV* sv = sv_newmortal();
191 if (HvFILL((HV*)TARG))
192 sv_setpvf(sv, "%ld/%ld",
193 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
203 DIE("NOT IMPL LINE %d",__LINE__);
214 tryAMAGICunDEREF(to_gv);
217 if (SvTYPE(sv) == SVt_PVIO) {
218 GV *gv = (GV*) sv_newmortal();
219 gv_init(gv, 0, "", 0, 0);
220 GvIOp(gv) = (IO *)sv;
221 (void)SvREFCNT_inc(sv);
223 } else if (SvTYPE(sv) != SVt_PVGV)
224 DIE("Not a GLOB reference");
227 if (SvTYPE(sv) != SVt_PVGV) {
230 if (SvGMAGICAL(sv)) {
236 if (PL_op->op_flags & OPf_REF ||
237 PL_op->op_private & HINT_STRICT_REFS)
238 DIE(PL_no_usym, "a symbol");
239 if (ckWARN(WARN_UNINITIALIZED))
240 warner(WARN_UNINITIALIZED, PL_warn_uninit);
243 sym = SvPV(sv, PL_na);
244 if (PL_op->op_private & HINT_STRICT_REFS)
245 DIE(PL_no_symref, sym, "a symbol");
246 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
249 if (PL_op->op_private & OPpLVAL_INTRO)
250 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
261 tryAMAGICunDEREF(to_sv);
264 switch (SvTYPE(sv)) {
268 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);
289 sym = SvPV(sv, PL_na);
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);
549 elem = SvPV(sv, PL_na);
553 switch (elem ? *elem : '\0')
556 if (strEQ(elem, "ARRAY"))
557 tmpRef = (SV*)GvAV(gv);
560 if (strEQ(elem, "CODE"))
561 tmpRef = (SV*)GvCVu(gv);
564 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
565 tmpRef = (SV*)GvIOp(gv);
568 if (strEQ(elem, "GLOB"))
572 if (strEQ(elem, "HASH"))
573 tmpRef = (SV*)GvHV(gv);
576 if (strEQ(elem, "IO"))
577 tmpRef = (SV*)GvIOp(gv);
580 if (strEQ(elem, "NAME"))
581 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
584 if (strEQ(elem, "PACKAGE"))
585 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
588 if (strEQ(elem, "SCALAR"))
602 /* Pattern matching */
607 register UNOP *unop = cUNOP;
608 register unsigned char *s;
611 register I32 *sfirst;
615 if (sv == PL_lastscream) {
621 SvSCREAM_off(PL_lastscream);
622 SvREFCNT_dec(PL_lastscream);
624 PL_lastscream = SvREFCNT_inc(sv);
627 s = (unsigned char*)(SvPV(sv, len));
631 if (pos > PL_maxscream) {
632 if (PL_maxscream < 0) {
633 PL_maxscream = pos + 80;
634 New(301, PL_screamfirst, 256, I32);
635 New(302, PL_screamnext, PL_maxscream, I32);
638 PL_maxscream = pos + pos / 4;
639 Renew(PL_screamnext, PL_maxscream, I32);
643 sfirst = PL_screamfirst;
644 snext = PL_screamnext;
646 if (!sfirst || !snext)
647 DIE("do_study: out of memory");
649 for (ch = 256; ch; --ch)
656 snext[pos] = sfirst[ch] - pos;
663 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
672 if (PL_op->op_flags & OPf_STACKED)
678 TARG = sv_newmortal();
683 /* Lvalue operators. */
695 djSP; dMARK; dTARGET;
705 SETi(do_chomp(TOPs));
711 djSP; dMARK; dTARGET;
712 register I32 count = 0;
715 count += do_chomp(POPs);
726 if (!sv || !SvANY(sv))
728 switch (SvTYPE(sv)) {
730 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
734 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
738 if (CvROOT(sv) || CvXSUB(sv))
755 if (!PL_op->op_private) {
764 if (SvTHINKFIRST(sv)) {
765 if (SvREADONLY(sv)) {
767 if (PL_curcop != &PL_compiling)
774 switch (SvTYPE(sv)) {
784 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
785 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
786 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
789 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
791 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
795 SvSetMagicSV(sv, &PL_sv_undef);
799 Newz(602, gp, 1, GP);
800 GvGP(sv) = gp_ref(gp);
801 GvSV(sv) = NEWSV(72,0);
802 GvLINE(sv) = PL_curcop->cop_line;
808 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
811 SvPV_set(sv, Nullch);
824 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
826 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
827 SvIVX(TOPs) != IV_MIN)
830 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
841 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
843 sv_setsv(TARG, TOPs);
844 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
845 SvIVX(TOPs) != IV_MAX)
848 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
862 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
864 sv_setsv(TARG, TOPs);
865 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
866 SvIVX(TOPs) != IV_MIN)
869 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
878 /* Ordinary operators. */
882 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
885 SETn( pow( left, right) );
892 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
895 SETn( left * right );
902 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
907 DIE("Illegal division by zero");
909 /* insure that 20./5. == 4. */
912 if ((double)I_V(left) == left &&
913 (double)I_V(right) == right &&
914 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
917 value = left / right;
921 value = left / right;
930 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
938 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
940 right = (right_neg = (i < 0)) ? -i : i;
944 right = U_V((right_neg = (n < 0)) ? -n : n);
947 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
949 left = (left_neg = (i < 0)) ? -i : i;
953 left = U_V((left_neg = (n < 0)) ? -n : n);
957 DIE("Illegal modulus zero");
960 if ((left_neg != right_neg) && ans)
963 /* XXX may warn: unary minus operator applied to unsigned type */
964 /* could change -foo to be (~foo)+1 instead */
965 if (ans <= ~((UV)IV_MAX)+1)
966 sv_setiv(TARG, ~ans+1);
968 sv_setnv(TARG, -(double)ans);
979 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
981 register I32 count = POPi;
982 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
984 I32 items = SP - MARK;
996 repeatcpy((char*)(MARK + items), (char*)MARK,
997 items * sizeof(SV*), count - 1);
1000 else if (count <= 0)
1003 else { /* Note: mark already snarfed by pp_list */
1008 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1009 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1010 DIE("Can't x= to readonly value");
1014 SvSetSV(TARG, tmpstr);
1015 SvPV_force(TARG, len);
1020 SvGROW(TARG, (count * len) + 1);
1021 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1022 SvCUR(TARG) *= count;
1024 *SvEND(TARG) = '\0';
1026 (void)SvPOK_only(TARG);
1035 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1038 SETn( left - right );
1045 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1048 if (PL_op->op_private & HINT_INTEGER) {
1050 i = BWi(i) << shift;
1064 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1067 if (PL_op->op_private & HINT_INTEGER) {
1069 i = BWi(i) >> shift;
1083 djSP; tryAMAGICbinSET(lt,0);
1086 SETs(boolSV(TOPn < value));
1093 djSP; tryAMAGICbinSET(gt,0);
1096 SETs(boolSV(TOPn > value));
1103 djSP; tryAMAGICbinSET(le,0);
1106 SETs(boolSV(TOPn <= value));
1113 djSP; tryAMAGICbinSET(ge,0);
1116 SETs(boolSV(TOPn >= value));
1123 djSP; tryAMAGICbinSET(ne,0);
1126 SETs(boolSV(TOPn != value));
1133 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1140 else if (left < right)
1142 else if (left > right)
1155 djSP; tryAMAGICbinSET(slt,0);
1158 int cmp = ((PL_op->op_private & OPpLOCALE)
1159 ? sv_cmp_locale(left, right)
1160 : sv_cmp(left, right));
1161 SETs(boolSV(cmp < 0));
1168 djSP; tryAMAGICbinSET(sgt,0);
1171 int cmp = ((PL_op->op_private & OPpLOCALE)
1172 ? sv_cmp_locale(left, right)
1173 : sv_cmp(left, right));
1174 SETs(boolSV(cmp > 0));
1181 djSP; tryAMAGICbinSET(sle,0);
1184 int cmp = ((PL_op->op_private & OPpLOCALE)
1185 ? sv_cmp_locale(left, right)
1186 : sv_cmp(left, right));
1187 SETs(boolSV(cmp <= 0));
1194 djSP; tryAMAGICbinSET(sge,0);
1197 int cmp = ((PL_op->op_private & OPpLOCALE)
1198 ? sv_cmp_locale(left, right)
1199 : sv_cmp(left, right));
1200 SETs(boolSV(cmp >= 0));
1207 djSP; tryAMAGICbinSET(seq,0);
1210 SETs(boolSV(sv_eq(left, right)));
1217 djSP; tryAMAGICbinSET(sne,0);
1220 SETs(boolSV(!sv_eq(left, right)));
1227 djSP; dTARGET; tryAMAGICbin(scmp,0);
1230 int cmp = ((PL_op->op_private & OPpLOCALE)
1231 ? sv_cmp_locale(left, right)
1232 : sv_cmp(left, right));
1240 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1243 if (SvNIOKp(left) || SvNIOKp(right)) {
1244 if (PL_op->op_private & HINT_INTEGER) {
1245 IBW value = SvIV(left) & SvIV(right);
1249 UBW value = SvUV(left) & SvUV(right);
1254 do_vop(PL_op->op_type, TARG, left, right);
1263 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1266 if (SvNIOKp(left) || SvNIOKp(right)) {
1267 if (PL_op->op_private & HINT_INTEGER) {
1268 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1272 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1277 do_vop(PL_op->op_type, TARG, left, right);
1286 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1289 if (SvNIOKp(left) || SvNIOKp(right)) {
1290 if (PL_op->op_private & HINT_INTEGER) {
1291 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1295 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1300 do_vop(PL_op->op_type, TARG, left, right);
1309 djSP; dTARGET; tryAMAGICun(neg);
1314 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1316 else if (SvNIOKp(sv))
1318 else if (SvPOKp(sv)) {
1320 char *s = SvPV(sv, len);
1321 if (isIDFIRST(*s)) {
1322 sv_setpvn(TARG, "-", 1);
1325 else if (*s == '+' || *s == '-') {
1327 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1329 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1330 sv_setpvn(TARG, "-", 1);
1334 sv_setnv(TARG, -SvNV(sv));
1346 djSP; tryAMAGICunSET(not);
1347 #endif /* OVERLOAD */
1348 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1354 djSP; dTARGET; tryAMAGICun(compl);
1358 if (PL_op->op_private & HINT_INTEGER) {
1359 IBW value = ~SvIV(sv);
1363 UBW value = ~SvUV(sv);
1368 register char *tmps;
1369 register long *tmpl;
1374 tmps = SvPV_force(TARG, len);
1377 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1380 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1384 for ( ; anum > 0; anum--, tmps++)
1393 /* integer versions of some of the above */
1397 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1400 SETi( left * right );
1407 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1411 DIE("Illegal division by zero");
1412 value = POPi / value;
1420 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1424 DIE("Illegal modulus zero");
1425 SETi( left % right );
1432 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1435 SETi( left + right );
1442 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1445 SETi( left - right );
1452 djSP; tryAMAGICbinSET(lt,0);
1455 SETs(boolSV(left < right));
1462 djSP; tryAMAGICbinSET(gt,0);
1465 SETs(boolSV(left > right));
1472 djSP; tryAMAGICbinSET(le,0);
1475 SETs(boolSV(left <= right));
1482 djSP; tryAMAGICbinSET(ge,0);
1485 SETs(boolSV(left >= right));
1492 djSP; tryAMAGICbinSET(eq,0);
1495 SETs(boolSV(left == right));
1502 djSP; tryAMAGICbinSET(ne,0);
1505 SETs(boolSV(left != right));
1512 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1519 else if (left < right)
1530 djSP; dTARGET; tryAMAGICun(neg);
1535 /* High falutin' math. */
1539 djSP; dTARGET; tryAMAGICbin(atan2,0);
1542 SETn(atan2(left, right));
1549 djSP; dTARGET; tryAMAGICun(sin);
1561 djSP; dTARGET; tryAMAGICun(cos);
1571 /* Support Configure command-line overrides for rand() functions.
1572 After 5.005, perhaps we should replace this by Configure support
1573 for drand48(), random(), or rand(). For 5.005, though, maintain
1574 compatibility by calling rand() but allow the user to override it.
1575 See INSTALL for details. --Andy Dougherty 15 July 1998
1577 /* Now it's after 5.005, and Configure supports drand48() and random(),
1578 in addition to rand(). So the overrides should not be needed any more.
1579 --Jarkko Hietaniemi 27 September 1998
1582 #ifndef HAS_DRAND48_PROTO
1583 extern double drand48 _((void));
1596 if (!srand_called) {
1597 (void)seedDrand01((Rand_seed_t)seed());
1598 srand_called = TRUE;
1613 (void)seedDrand01((Rand_seed_t)anum);
1614 srand_called = TRUE;
1623 * This is really just a quick hack which grabs various garbage
1624 * values. It really should be a real hash algorithm which
1625 * spreads the effect of every input bit onto every output bit,
1626 * if someone who knows about such things would bother to write it.
1627 * Might be a good idea to add that function to CORE as well.
1628 * No numbers below come from careful analysis or anything here,
1629 * except they are primes and SEED_C1 > 1E6 to get a full-width
1630 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1631 * probably be bigger too.
1634 # define SEED_C1 1000003
1635 #define SEED_C4 73819
1637 # define SEED_C1 25747
1638 #define SEED_C4 20639
1642 #define SEED_C5 26107
1645 #ifndef PERL_NO_DEV_RANDOM
1650 # include <starlet.h>
1651 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1652 * in 100-ns units, typically incremented ever 10 ms. */
1653 unsigned int when[2];
1655 # ifdef HAS_GETTIMEOFDAY
1656 struct timeval when;
1662 /* This test is an escape hatch, this symbol isn't set by Configure. */
1663 #ifndef PERL_NO_DEV_RANDOM
1664 #ifndef PERL_RANDOM_DEVICE
1665 /* /dev/random isn't used by default because reads from it will block
1666 * if there isn't enough entropy available. You can compile with
1667 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1668 * is enough real entropy to fill the seed. */
1669 # define PERL_RANDOM_DEVICE "/dev/urandom"
1671 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1673 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1682 _ckvmssts(sys$gettim(when));
1683 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1685 # ifdef HAS_GETTIMEOFDAY
1686 gettimeofday(&when,(struct timezone *) 0);
1687 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1690 u = (U32)SEED_C1 * when;
1693 u += SEED_C3 * (U32)getpid();
1694 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1695 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1696 u += SEED_C5 * (U32)(UV)&when;
1703 djSP; dTARGET; tryAMAGICun(exp);
1715 djSP; dTARGET; tryAMAGICun(log);
1720 SET_NUMERIC_STANDARD();
1721 DIE("Can't take log of %g", value);
1731 djSP; dTARGET; tryAMAGICun(sqrt);
1736 SET_NUMERIC_STANDARD();
1737 DIE("Can't take sqrt of %g", value);
1739 value = sqrt(value);
1749 double value = TOPn;
1752 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1758 (void)modf(value, &value);
1760 (void)modf(-value, &value);
1775 djSP; dTARGET; tryAMAGICun(abs);
1777 double value = TOPn;
1780 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1781 (iv = SvIVX(TOPs)) != IV_MIN) {
1802 XPUSHu(scan_hex(tmps, 99, &argtype));
1814 while (*tmps && isSPACE(*tmps))
1819 value = scan_hex(++tmps, 99, &argtype);
1821 value = scan_oct(tmps, 99, &argtype);
1833 SETi( sv_len_utf8(TOPs) );
1837 SETi( sv_len(TOPs) );
1851 I32 lvalue = PL_op->op_flags & OPf_MOD;
1853 I32 arybase = PL_curcop->cop_arybase;
1857 SvTAINTED_off(TARG); /* decontaminate */
1861 repl = SvPV(sv, repl_len);
1868 tmps = SvPV(sv, curlen);
1870 utfcurlen = sv_len_utf8(sv);
1871 if (utfcurlen == curlen)
1879 if (pos >= arybase) {
1897 else if (len >= 0) {
1899 if (rem > (I32)curlen)
1913 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1914 warner(WARN_SUBSTR, "substr outside of string");
1919 sv_pos_u2b(sv, &pos, &rem);
1921 sv_setpvn(TARG, tmps, rem);
1922 if (lvalue) { /* it's an lvalue! */
1923 if (!SvGMAGICAL(sv)) {
1925 SvPV_force(sv,PL_na);
1926 if (ckWARN(WARN_SUBSTR))
1928 "Attempt to use reference as lvalue in substr");
1930 if (SvOK(sv)) /* is it defined ? */
1931 (void)SvPOK_only(sv);
1933 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1936 if (SvTYPE(TARG) < SVt_PVLV) {
1937 sv_upgrade(TARG, SVt_PVLV);
1938 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1942 if (LvTARG(TARG) != sv) {
1944 SvREFCNT_dec(LvTARG(TARG));
1945 LvTARG(TARG) = SvREFCNT_inc(sv);
1947 LvTARGOFF(TARG) = pos;
1948 LvTARGLEN(TARG) = rem;
1951 sv_insert(sv, pos, rem, repl, repl_len);
1954 PUSHs(TARG); /* avoid SvSETMAGIC here */
1961 register I32 size = POPi;
1962 register I32 offset = POPi;
1963 register SV *src = POPs;
1964 I32 lvalue = PL_op->op_flags & OPf_MOD;
1966 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1967 unsigned long retnum;
1970 SvTAINTED_off(TARG); /* decontaminate */
1971 offset *= size; /* turn into bit offset */
1972 len = (offset + size + 7) / 8;
1973 if (offset < 0 || size < 1)
1976 if (lvalue) { /* it's an lvalue! */
1977 if (SvTYPE(TARG) < SVt_PVLV) {
1978 sv_upgrade(TARG, SVt_PVLV);
1979 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1983 if (LvTARG(TARG) != src) {
1985 SvREFCNT_dec(LvTARG(TARG));
1986 LvTARG(TARG) = SvREFCNT_inc(src);
1988 LvTARGOFF(TARG) = offset;
1989 LvTARGLEN(TARG) = size;
1997 if (offset >= srclen)
2000 retnum = (unsigned long) s[offset] << 8;
2002 else if (size == 32) {
2003 if (offset >= srclen)
2005 else if (offset + 1 >= srclen)
2006 retnum = (unsigned long) s[offset] << 24;
2007 else if (offset + 2 >= srclen)
2008 retnum = ((unsigned long) s[offset] << 24) +
2009 ((unsigned long) s[offset + 1] << 16);
2011 retnum = ((unsigned long) s[offset] << 24) +
2012 ((unsigned long) s[offset + 1] << 16) +
2013 (s[offset + 2] << 8);
2018 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2023 else if (size == 16)
2024 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2025 else if (size == 32)
2026 retnum = ((unsigned long) s[offset] << 24) +
2027 ((unsigned long) s[offset + 1] << 16) +
2028 (s[offset + 2] << 8) + s[offset+3];
2032 sv_setuv(TARG, (UV)retnum);
2047 I32 arybase = PL_curcop->cop_arybase;
2052 offset = POPi - arybase;
2055 tmps = SvPV(big, biglen);
2056 if (IN_UTF8 && offset > 0)
2057 sv_pos_u2b(big, &offset, 0);
2060 else if (offset > biglen)
2062 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2063 (unsigned char*)tmps + biglen, little, 0)))
2066 retval = tmps2 - tmps;
2067 if (IN_UTF8 && retval > 0)
2068 sv_pos_b2u(big, &retval);
2069 PUSHi(retval + arybase);
2084 I32 arybase = PL_curcop->cop_arybase;
2090 tmps2 = SvPV(little, llen);
2091 tmps = SvPV(big, blen);
2095 if (IN_UTF8 && offset > 0)
2096 sv_pos_u2b(big, &offset, 0);
2097 offset = offset - arybase + llen;
2101 else if (offset > blen)
2103 if (!(tmps2 = rninstr(tmps, tmps + offset,
2104 tmps2, tmps2 + llen)))
2107 retval = tmps2 - tmps;
2108 if (IN_UTF8 && retval > 0)
2109 sv_pos_b2u(big, &retval);
2110 PUSHi(retval + arybase);
2116 djSP; dMARK; dORIGMARK; dTARGET;
2117 #ifdef USE_LOCALE_NUMERIC
2118 if (PL_op->op_private & OPpLOCALE)
2119 SET_NUMERIC_LOCAL();
2121 SET_NUMERIC_STANDARD();
2123 do_sprintf(TARG, SP-MARK, MARK+1);
2124 TAINT_IF(SvTAINTED(TARG));
2134 U8 *tmps = (U8*)POPp;
2137 if (IN_UTF8 && (*tmps & 0x80))
2138 value = utf8_to_uv(tmps, &retlen);
2140 value = (UV)(*tmps & 255);
2151 (void)SvUPGRADE(TARG,SVt_PV);
2153 if (IN_UTF8 && value >= 128) {
2156 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2157 SvCUR_set(TARG, tmps - SvPVX(TARG));
2159 (void)SvPOK_only(TARG);
2169 (void)SvPOK_only(TARG);
2176 djSP; dTARGET; dPOPTOPssrl;
2178 char *tmps = SvPV(left, PL_na);
2180 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2182 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2186 "The crypt() function is unimplemented due to excessive paranoia.");
2199 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2203 UV uv = utf8_to_uv(s, &ulen);
2205 if (PL_op->op_private & OPpLOCALE) {
2208 uv = toTITLE_LC_uni(uv);
2211 uv = toTITLE_utf8(s);
2213 tend = uv_to_utf8(tmpbuf, uv);
2215 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2217 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2218 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2222 s = (U8*)SvPV_force(sv, slen);
2223 Copy(tmpbuf, s, ulen, U8);
2228 if (!SvPADTMP(sv)) {
2234 s = (U8*)SvPV_force(sv, PL_na);
2236 if (PL_op->op_private & OPpLOCALE) {
2239 *s = toUPPER_LC(*s);
2255 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2259 UV uv = utf8_to_uv(s, &ulen);
2261 if (PL_op->op_private & OPpLOCALE) {
2264 uv = toLOWER_LC_uni(uv);
2267 uv = toLOWER_utf8(s);
2269 tend = uv_to_utf8(tmpbuf, uv);
2271 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2273 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2274 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2278 s = (U8*)SvPV_force(sv, slen);
2279 Copy(tmpbuf, s, ulen, U8);
2284 if (!SvPADTMP(sv)) {
2290 s = (U8*)SvPV_force(sv, PL_na);
2292 if (PL_op->op_private & OPpLOCALE) {
2295 *s = toLOWER_LC(*s);
2318 s = (U8*)SvPV(sv,len);
2320 sv_setpvn(TARG, "", 0);
2325 (void)SvUPGRADE(TARG, SVt_PV);
2326 SvGROW(TARG, (len * 2) + 1);
2327 (void)SvPOK_only(TARG);
2328 d = (U8*)SvPVX(TARG);
2330 if (PL_op->op_private & OPpLOCALE) {
2334 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2340 d = uv_to_utf8(d, toUPPER_utf8( s ));
2345 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2350 if (!SvPADTMP(sv)) {
2357 s = (U8*)SvPV_force(sv, len);
2359 register U8 *send = s + len;
2361 if (PL_op->op_private & OPpLOCALE) {
2364 for (; s < send; s++)
2365 *s = toUPPER_LC(*s);
2368 for (; s < send; s++)
2388 s = (U8*)SvPV(sv,len);
2390 sv_setpvn(TARG, "", 0);
2395 (void)SvUPGRADE(TARG, SVt_PV);
2396 SvGROW(TARG, (len * 2) + 1);
2397 (void)SvPOK_only(TARG);
2398 d = (U8*)SvPVX(TARG);
2400 if (PL_op->op_private & OPpLOCALE) {
2404 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2410 d = uv_to_utf8(d, toLOWER_utf8(s));
2415 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2420 if (!SvPADTMP(sv)) {
2427 s = (U8*)SvPV_force(sv, len);
2429 register U8 *send = s + len;
2431 if (PL_op->op_private & OPpLOCALE) {
2434 for (; s < send; s++)
2435 *s = toLOWER_LC(*s);
2438 for (; s < send; s++)
2450 register char *s = SvPV(sv,len);
2454 (void)SvUPGRADE(TARG, SVt_PV);
2455 SvGROW(TARG, (len * 2) + 1);
2460 STRLEN ulen = UTF8SKIP(s);
2483 SvCUR_set(TARG, d - SvPVX(TARG));
2484 (void)SvPOK_only(TARG);
2487 sv_setpvn(TARG, s, len);
2496 djSP; dMARK; dORIGMARK;
2498 register AV* av = (AV*)POPs;
2499 register I32 lval = PL_op->op_flags & OPf_MOD;
2500 I32 arybase = PL_curcop->cop_arybase;
2503 if (SvTYPE(av) == SVt_PVAV) {
2504 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2506 for (svp = MARK + 1; svp <= SP; svp++) {
2511 if (max > AvMAX(av))
2514 while (++MARK <= SP) {
2515 elem = SvIVx(*MARK);
2519 svp = av_fetch(av, elem, lval);
2521 if (!svp || *svp == &PL_sv_undef)
2522 DIE(PL_no_aelem, elem);
2523 if (PL_op->op_private & OPpLVAL_INTRO)
2524 save_aelem(av, elem, svp);
2526 *MARK = svp ? *svp : &PL_sv_undef;
2529 if (GIMME != G_ARRAY) {
2537 /* Associative arrays. */
2542 HV *hash = (HV*)POPs;
2544 I32 gimme = GIMME_V;
2545 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2548 /* might clobber stack_sp */
2549 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2554 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2555 if (gimme == G_ARRAY) {
2557 /* might clobber stack_sp */
2558 sv_setsv(TARG, realhv ?
2559 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2564 else if (gimme == G_SCALAR)
2583 I32 gimme = GIMME_V;
2584 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2588 if (PL_op->op_private & OPpSLICE) {
2592 hvtype = SvTYPE(hv);
2593 while (++MARK <= SP) {
2594 if (hvtype == SVt_PVHV)
2595 sv = hv_delete_ent(hv, *MARK, discard, 0);
2597 DIE("Not a HASH reference");
2598 *MARK = sv ? sv : &PL_sv_undef;
2602 else if (gimme == G_SCALAR) {
2611 if (SvTYPE(hv) == SVt_PVHV)
2612 sv = hv_delete_ent(hv, keysv, discard, 0);
2614 DIE("Not a HASH reference");
2628 if (SvTYPE(hv) == SVt_PVHV) {
2629 if (hv_exists_ent(hv, tmpsv, 0))
2631 } else if (SvTYPE(hv) == SVt_PVAV) {
2632 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2635 DIE("Not a HASH reference");
2642 djSP; dMARK; dORIGMARK;
2643 register HV *hv = (HV*)POPs;
2644 register I32 lval = PL_op->op_flags & OPf_MOD;
2645 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2647 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2648 DIE("Can't localize pseudo-hash element");
2650 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2651 while (++MARK <= SP) {
2655 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2656 svp = he ? &HeVAL(he) : 0;
2658 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2661 if (!svp || *svp == &PL_sv_undef)
2662 DIE(PL_no_helem, SvPV(keysv, PL_na));
2663 if (PL_op->op_private & OPpLVAL_INTRO)
2664 save_helem(hv, keysv, svp);
2666 *MARK = svp ? *svp : &PL_sv_undef;
2669 if (GIMME != G_ARRAY) {
2677 /* List operators. */
2682 if (GIMME != G_ARRAY) {
2684 *MARK = *SP; /* unwanted list, return last item */
2686 *MARK = &PL_sv_undef;
2695 SV **lastrelem = PL_stack_sp;
2696 SV **lastlelem = PL_stack_base + POPMARK;
2697 SV **firstlelem = PL_stack_base + POPMARK + 1;
2698 register SV **firstrelem = lastlelem + 1;
2699 I32 arybase = PL_curcop->cop_arybase;
2700 I32 lval = PL_op->op_flags & OPf_MOD;
2701 I32 is_something_there = lval;
2703 register I32 max = lastrelem - lastlelem;
2704 register SV **lelem;
2707 if (GIMME != G_ARRAY) {
2708 ix = SvIVx(*lastlelem);
2713 if (ix < 0 || ix >= max)
2714 *firstlelem = &PL_sv_undef;
2716 *firstlelem = firstrelem[ix];
2722 SP = firstlelem - 1;
2726 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2731 *lelem = &PL_sv_undef;
2732 else if (!(*lelem = firstrelem[ix]))
2733 *lelem = &PL_sv_undef;
2737 if (ix >= max || !(*lelem = firstrelem[ix]))
2738 *lelem = &PL_sv_undef;
2740 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2741 is_something_there = TRUE;
2743 if (is_something_there)
2746 SP = firstlelem - 1;
2752 djSP; dMARK; dORIGMARK;
2753 I32 items = SP - MARK;
2754 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2755 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2762 djSP; dMARK; dORIGMARK;
2763 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2767 SV *val = NEWSV(46, 0);
2769 sv_setsv(val, *++MARK);
2770 else if (ckWARN(WARN_UNSAFE))
2771 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2772 (void)hv_store_ent(hv,key,val,0);
2781 djSP; dMARK; dORIGMARK;
2782 register AV *ary = (AV*)*++MARK;
2786 register I32 offset;
2787 register I32 length;
2794 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2795 *MARK-- = SvTIED_obj((SV*)ary, mg);
2799 perl_call_method("SPLICE",GIMME_V);
2808 offset = i = SvIVx(*MARK);
2810 offset += AvFILLp(ary) + 1;
2812 offset -= PL_curcop->cop_arybase;
2814 DIE(PL_no_aelem, i);
2816 length = SvIVx(*MARK++);
2818 length += AvFILLp(ary) - offset + 1;
2824 length = AvMAX(ary) + 1; /* close enough to infinity */
2828 length = AvMAX(ary) + 1;
2830 if (offset > AvFILLp(ary) + 1)
2831 offset = AvFILLp(ary) + 1;
2832 after = AvFILLp(ary) + 1 - (offset + length);
2833 if (after < 0) { /* not that much array */
2834 length += after; /* offset+length now in array */
2840 /* At this point, MARK .. SP-1 is our new LIST */
2843 diff = newlen - length;
2844 if (newlen && !AvREAL(ary)) {
2848 assert(AvREAL(ary)); /* would leak, so croak */
2851 if (diff < 0) { /* shrinking the area */
2853 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2854 Copy(MARK, tmparyval, newlen, SV*);
2857 MARK = ORIGMARK + 1;
2858 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2859 MEXTEND(MARK, length);
2860 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2862 EXTEND_MORTAL(length);
2863 for (i = length, dst = MARK; i; i--) {
2864 sv_2mortal(*dst); /* free them eventualy */
2871 *MARK = AvARRAY(ary)[offset+length-1];
2874 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2875 SvREFCNT_dec(*dst++); /* free them now */
2878 AvFILLp(ary) += diff;
2880 /* pull up or down? */
2882 if (offset < after) { /* easier to pull up */
2883 if (offset) { /* esp. if nothing to pull */
2884 src = &AvARRAY(ary)[offset-1];
2885 dst = src - diff; /* diff is negative */
2886 for (i = offset; i > 0; i--) /* can't trust Copy */
2890 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2894 if (after) { /* anything to pull down? */
2895 src = AvARRAY(ary) + offset + length;
2896 dst = src + diff; /* diff is negative */
2897 Move(src, dst, after, SV*);
2899 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2900 /* avoid later double free */
2904 dst[--i] = &PL_sv_undef;
2907 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2909 *dst = NEWSV(46, 0);
2910 sv_setsv(*dst++, *src++);
2912 Safefree(tmparyval);
2915 else { /* no, expanding (or same) */
2917 New(452, tmparyval, length, SV*); /* so remember deletion */
2918 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2921 if (diff > 0) { /* expanding */
2923 /* push up or down? */
2925 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2929 Move(src, dst, offset, SV*);
2931 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2933 AvFILLp(ary) += diff;
2936 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2937 av_extend(ary, AvFILLp(ary) + diff);
2938 AvFILLp(ary) += diff;
2941 dst = AvARRAY(ary) + AvFILLp(ary);
2943 for (i = after; i; i--) {
2950 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2951 *dst = NEWSV(46, 0);
2952 sv_setsv(*dst++, *src++);
2954 MARK = ORIGMARK + 1;
2955 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2957 Copy(tmparyval, MARK, length, SV*);
2959 EXTEND_MORTAL(length);
2960 for (i = length, dst = MARK; i; i--) {
2961 sv_2mortal(*dst); /* free them eventualy */
2965 Safefree(tmparyval);
2969 else if (length--) {
2970 *MARK = tmparyval[length];
2973 while (length-- > 0)
2974 SvREFCNT_dec(tmparyval[length]);
2976 Safefree(tmparyval);
2979 *MARK = &PL_sv_undef;
2987 djSP; dMARK; dORIGMARK; dTARGET;
2988 register AV *ary = (AV*)*++MARK;
2989 register SV *sv = &PL_sv_undef;
2992 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2993 *MARK-- = SvTIED_obj((SV*)ary, mg);
2997 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3002 /* Why no pre-extend of ary here ? */
3003 for (++MARK; MARK <= SP; MARK++) {
3006 sv_setsv(sv, *MARK);
3011 PUSHi( AvFILL(ary) + 1 );
3019 SV *sv = av_pop(av);
3021 (void)sv_2mortal(sv);
3030 SV *sv = av_shift(av);
3035 (void)sv_2mortal(sv);
3042 djSP; dMARK; dORIGMARK; dTARGET;
3043 register AV *ary = (AV*)*++MARK;
3048 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3049 *MARK-- = SvTIED_obj((SV*)ary, mg);
3053 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3058 av_unshift(ary, SP - MARK);
3061 sv_setsv(sv, *++MARK);
3062 (void)av_store(ary, i++, sv);
3066 PUSHi( AvFILL(ary) + 1 );
3076 if (GIMME == G_ARRAY) {
3087 register char *down;
3093 do_join(TARG, &PL_sv_no, MARK, SP);
3095 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3096 up = SvPV_force(TARG, len);
3098 if (IN_UTF8) { /* first reverse each character */
3099 U8* s = (U8*)SvPVX(TARG);
3100 U8* send = (U8*)(s + len);
3109 down = (char*)(s - 1);
3110 if (s > send || !((*down & 0xc0) == 0x80)) {
3111 warn("Malformed UTF-8 character");
3123 down = SvPVX(TARG) + len - 1;
3129 (void)SvPOK_only(TARG);
3138 mul128(SV *sv, U8 m)
3141 char *s = SvPV(sv, len);
3145 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3146 SV *tmpNew = newSVpv("0000000000", 10);
3148 sv_catsv(tmpNew, sv);
3149 SvREFCNT_dec(sv); /* free old sv */
3154 while (!*t) /* trailing '\0'? */
3157 i = ((*t - '0') << 7) + m;
3158 *(t--) = '0' + (i % 10);
3164 /* Explosives and implosives. */
3166 static const char uuemap[] =
3167 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3168 static char uudmap[256]; /* Initialised on first use */
3169 #if 'I' == 73 && 'J' == 74
3170 /* On an ASCII/ISO kind of system */
3171 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3174 Some other sort of character set - use memchr() so we don't match
3177 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3185 I32 gimme = GIMME_V;
3189 register char *pat = SvPV(left, llen);
3190 register char *s = SvPV(right, rlen);
3191 char *strend = s + rlen;
3193 register char *patend = pat + llen;
3198 /* These must not be in registers: */
3215 register U32 culong;
3217 static char* bitcount = 0;
3220 if (gimme != G_ARRAY) { /* arrange to do first one only */
3222 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3223 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3225 while (isDIGIT(*patend) || *patend == '*')
3231 while (pat < patend) {
3233 datumtype = *pat++ & 0xFF;
3234 if (isSPACE(datumtype))
3238 else if (*pat == '*') {
3239 len = strend - strbeg; /* long enough */
3242 else if (isDIGIT(*pat)) {
3244 while (isDIGIT(*pat))
3245 len = (len * 10) + (*pat++ - '0');
3248 len = (datumtype != '@');
3251 croak("Invalid type in unpack: '%c'", (int)datumtype);
3252 case ',': /* grandfather in commas but with a warning */
3253 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3254 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3257 if (len == 1 && pat[-1] != '1')
3266 if (len > strend - strbeg)
3267 DIE("@ outside of string");
3271 if (len > s - strbeg)
3272 DIE("X outside of string");
3276 if (len > strend - s)
3277 DIE("x outside of string");
3282 if (len > strend - s)
3285 goto uchar_checksum;
3286 sv = NEWSV(35, len);
3287 sv_setpvn(sv, s, len);
3289 if (datumtype == 'A') {
3290 aptr = s; /* borrow register */
3291 s = SvPVX(sv) + len - 1;
3292 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3295 SvCUR_set(sv, s - SvPVX(sv));
3296 s = aptr; /* unborrow register */
3298 XPUSHs(sv_2mortal(sv));
3302 if (pat[-1] == '*' || len > (strend - s) * 8)
3303 len = (strend - s) * 8;
3306 Newz(601, bitcount, 256, char);
3307 for (bits = 1; bits < 256; bits++) {
3308 if (bits & 1) bitcount[bits]++;
3309 if (bits & 2) bitcount[bits]++;
3310 if (bits & 4) bitcount[bits]++;
3311 if (bits & 8) bitcount[bits]++;
3312 if (bits & 16) bitcount[bits]++;
3313 if (bits & 32) bitcount[bits]++;
3314 if (bits & 64) bitcount[bits]++;
3315 if (bits & 128) bitcount[bits]++;
3319 culong += bitcount[*(unsigned char*)s++];
3324 if (datumtype == 'b') {
3326 if (bits & 1) culong++;
3332 if (bits & 128) culong++;
3339 sv = NEWSV(35, len + 1);
3342 aptr = pat; /* borrow register */
3344 if (datumtype == 'b') {
3346 for (len = 0; len < aint; len++) {
3347 if (len & 7) /*SUPPRESS 595*/
3351 *pat++ = '0' + (bits & 1);
3356 for (len = 0; len < aint; len++) {
3361 *pat++ = '0' + ((bits & 128) != 0);
3365 pat = aptr; /* unborrow register */
3366 XPUSHs(sv_2mortal(sv));
3370 if (pat[-1] == '*' || len > (strend - s) * 2)
3371 len = (strend - s) * 2;
3372 sv = NEWSV(35, len + 1);
3375 aptr = pat; /* borrow register */
3377 if (datumtype == 'h') {
3379 for (len = 0; len < aint; len++) {
3384 *pat++ = PL_hexdigit[bits & 15];
3389 for (len = 0; len < aint; len++) {
3394 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3398 pat = aptr; /* unborrow register */
3399 XPUSHs(sv_2mortal(sv));
3402 if (len > strend - s)
3407 if (aint >= 128) /* fake up signed chars */
3417 if (aint >= 128) /* fake up signed chars */
3420 sv_setiv(sv, (IV)aint);
3421 PUSHs(sv_2mortal(sv));
3426 if (len > strend - s)
3441 sv_setiv(sv, (IV)auint);
3442 PUSHs(sv_2mortal(sv));
3447 if (len > strend - s)
3450 while (len-- > 0 && s < strend) {
3451 auint = utf8_to_uv((U8*)s, &along);
3454 cdouble += (double)auint;
3462 while (len-- > 0 && s < strend) {
3463 auint = utf8_to_uv((U8*)s, &along);
3466 sv_setuv(sv, (UV)auint);
3467 PUSHs(sv_2mortal(sv));
3472 along = (strend - s) / SIZE16;
3489 sv_setiv(sv, (IV)ashort);
3490 PUSHs(sv_2mortal(sv));
3497 along = (strend - s) / SIZE16;
3502 COPY16(s, &aushort);
3505 if (datumtype == 'n')
3506 aushort = PerlSock_ntohs(aushort);
3509 if (datumtype == 'v')
3510 aushort = vtohs(aushort);
3519 COPY16(s, &aushort);
3523 if (datumtype == 'n')
3524 aushort = PerlSock_ntohs(aushort);
3527 if (datumtype == 'v')
3528 aushort = vtohs(aushort);
3530 sv_setiv(sv, (IV)aushort);
3531 PUSHs(sv_2mortal(sv));
3536 along = (strend - s) / sizeof(int);
3541 Copy(s, &aint, 1, int);
3544 cdouble += (double)aint;
3553 Copy(s, &aint, 1, int);
3557 /* Without the dummy below unpack("i", pack("i",-1))
3558 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3559 * cc with optimization turned on */
3561 sv_setiv(sv, (IV)aint) :
3563 sv_setiv(sv, (IV)aint);
3564 PUSHs(sv_2mortal(sv));
3569 along = (strend - s) / sizeof(unsigned int);
3574 Copy(s, &auint, 1, unsigned int);
3575 s += sizeof(unsigned int);
3577 cdouble += (double)auint;
3586 Copy(s, &auint, 1, unsigned int);
3587 s += sizeof(unsigned int);
3589 sv_setuv(sv, (UV)auint);
3590 PUSHs(sv_2mortal(sv));
3595 along = (strend - s) / SIZE32;
3603 cdouble += (double)along;
3615 sv_setiv(sv, (IV)along);
3616 PUSHs(sv_2mortal(sv));
3623 along = (strend - s) / SIZE32;
3631 if (datumtype == 'N')
3632 aulong = PerlSock_ntohl(aulong);
3635 if (datumtype == 'V')
3636 aulong = vtohl(aulong);
3639 cdouble += (double)aulong;
3651 if (datumtype == 'N')
3652 aulong = PerlSock_ntohl(aulong);
3655 if (datumtype == 'V')
3656 aulong = vtohl(aulong);
3659 sv_setuv(sv, (UV)aulong);
3660 PUSHs(sv_2mortal(sv));
3665 along = (strend - s) / sizeof(char*);
3671 if (sizeof(char*) > strend - s)
3674 Copy(s, &aptr, 1, char*);
3680 PUSHs(sv_2mortal(sv));
3690 while ((len > 0) && (s < strend)) {
3691 auv = (auv << 7) | (*s & 0x7f);
3692 if (!(*s++ & 0x80)) {
3696 PUSHs(sv_2mortal(sv));
3700 else if (++bytes >= sizeof(UV)) { /* promote to string */
3703 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3704 while (s < strend) {
3705 sv = mul128(sv, *s & 0x7f);
3706 if (!(*s++ & 0x80)) {
3711 t = SvPV(sv, PL_na);
3715 PUSHs(sv_2mortal(sv));
3720 if ((s >= strend) && bytes)
3721 croak("Unterminated compressed integer");
3726 if (sizeof(char*) > strend - s)
3729 Copy(s, &aptr, 1, char*);
3734 sv_setpvn(sv, aptr, len);
3735 PUSHs(sv_2mortal(sv));
3739 along = (strend - s) / sizeof(Quad_t);
3745 if (s + sizeof(Quad_t) > strend)
3748 Copy(s, &aquad, 1, Quad_t);
3749 s += sizeof(Quad_t);
3752 if (aquad >= IV_MIN && aquad <= IV_MAX)
3753 sv_setiv(sv, (IV)aquad);
3755 sv_setnv(sv, (double)aquad);
3756 PUSHs(sv_2mortal(sv));
3760 along = (strend - s) / sizeof(Quad_t);
3766 if (s + sizeof(Uquad_t) > strend)
3769 Copy(s, &auquad, 1, Uquad_t);
3770 s += sizeof(Uquad_t);
3773 if (auquad <= UV_MAX)
3774 sv_setuv(sv, (UV)auquad);
3776 sv_setnv(sv, (double)auquad);
3777 PUSHs(sv_2mortal(sv));
3781 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3784 along = (strend - s) / sizeof(float);
3789 Copy(s, &afloat, 1, float);
3798 Copy(s, &afloat, 1, float);
3801 sv_setnv(sv, (double)afloat);
3802 PUSHs(sv_2mortal(sv));
3808 along = (strend - s) / sizeof(double);
3813 Copy(s, &adouble, 1, double);
3814 s += sizeof(double);
3822 Copy(s, &adouble, 1, double);
3823 s += sizeof(double);
3825 sv_setnv(sv, (double)adouble);
3826 PUSHs(sv_2mortal(sv));
3832 * Initialise the decode mapping. By using a table driven
3833 * algorithm, the code will be character-set independent
3834 * (and just as fast as doing character arithmetic)
3836 if (uudmap['M'] == 0) {
3839 for (i = 0; i < sizeof(uuemap); i += 1)
3840 uudmap[uuemap[i]] = i;
3842 * Because ' ' and '`' map to the same value,
3843 * we need to decode them both the same.
3848 along = (strend - s) * 3 / 4;
3849 sv = NEWSV(42, along);
3852 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3857 len = uudmap[*s++] & 077;
3859 if (s < strend && ISUUCHAR(*s))
3860 a = uudmap[*s++] & 077;
3863 if (s < strend && ISUUCHAR(*s))
3864 b = uudmap[*s++] & 077;
3867 if (s < strend && ISUUCHAR(*s))
3868 c = uudmap[*s++] & 077;
3871 if (s < strend && ISUUCHAR(*s))
3872 d = uudmap[*s++] & 077;
3875 hunk[0] = (a << 2) | (b >> 4);
3876 hunk[1] = (b << 4) | (c >> 2);
3877 hunk[2] = (c << 6) | d;
3878 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3883 else if (s[1] == '\n') /* possible checksum byte */
3886 XPUSHs(sv_2mortal(sv));
3891 if (strchr("fFdD", datumtype) ||
3892 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
3896 while (checksum >= 16) {
3900 while (checksum >= 4) {
3906 along = (1 << checksum) - 1;
3907 while (cdouble < 0.0)
3909 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3910 sv_setnv(sv, cdouble);
3913 if (checksum < 32) {
3914 aulong = (1 << checksum) - 1;
3917 sv_setuv(sv, (UV)culong);
3919 XPUSHs(sv_2mortal(sv));
3923 if (SP == oldsp && gimme == G_SCALAR)
3924 PUSHs(&PL_sv_undef);
3929 doencodes(register SV *sv, register char *s, register I32 len)
3933 *hunk = uuemap[len];
3934 sv_catpvn(sv, hunk, 1);
3937 hunk[0] = uuemap[(077 & (*s >> 2))];
3938 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3939 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3940 hunk[3] = uuemap[(077 & (s[2] & 077))];
3941 sv_catpvn(sv, hunk, 4);
3946 char r = (len > 1 ? s[1] : '\0');
3947 hunk[0] = uuemap[(077 & (*s >> 2))];
3948 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3949 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3950 hunk[3] = uuemap[0];
3951 sv_catpvn(sv, hunk, 4);
3953 sv_catpvn(sv, "\n", 1);
3957 is_an_int(char *s, STRLEN l)
3959 SV *result = newSVpv("", l);
3960 char *result_c = SvPV(result, PL_na); /* convenience */
3961 char *out = result_c;
3971 SvREFCNT_dec(result);
3994 SvREFCNT_dec(result);
4000 SvCUR_set(result, out - result_c);
4005 div128(SV *pnum, bool *done)
4006 /* must be '\0' terminated */
4010 char *s = SvPV(pnum, len);
4019 i = m * 10 + (*t - '0');
4021 r = (i >> 7); /* r < 10 */
4028 SvCUR_set(pnum, (STRLEN) (t - s));
4035 djSP; dMARK; dORIGMARK; dTARGET;
4036 register SV *cat = TARG;
4039 register char *pat = SvPVx(*++MARK, fromlen);
4040 register char *patend = pat + fromlen;
4045 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4046 static char *space10 = " ";
4048 /* These must not be in registers: */
4066 sv_setpvn(cat, "", 0);
4067 while (pat < patend) {
4068 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4069 datumtype = *pat++ & 0xFF;
4070 if (isSPACE(datumtype))
4073 len = strchr("@Xxu", datumtype) ? 0 : items;
4076 else if (isDIGIT(*pat)) {
4078 while (isDIGIT(*pat))
4079 len = (len * 10) + (*pat++ - '0');
4085 croak("Invalid type in pack: '%c'", (int)datumtype);
4086 case ',': /* grandfather in commas but with a warning */
4087 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4088 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4091 DIE("%% may only be used in unpack");
4102 if (SvCUR(cat) < len)
4103 DIE("X outside of string");
4110 sv_catpvn(cat, null10, 10);
4113 sv_catpvn(cat, null10, len);
4118 aptr = SvPV(fromstr, fromlen);
4122 sv_catpvn(cat, aptr, len);
4124 sv_catpvn(cat, aptr, fromlen);
4126 if (datumtype == 'A') {
4128 sv_catpvn(cat, space10, 10);
4131 sv_catpvn(cat, space10, len);
4135 sv_catpvn(cat, null10, 10);
4138 sv_catpvn(cat, null10, len);
4145 char *savepat = pat;
4150 aptr = SvPV(fromstr, fromlen);
4155 SvCUR(cat) += (len+7)/8;
4156 SvGROW(cat, SvCUR(cat) + 1);
4157 aptr = SvPVX(cat) + aint;
4162 if (datumtype == 'B') {
4163 for (len = 0; len++ < aint;) {
4164 items |= *pat++ & 1;
4168 *aptr++ = items & 0xff;
4174 for (len = 0; len++ < aint;) {
4180 *aptr++ = items & 0xff;
4186 if (datumtype == 'B')
4187 items <<= 7 - (aint & 7);
4189 items >>= 7 - (aint & 7);
4190 *aptr++ = items & 0xff;
4192 pat = SvPVX(cat) + SvCUR(cat);
4203 char *savepat = pat;
4208 aptr = SvPV(fromstr, fromlen);
4213 SvCUR(cat) += (len+1)/2;
4214 SvGROW(cat, SvCUR(cat) + 1);
4215 aptr = SvPVX(cat) + aint;
4220 if (datumtype == 'H') {
4221 for (len = 0; len++ < aint;) {
4223 items |= ((*pat++ & 15) + 9) & 15;
4225 items |= *pat++ & 15;
4229 *aptr++ = items & 0xff;
4235 for (len = 0; len++ < aint;) {
4237 items |= (((*pat++ & 15) + 9) & 15) << 4;
4239 items |= (*pat++ & 15) << 4;
4243 *aptr++ = items & 0xff;
4249 *aptr++ = items & 0xff;
4250 pat = SvPVX(cat) + SvCUR(cat);
4262 aint = SvIV(fromstr);
4264 sv_catpvn(cat, &achar, sizeof(char));
4270 auint = SvUV(fromstr);
4271 SvGROW(cat, SvCUR(cat) + 10);
4272 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4277 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4282 afloat = (float)SvNV(fromstr);
4283 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4290 adouble = (double)SvNV(fromstr);
4291 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4297 ashort = (I16)SvIV(fromstr);
4299 ashort = PerlSock_htons(ashort);
4301 CAT16(cat, &ashort);
4307 ashort = (I16)SvIV(fromstr);
4309 ashort = htovs(ashort);
4311 CAT16(cat, &ashort);
4318 ashort = (I16)SvIV(fromstr);
4319 CAT16(cat, &ashort);
4325 auint = SvUV(fromstr);
4326 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4332 adouble = floor(SvNV(fromstr));
4335 croak("Cannot compress negative numbers");
4341 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4342 adouble <= UV_MAX_cxux
4349 char buf[1 + sizeof(UV)];
4350 char *in = buf + sizeof(buf);
4351 UV auv = U_V(adouble);;
4354 *--in = (auv & 0x7f) | 0x80;
4357 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4358 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4360 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4361 char *from, *result, *in;
4366 /* Copy string and check for compliance */
4367 from = SvPV(fromstr, len);
4368 if ((norm = is_an_int(from, len)) == NULL)
4369 croak("can compress only unsigned integer");
4371 New('w', result, len, char);
4375 *--in = div128(norm, &done) | 0x80;
4376 result[len - 1] &= 0x7F; /* clear continue bit */
4377 sv_catpvn(cat, in, (result + len) - in);
4379 SvREFCNT_dec(norm); /* free norm */
4381 else if (SvNOKp(fromstr)) {
4382 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4383 char *in = buf + sizeof(buf);
4386 double next = floor(adouble / 128);
4387 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4388 if (--in < buf) /* this cannot happen ;-) */
4389 croak ("Cannot compress integer");
4391 } while (adouble > 0);
4392 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4393 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4396 croak("Cannot compress non integer");
4402 aint = SvIV(fromstr);
4403 sv_catpvn(cat, (char*)&aint, sizeof(int));
4409 aulong = SvUV(fromstr);
4411 aulong = PerlSock_htonl(aulong);
4413 CAT32(cat, &aulong);
4419 aulong = SvUV(fromstr);
4421 aulong = htovl(aulong);
4423 CAT32(cat, &aulong);
4429 aulong = SvUV(fromstr);
4430 CAT32(cat, &aulong);
4436 along = SvIV(fromstr);
4444 auquad = (Uquad_t)SvIV(fromstr);
4445 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4451 aquad = (Quad_t)SvIV(fromstr);
4452 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4455 #endif /* HAS_QUAD */
4457 len = 1; /* assume SV is correct length */
4462 if (fromstr == &PL_sv_undef)
4465 /* XXX better yet, could spirit away the string to
4466 * a safe spot and hang on to it until the result
4467 * of pack() (and all copies of the result) are
4470 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4472 "Attempt to pack pointer to temporary value");
4473 if (SvPOK(fromstr) || SvNIOK(fromstr))
4474 aptr = SvPV(fromstr,PL_na);
4476 aptr = SvPV_force(fromstr,PL_na);
4478 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4483 aptr = SvPV(fromstr, fromlen);
4484 SvGROW(cat, fromlen * 4 / 3);
4489 while (fromlen > 0) {
4496 doencodes(cat, aptr, todo);
4515 register I32 limit = POPi; /* note, negative is forever */
4518 register char *s = SvPV(sv, len);
4519 char *strend = s + len;
4521 register REGEXP *rx;
4525 I32 maxiters = (strend - s) + 10;
4528 I32 origlimit = limit;
4531 AV *oldstack = PL_curstack;
4532 I32 gimme = GIMME_V;
4533 I32 oldsave = PL_savestack_ix;
4534 I32 make_mortal = 1;
4535 MAGIC *mg = (MAGIC *) NULL;
4538 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4543 DIE("panic: do_split");
4544 rx = pm->op_pmregexp;
4546 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4547 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4549 if (pm->op_pmreplroot)
4550 ary = GvAVn((GV*)pm->op_pmreplroot);
4551 else if (gimme != G_ARRAY)
4553 ary = (AV*)PL_curpad[0];
4555 ary = GvAVn(PL_defgv);
4556 #endif /* USE_THREADS */
4559 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4565 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4567 XPUSHs(SvTIED_obj((SV*)ary, mg));
4572 for (i = AvFILLp(ary); i >= 0; i--)
4573 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4575 /* temporarily switch stacks */
4576 SWITCHSTACK(PL_curstack, ary);
4580 base = SP - PL_stack_base;
4582 if (pm->op_pmflags & PMf_SKIPWHITE) {
4583 if (pm->op_pmflags & PMf_LOCALE) {
4584 while (isSPACE_LC(*s))
4592 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4593 SAVEINT(PL_multiline);
4594 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4598 limit = maxiters + 2;
4599 if (pm->op_pmflags & PMf_WHITE) {
4602 while (m < strend &&
4603 !((pm->op_pmflags & PMf_LOCALE)
4604 ? isSPACE_LC(*m) : isSPACE(*m)))
4609 dstr = NEWSV(30, m-s);
4610 sv_setpvn(dstr, s, m-s);
4616 while (s < strend &&
4617 ((pm->op_pmflags & PMf_LOCALE)
4618 ? isSPACE_LC(*s) : isSPACE(*s)))
4622 else if (strEQ("^", rx->precomp)) {
4625 for (m = s; m < strend && *m != '\n'; m++) ;
4629 dstr = NEWSV(30, m-s);
4630 sv_setpvn(dstr, s, m-s);
4637 else if (rx->check_substr && !rx->nparens
4638 && (rx->reganch & ROPT_CHECK_ALL)
4639 && !(rx->reganch & ROPT_ANCH)) {
4640 i = SvCUR(rx->check_substr);
4641 if (i == 1 && !SvTAIL(rx->check_substr)) {
4642 i = *SvPVX(rx->check_substr);
4645 for (m = s; m < strend && *m != i; m++) ;
4648 dstr = NEWSV(30, m-s);
4649 sv_setpvn(dstr, s, m-s);
4658 while (s < strend && --limit &&
4659 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4660 rx->check_substr, 0)) )
4663 dstr = NEWSV(31, m-s);
4664 sv_setpvn(dstr, s, m-s);
4673 maxiters += (strend - s) * rx->nparens;
4674 while (s < strend && --limit &&
4675 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4677 TAINT_IF(RX_MATCH_TAINTED(rx));
4679 && rx->subbase != orig) {
4684 strend = s + (strend - m);
4687 dstr = NEWSV(32, m-s);
4688 sv_setpvn(dstr, s, m-s);
4693 for (i = 1; i <= rx->nparens; i++) {
4697 dstr = NEWSV(33, m-s);
4698 sv_setpvn(dstr, s, m-s);
4701 dstr = NEWSV(33, 0);
4711 LEAVE_SCOPE(oldsave);
4712 iters = (SP - PL_stack_base) - base;
4713 if (iters > maxiters)
4716 /* keep field after final delim? */
4717 if (s < strend || (iters && origlimit)) {
4718 dstr = NEWSV(34, strend-s);
4719 sv_setpvn(dstr, s, strend-s);
4725 else if (!origlimit) {
4726 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4732 SWITCHSTACK(ary, oldstack);
4733 if (SvSMAGICAL(ary)) {
4738 if (gimme == G_ARRAY) {
4740 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4748 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4751 if (gimme == G_ARRAY) {
4752 /* EXTEND should not be needed - we just popped them */
4754 for (i=0; i < iters; i++) {
4755 SV **svp = av_fetch(ary, i, FALSE);
4756 PUSHs((svp) ? *svp : &PL_sv_undef);
4763 if (gimme == G_ARRAY)
4766 if (iters || !pm->op_pmreplroot) {
4776 unlock_condpair(void *svv)
4779 MAGIC *mg = mg_find((SV*)svv, 'm');
4782 croak("panic: unlock_condpair unlocking non-mutex");
4783 MUTEX_LOCK(MgMUTEXP(mg));
4784 if (MgOWNER(mg) != thr)
4785 croak("panic: unlock_condpair unlocking mutex that we don't own");
4787 COND_SIGNAL(MgOWNERCONDP(mg));
4788 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4789 (unsigned long)thr, (unsigned long)svv);)
4790 MUTEX_UNLOCK(MgMUTEXP(mg));
4792 #endif /* USE_THREADS */
4805 mg = condpair_magic(sv);
4806 MUTEX_LOCK(MgMUTEXP(mg));
4807 if (MgOWNER(mg) == thr)
4808 MUTEX_UNLOCK(MgMUTEXP(mg));
4811 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4813 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4814 (unsigned long)thr, (unsigned long)sv);)
4815 MUTEX_UNLOCK(MgMUTEXP(mg));
4816 save_destructor(unlock_condpair, sv);
4818 #endif /* USE_THREADS */
4819 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4820 || SvTYPE(retsv) == SVt_PVCV) {
4821 retsv = refto(retsv);
4832 if (PL_op->op_private & OPpLVAL_INTRO)
4833 PUSHs(*save_threadsv(PL_op->op_targ));
4835 PUSHs(THREADSV(PL_op->op_targ));
4838 DIE("tried to access per-thread data in non-threaded perl");
4839 #endif /* USE_THREADS */