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 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
84 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
85 # define PERL_NATINT_PACK
88 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
89 # if BYTEORDER == 0x12345678
90 # define OFF16(p) (char*)(p)
91 # define OFF32(p) (char*)(p)
93 # if BYTEORDER == 0x87654321
94 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
95 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
97 }}}} bad cray byte order
100 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
101 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
102 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
103 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
104 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
106 # define COPY16(s,p) Copy(s, p, SIZE16, char)
107 # define COPY32(s,p) Copy(s, p, SIZE32, char)
108 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
109 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
110 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
114 static void doencodes _((SV* sv, char* s, I32 len));
115 static SV* refto _((SV* sv));
116 static U32 seed _((void));
119 /* variations on pp_null */
125 /* XXX I can't imagine anyone who doesn't have this actually _needs_
126 it, since pid_t is an integral type.
129 #ifdef NEED_GETPID_PROTO
130 extern Pid_t getpid (void);
136 if (GIMME_V == G_SCALAR)
137 XPUSHs(&PL_sv_undef);
151 if (PL_op->op_private & OPpLVAL_INTRO)
152 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
154 if (PL_op->op_flags & OPf_REF) {
158 if (GIMME == G_ARRAY) {
159 I32 maxarg = AvFILL((AV*)TARG) + 1;
161 if (SvMAGICAL(TARG)) {
163 for (i=0; i < maxarg; i++) {
164 SV **svp = av_fetch((AV*)TARG, i, FALSE);
165 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
169 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
174 SV* sv = sv_newmortal();
175 I32 maxarg = AvFILL((AV*)TARG) + 1;
176 sv_setiv(sv, maxarg);
188 if (PL_op->op_private & OPpLVAL_INTRO)
189 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
190 if (PL_op->op_flags & OPf_REF)
193 if (gimme == G_ARRAY) {
194 RETURNOP(do_kv(ARGS));
196 else if (gimme == G_SCALAR) {
197 SV* sv = sv_newmortal();
198 if (HvFILL((HV*)TARG))
199 sv_setpvf(sv, "%ld/%ld",
200 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
210 DIE("NOT IMPL LINE %d",__LINE__);
221 tryAMAGICunDEREF(to_gv);
224 if (SvTYPE(sv) == SVt_PVIO) {
225 GV *gv = (GV*) sv_newmortal();
226 gv_init(gv, 0, "", 0, 0);
227 GvIOp(gv) = (IO *)sv;
228 (void)SvREFCNT_inc(sv);
231 else if (SvTYPE(sv) != SVt_PVGV)
232 DIE("Not a GLOB reference");
235 if (SvTYPE(sv) != SVt_PVGV) {
239 if (SvGMAGICAL(sv)) {
245 if (PL_op->op_flags & OPf_REF ||
246 PL_op->op_private & HINT_STRICT_REFS)
247 DIE(PL_no_usym, "a symbol");
248 if (ckWARN(WARN_UNINITIALIZED))
249 warner(WARN_UNINITIALIZED, PL_warn_uninit);
253 if ((PL_op->op_flags & OPf_SPECIAL) &&
254 !(PL_op->op_flags & OPf_MOD))
256 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
261 if (PL_op->op_private & HINT_STRICT_REFS)
262 DIE(PL_no_symref, sym, "a symbol");
263 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
267 if (PL_op->op_private & OPpLVAL_INTRO)
268 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
279 tryAMAGICunDEREF(to_sv);
282 switch (SvTYPE(sv)) {
286 DIE("Not a SCALAR reference");
294 if (SvTYPE(gv) != SVt_PVGV) {
295 if (SvGMAGICAL(sv)) {
301 if (PL_op->op_flags & OPf_REF ||
302 PL_op->op_private & HINT_STRICT_REFS)
303 DIE(PL_no_usym, "a SCALAR");
304 if (ckWARN(WARN_UNINITIALIZED))
305 warner(WARN_UNINITIALIZED, PL_warn_uninit);
309 if ((PL_op->op_flags & OPf_SPECIAL) &&
310 !(PL_op->op_flags & OPf_MOD))
312 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
317 if (PL_op->op_private & HINT_STRICT_REFS)
318 DIE(PL_no_symref, sym, "a SCALAR");
319 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
324 if (PL_op->op_flags & OPf_MOD) {
325 if (PL_op->op_private & OPpLVAL_INTRO)
326 sv = save_scalar((GV*)TOPs);
327 else if (PL_op->op_private & OPpDEREF)
328 vivify_ref(sv, PL_op->op_private & OPpDEREF);
338 SV *sv = AvARYLEN(av);
340 AvARYLEN(av) = sv = NEWSV(0,0);
341 sv_upgrade(sv, SVt_IV);
342 sv_magic(sv, (SV*)av, '#', Nullch, 0);
350 djSP; dTARGET; dPOPss;
352 if (PL_op->op_flags & OPf_MOD) {
353 if (SvTYPE(TARG) < SVt_PVLV) {
354 sv_upgrade(TARG, SVt_PVLV);
355 sv_magic(TARG, Nullsv, '.', Nullch, 0);
359 if (LvTARG(TARG) != sv) {
361 SvREFCNT_dec(LvTARG(TARG));
362 LvTARG(TARG) = SvREFCNT_inc(sv);
364 PUSHs(TARG); /* no SvSETMAGIC */
370 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
371 mg = mg_find(sv, 'g');
372 if (mg && mg->mg_len >= 0) {
376 PUSHi(i + PL_curcop->cop_arybase);
390 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
391 /* (But not in defined().) */
392 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
395 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
398 cv = (CV*)&PL_sv_undef;
412 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
413 char *s = SvPVX(TOPs);
414 if (strnEQ(s, "CORE::", 6)) {
417 code = keyword(s + 6, SvCUR(TOPs) - 6);
418 if (code < 0) { /* Overridable. */
419 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
420 int i = 0, n = 0, seen_question = 0;
422 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
424 while (i < MAXO) { /* The slow way. */
425 if (strEQ(s + 6, PL_op_name[i])
426 || strEQ(s + 6, PL_op_desc[i]))
432 goto nonesuch; /* Should not happen... */
434 oa = PL_opargs[i] >> OASHIFT;
436 if (oa & OA_OPTIONAL) {
440 else if (seen_question)
441 goto set; /* XXXX system, exec */
442 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
443 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
446 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
447 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
451 ret = sv_2mortal(newSVpv(str, n - 1));
453 else if (code) /* Non-Overridable */
455 else { /* None such */
457 croak("Cannot find an opnumber for \"%s\"", s+6);
461 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
463 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
472 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
474 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
490 if (GIMME != G_ARRAY) {
494 *MARK = &PL_sv_undef;
495 *MARK = refto(*MARK);
499 EXTEND_MORTAL(SP - MARK);
501 *MARK = refto(*MARK);
510 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
513 if (!(sv = LvTARG(sv)))
516 else if (SvPADTMP(sv))
520 (void)SvREFCNT_inc(sv);
523 sv_upgrade(rv, SVt_RV);
537 if (sv && SvGMAGICAL(sv))
540 if (!sv || !SvROK(sv))
544 pv = sv_reftype(sv,TRUE);
545 PUSHp(pv, strlen(pv));
555 stash = PL_curcop->cop_stash;
559 char *ptr = SvPV(ssv,len);
560 if (ckWARN(WARN_UNSAFE) && len == 0)
562 "Explicit blessing to '' (assuming package main)");
563 stash = gv_stashpvn(ptr, len, TRUE);
566 (void)sv_bless(TOPs, stash);
580 elem = SvPV(sv, n_a);
584 switch (elem ? *elem : '\0')
587 if (strEQ(elem, "ARRAY"))
588 tmpRef = (SV*)GvAV(gv);
591 if (strEQ(elem, "CODE"))
592 tmpRef = (SV*)GvCVu(gv);
595 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
596 tmpRef = (SV*)GvIOp(gv);
599 if (strEQ(elem, "GLOB"))
603 if (strEQ(elem, "HASH"))
604 tmpRef = (SV*)GvHV(gv);
607 if (strEQ(elem, "IO"))
608 tmpRef = (SV*)GvIOp(gv);
611 if (strEQ(elem, "NAME"))
612 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
615 if (strEQ(elem, "PACKAGE"))
616 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
619 if (strEQ(elem, "SCALAR"))
633 /* Pattern matching */
638 register UNOP *unop = cUNOP;
639 register unsigned char *s;
642 register I32 *sfirst;
646 if (sv == PL_lastscream) {
652 SvSCREAM_off(PL_lastscream);
653 SvREFCNT_dec(PL_lastscream);
655 PL_lastscream = SvREFCNT_inc(sv);
658 s = (unsigned char*)(SvPV(sv, len));
662 if (pos > PL_maxscream) {
663 if (PL_maxscream < 0) {
664 PL_maxscream = pos + 80;
665 New(301, PL_screamfirst, 256, I32);
666 New(302, PL_screamnext, PL_maxscream, I32);
669 PL_maxscream = pos + pos / 4;
670 Renew(PL_screamnext, PL_maxscream, I32);
674 sfirst = PL_screamfirst;
675 snext = PL_screamnext;
677 if (!sfirst || !snext)
678 DIE("do_study: out of memory");
680 for (ch = 256; ch; --ch)
687 snext[pos] = sfirst[ch] - pos;
694 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
703 if (PL_op->op_flags & OPf_STACKED)
709 TARG = sv_newmortal();
714 /* Lvalue operators. */
726 djSP; dMARK; dTARGET;
736 SETi(do_chomp(TOPs));
742 djSP; dMARK; dTARGET;
743 register I32 count = 0;
746 count += do_chomp(POPs);
757 if (!sv || !SvANY(sv))
759 switch (SvTYPE(sv)) {
761 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
765 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
769 if (CvROOT(sv) || CvXSUB(sv))
786 if (!PL_op->op_private) {
795 if (SvTHINKFIRST(sv)) {
796 if (SvREADONLY(sv)) {
798 if (PL_curcop != &PL_compiling)
805 switch (SvTYPE(sv)) {
815 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
816 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
817 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
820 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
822 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
826 SvSetMagicSV(sv, &PL_sv_undef);
830 Newz(602, gp, 1, GP);
831 GvGP(sv) = gp_ref(gp);
832 GvSV(sv) = NEWSV(72,0);
833 GvLINE(sv) = PL_curcop->cop_line;
839 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
842 SvPV_set(sv, Nullch);
855 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
857 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
858 SvIVX(TOPs) != IV_MIN)
861 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
874 sv_setsv(TARG, TOPs);
875 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
876 SvIVX(TOPs) != IV_MAX)
879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
893 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
895 sv_setsv(TARG, TOPs);
896 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
897 SvIVX(TOPs) != IV_MIN)
900 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
909 /* Ordinary operators. */
913 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
916 SETn( pow( left, right) );
923 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
926 SETn( left * right );
933 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
938 DIE("Illegal division by zero");
940 /* insure that 20./5. == 4. */
943 if ((double)I_V(left) == left &&
944 (double)I_V(right) == right &&
945 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
949 value = left / right;
953 value = left / right;
962 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
970 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
972 right = (right_neg = (i < 0)) ? -i : i;
976 right = U_V((right_neg = (n < 0)) ? -n : n);
979 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
981 left = (left_neg = (i < 0)) ? -i : i;
985 left = U_V((left_neg = (n < 0)) ? -n : n);
989 DIE("Illegal modulus zero");
992 if ((left_neg != right_neg) && ans)
995 /* XXX may warn: unary minus operator applied to unsigned type */
996 /* could change -foo to be (~foo)+1 instead */
997 if (ans <= ~((UV)IV_MAX)+1)
998 sv_setiv(TARG, ~ans+1);
1000 sv_setnv(TARG, -(double)ans);
1003 sv_setuv(TARG, ans);
1011 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1013 register I32 count = POPi;
1014 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1016 I32 items = SP - MARK;
1019 max = items * count;
1028 repeatcpy((char*)(MARK + items), (char*)MARK,
1029 items * sizeof(SV*), count - 1);
1032 else if (count <= 0)
1035 else { /* Note: mark already snarfed by pp_list */
1040 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1041 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1042 DIE("Can't x= to readonly value");
1046 SvSetSV(TARG, tmpstr);
1047 SvPV_force(TARG, len);
1052 SvGROW(TARG, (count * len) + 1);
1053 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1054 SvCUR(TARG) *= count;
1056 *SvEND(TARG) = '\0';
1058 (void)SvPOK_only(TARG);
1067 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1070 SETn( left - right );
1077 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1080 if (PL_op->op_private & HINT_INTEGER) {
1082 i = BWi(i) << shift;
1096 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1099 if (PL_op->op_private & HINT_INTEGER) {
1101 i = BWi(i) >> shift;
1115 djSP; tryAMAGICbinSET(lt,0);
1118 SETs(boolSV(TOPn < value));
1125 djSP; tryAMAGICbinSET(gt,0);
1128 SETs(boolSV(TOPn > value));
1135 djSP; tryAMAGICbinSET(le,0);
1138 SETs(boolSV(TOPn <= value));
1145 djSP; tryAMAGICbinSET(ge,0);
1148 SETs(boolSV(TOPn >= value));
1155 djSP; tryAMAGICbinSET(ne,0);
1158 SETs(boolSV(TOPn != value));
1165 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1172 else if (left < right)
1174 else if (left > right)
1187 djSP; tryAMAGICbinSET(slt,0);
1190 int cmp = ((PL_op->op_private & OPpLOCALE)
1191 ? sv_cmp_locale(left, right)
1192 : sv_cmp(left, right));
1193 SETs(boolSV(cmp < 0));
1200 djSP; tryAMAGICbinSET(sgt,0);
1203 int cmp = ((PL_op->op_private & OPpLOCALE)
1204 ? sv_cmp_locale(left, right)
1205 : sv_cmp(left, right));
1206 SETs(boolSV(cmp > 0));
1213 djSP; tryAMAGICbinSET(sle,0);
1216 int cmp = ((PL_op->op_private & OPpLOCALE)
1217 ? sv_cmp_locale(left, right)
1218 : sv_cmp(left, right));
1219 SETs(boolSV(cmp <= 0));
1226 djSP; tryAMAGICbinSET(sge,0);
1229 int cmp = ((PL_op->op_private & OPpLOCALE)
1230 ? sv_cmp_locale(left, right)
1231 : sv_cmp(left, right));
1232 SETs(boolSV(cmp >= 0));
1239 djSP; tryAMAGICbinSET(seq,0);
1242 SETs(boolSV(sv_eq(left, right)));
1249 djSP; tryAMAGICbinSET(sne,0);
1252 SETs(boolSV(!sv_eq(left, right)));
1259 djSP; dTARGET; tryAMAGICbin(scmp,0);
1262 int cmp = ((PL_op->op_private & OPpLOCALE)
1263 ? sv_cmp_locale(left, right)
1264 : sv_cmp(left, right));
1272 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1275 if (SvNIOKp(left) || SvNIOKp(right)) {
1276 if (PL_op->op_private & HINT_INTEGER) {
1277 IBW value = SvIV(left) & SvIV(right);
1281 UBW value = SvUV(left) & SvUV(right);
1286 do_vop(PL_op->op_type, TARG, left, right);
1295 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1298 if (SvNIOKp(left) || SvNIOKp(right)) {
1299 if (PL_op->op_private & HINT_INTEGER) {
1300 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1304 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1309 do_vop(PL_op->op_type, TARG, left, right);
1318 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1321 if (SvNIOKp(left) || SvNIOKp(right)) {
1322 if (PL_op->op_private & HINT_INTEGER) {
1323 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1327 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1332 do_vop(PL_op->op_type, TARG, left, right);
1341 djSP; dTARGET; tryAMAGICun(neg);
1346 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1348 else if (SvNIOKp(sv))
1350 else if (SvPOKp(sv)) {
1352 char *s = SvPV(sv, len);
1353 if (isIDFIRST(*s)) {
1354 sv_setpvn(TARG, "-", 1);
1357 else if (*s == '+' || *s == '-') {
1359 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1361 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1362 sv_setpvn(TARG, "-", 1);
1366 sv_setnv(TARG, -SvNV(sv));
1377 djSP; tryAMAGICunSET(not);
1378 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1384 djSP; dTARGET; tryAMAGICun(compl);
1388 if (PL_op->op_private & HINT_INTEGER) {
1389 IBW value = ~SvIV(sv);
1393 UBW value = ~SvUV(sv);
1398 register char *tmps;
1399 register long *tmpl;
1404 tmps = SvPV_force(TARG, len);
1407 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1410 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1414 for ( ; anum > 0; anum--, tmps++)
1423 /* integer versions of some of the above */
1427 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1430 SETi( left * right );
1437 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1441 DIE("Illegal division by zero");
1442 value = POPi / value;
1450 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1454 DIE("Illegal modulus zero");
1455 SETi( left % right );
1462 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1465 SETi( left + right );
1472 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1475 SETi( left - right );
1482 djSP; tryAMAGICbinSET(lt,0);
1485 SETs(boolSV(left < right));
1492 djSP; tryAMAGICbinSET(gt,0);
1495 SETs(boolSV(left > right));
1502 djSP; tryAMAGICbinSET(le,0);
1505 SETs(boolSV(left <= right));
1512 djSP; tryAMAGICbinSET(ge,0);
1515 SETs(boolSV(left >= right));
1522 djSP; tryAMAGICbinSET(eq,0);
1525 SETs(boolSV(left == right));
1532 djSP; tryAMAGICbinSET(ne,0);
1535 SETs(boolSV(left != right));
1542 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1549 else if (left < right)
1560 djSP; dTARGET; tryAMAGICun(neg);
1565 /* High falutin' math. */
1569 djSP; dTARGET; tryAMAGICbin(atan2,0);
1572 SETn(atan2(left, right));
1579 djSP; dTARGET; tryAMAGICun(sin);
1591 djSP; dTARGET; tryAMAGICun(cos);
1601 /* Support Configure command-line overrides for rand() functions.
1602 After 5.005, perhaps we should replace this by Configure support
1603 for drand48(), random(), or rand(). For 5.005, though, maintain
1604 compatibility by calling rand() but allow the user to override it.
1605 See INSTALL for details. --Andy Dougherty 15 July 1998
1607 /* Now it's after 5.005, and Configure supports drand48() and random(),
1608 in addition to rand(). So the overrides should not be needed any more.
1609 --Jarkko Hietaniemi 27 September 1998
1612 #ifndef HAS_DRAND48_PROTO
1613 extern double drand48 _((void));
1626 if (!PL_srand_called) {
1627 (void)seedDrand01((Rand_seed_t)seed());
1628 PL_srand_called = TRUE;
1643 (void)seedDrand01((Rand_seed_t)anum);
1644 PL_srand_called = TRUE;
1653 * This is really just a quick hack which grabs various garbage
1654 * values. It really should be a real hash algorithm which
1655 * spreads the effect of every input bit onto every output bit,
1656 * if someone who knows about such things would bother to write it.
1657 * Might be a good idea to add that function to CORE as well.
1658 * No numbers below come from careful analysis or anything here,
1659 * except they are primes and SEED_C1 > 1E6 to get a full-width
1660 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1661 * probably be bigger too.
1664 # define SEED_C1 1000003
1665 #define SEED_C4 73819
1667 # define SEED_C1 25747
1668 #define SEED_C4 20639
1672 #define SEED_C5 26107
1675 #ifndef PERL_NO_DEV_RANDOM
1680 # include <starlet.h>
1681 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1682 * in 100-ns units, typically incremented ever 10 ms. */
1683 unsigned int when[2];
1685 # ifdef HAS_GETTIMEOFDAY
1686 struct timeval when;
1692 /* This test is an escape hatch, this symbol isn't set by Configure. */
1693 #ifndef PERL_NO_DEV_RANDOM
1694 #ifndef PERL_RANDOM_DEVICE
1695 /* /dev/random isn't used by default because reads from it will block
1696 * if there isn't enough entropy available. You can compile with
1697 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1698 * is enough real entropy to fill the seed. */
1699 # define PERL_RANDOM_DEVICE "/dev/urandom"
1701 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1703 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1712 _ckvmssts(sys$gettim(when));
1713 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1715 # ifdef HAS_GETTIMEOFDAY
1716 gettimeofday(&when,(struct timezone *) 0);
1717 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1720 u = (U32)SEED_C1 * when;
1723 u += SEED_C3 * (U32)getpid();
1724 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1725 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1726 u += SEED_C5 * (U32)(UV)&when;
1733 djSP; dTARGET; tryAMAGICun(exp);
1745 djSP; dTARGET; tryAMAGICun(log);
1750 SET_NUMERIC_STANDARD();
1751 DIE("Can't take log of %g", value);
1761 djSP; dTARGET; tryAMAGICun(sqrt);
1766 SET_NUMERIC_STANDARD();
1767 DIE("Can't take sqrt of %g", value);
1769 value = sqrt(value);
1779 double value = TOPn;
1782 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1788 (void)modf(value, &value);
1790 (void)modf(-value, &value);
1805 djSP; dTARGET; tryAMAGICun(abs);
1807 double value = TOPn;
1810 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1811 (iv = SvIVX(TOPs)) != IV_MIN) {
1833 XPUSHu(scan_hex(tmps, 99, &argtype));
1846 while (*tmps && isSPACE(*tmps))
1851 value = scan_hex(++tmps, 99, &argtype);
1852 else if (*tmps == 'b')
1853 value = scan_bin(++tmps, 99, &argtype);
1855 value = scan_oct(tmps, 99, &argtype);
1867 SETi( sv_len_utf8(TOPs) );
1871 SETi( sv_len(TOPs) );
1885 I32 lvalue = PL_op->op_flags & OPf_MOD;
1887 I32 arybase = PL_curcop->cop_arybase;
1891 SvTAINTED_off(TARG); /* decontaminate */
1895 repl = SvPV(sv, repl_len);
1902 tmps = SvPV(sv, curlen);
1904 utfcurlen = sv_len_utf8(sv);
1905 if (utfcurlen == curlen)
1913 if (pos >= arybase) {
1931 else if (len >= 0) {
1933 if (rem > (I32)curlen)
1947 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1948 warner(WARN_SUBSTR, "substr outside of string");
1953 sv_pos_u2b(sv, &pos, &rem);
1955 sv_setpvn(TARG, tmps, rem);
1956 if (lvalue) { /* it's an lvalue! */
1957 if (!SvGMAGICAL(sv)) {
1961 if (ckWARN(WARN_SUBSTR))
1963 "Attempt to use reference as lvalue in substr");
1965 if (SvOK(sv)) /* is it defined ? */
1966 (void)SvPOK_only(sv);
1968 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1971 if (SvTYPE(TARG) < SVt_PVLV) {
1972 sv_upgrade(TARG, SVt_PVLV);
1973 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1977 if (LvTARG(TARG) != sv) {
1979 SvREFCNT_dec(LvTARG(TARG));
1980 LvTARG(TARG) = SvREFCNT_inc(sv);
1982 LvTARGOFF(TARG) = pos;
1983 LvTARGLEN(TARG) = rem;
1986 sv_insert(sv, pos, rem, repl, repl_len);
1989 PUSHs(TARG); /* avoid SvSETMAGIC here */
1996 register I32 size = POPi;
1997 register I32 offset = POPi;
1998 register SV *src = POPs;
1999 I32 lvalue = PL_op->op_flags & OPf_MOD;
2001 unsigned char *s = (unsigned char*)SvPV(src, srclen);
2002 unsigned long retnum;
2005 SvTAINTED_off(TARG); /* decontaminate */
2006 offset *= size; /* turn into bit offset */
2007 len = (offset + size + 7) / 8;
2008 if (offset < 0 || size < 1)
2011 if (lvalue) { /* it's an lvalue! */
2012 if (SvTYPE(TARG) < SVt_PVLV) {
2013 sv_upgrade(TARG, SVt_PVLV);
2014 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2018 if (LvTARG(TARG) != src) {
2020 SvREFCNT_dec(LvTARG(TARG));
2021 LvTARG(TARG) = SvREFCNT_inc(src);
2023 LvTARGOFF(TARG) = offset;
2024 LvTARGLEN(TARG) = size;
2032 if (offset >= srclen)
2035 retnum = (unsigned long) s[offset] << 8;
2037 else if (size == 32) {
2038 if (offset >= srclen)
2040 else if (offset + 1 >= srclen)
2041 retnum = (unsigned long) s[offset] << 24;
2042 else if (offset + 2 >= srclen)
2043 retnum = ((unsigned long) s[offset] << 24) +
2044 ((unsigned long) s[offset + 1] << 16);
2046 retnum = ((unsigned long) s[offset] << 24) +
2047 ((unsigned long) s[offset + 1] << 16) +
2048 (s[offset + 2] << 8);
2053 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2058 else if (size == 16)
2059 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2060 else if (size == 32)
2061 retnum = ((unsigned long) s[offset] << 24) +
2062 ((unsigned long) s[offset + 1] << 16) +
2063 (s[offset + 2] << 8) + s[offset+3];
2067 sv_setuv(TARG, (UV)retnum);
2082 I32 arybase = PL_curcop->cop_arybase;
2087 offset = POPi - arybase;
2090 tmps = SvPV(big, biglen);
2091 if (IN_UTF8 && offset > 0)
2092 sv_pos_u2b(big, &offset, 0);
2095 else if (offset > biglen)
2097 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2098 (unsigned char*)tmps + biglen, little, 0)))
2101 retval = tmps2 - tmps;
2102 if (IN_UTF8 && retval > 0)
2103 sv_pos_b2u(big, &retval);
2104 PUSHi(retval + arybase);
2119 I32 arybase = PL_curcop->cop_arybase;
2125 tmps2 = SvPV(little, llen);
2126 tmps = SvPV(big, blen);
2130 if (IN_UTF8 && offset > 0)
2131 sv_pos_u2b(big, &offset, 0);
2132 offset = offset - arybase + llen;
2136 else if (offset > blen)
2138 if (!(tmps2 = rninstr(tmps, tmps + offset,
2139 tmps2, tmps2 + llen)))
2142 retval = tmps2 - tmps;
2143 if (IN_UTF8 && retval > 0)
2144 sv_pos_b2u(big, &retval);
2145 PUSHi(retval + arybase);
2151 djSP; dMARK; dORIGMARK; dTARGET;
2152 #ifdef USE_LOCALE_NUMERIC
2153 if (PL_op->op_private & OPpLOCALE)
2154 SET_NUMERIC_LOCAL();
2156 SET_NUMERIC_STANDARD();
2158 do_sprintf(TARG, SP-MARK, MARK+1);
2159 TAINT_IF(SvTAINTED(TARG));
2170 U8 *tmps = (U8*)POPpx;
2173 if (IN_UTF8 && (*tmps & 0x80))
2174 value = utf8_to_uv(tmps, &retlen);
2176 value = (UV)(*tmps & 255);
2187 (void)SvUPGRADE(TARG,SVt_PV);
2189 if (IN_UTF8 && value >= 128) {
2192 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2193 SvCUR_set(TARG, tmps - SvPVX(TARG));
2195 (void)SvPOK_only(TARG);
2205 (void)SvPOK_only(TARG);
2212 djSP; dTARGET; dPOPTOPssrl;
2215 char *tmps = SvPV(left, n_a);
2217 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2219 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2223 "The crypt() function is unimplemented due to excessive paranoia.");
2236 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2240 UV uv = utf8_to_uv(s, &ulen);
2242 if (PL_op->op_private & OPpLOCALE) {
2245 uv = toTITLE_LC_uni(uv);
2248 uv = toTITLE_utf8(s);
2250 tend = uv_to_utf8(tmpbuf, uv);
2252 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2254 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2255 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2259 s = (U8*)SvPV_force(sv, slen);
2260 Copy(tmpbuf, s, ulen, U8);
2265 if (!SvPADTMP(sv)) {
2271 s = (U8*)SvPV_force(sv, slen);
2273 if (PL_op->op_private & OPpLOCALE) {
2276 *s = toUPPER_LC(*s);
2292 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2296 UV uv = utf8_to_uv(s, &ulen);
2298 if (PL_op->op_private & OPpLOCALE) {
2301 uv = toLOWER_LC_uni(uv);
2304 uv = toLOWER_utf8(s);
2306 tend = uv_to_utf8(tmpbuf, uv);
2308 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2310 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2311 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2315 s = (U8*)SvPV_force(sv, slen);
2316 Copy(tmpbuf, s, ulen, U8);
2321 if (!SvPADTMP(sv)) {
2327 s = (U8*)SvPV_force(sv, slen);
2329 if (PL_op->op_private & OPpLOCALE) {
2332 *s = toLOWER_LC(*s);
2355 s = (U8*)SvPV(sv,len);
2357 sv_setpvn(TARG, "", 0);
2362 (void)SvUPGRADE(TARG, SVt_PV);
2363 SvGROW(TARG, (len * 2) + 1);
2364 (void)SvPOK_only(TARG);
2365 d = (U8*)SvPVX(TARG);
2367 if (PL_op->op_private & OPpLOCALE) {
2371 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2377 d = uv_to_utf8(d, toUPPER_utf8( s ));
2382 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2387 if (!SvPADTMP(sv)) {
2394 s = (U8*)SvPV_force(sv, len);
2396 register U8 *send = s + len;
2398 if (PL_op->op_private & OPpLOCALE) {
2401 for (; s < send; s++)
2402 *s = toUPPER_LC(*s);
2405 for (; s < send; s++)
2425 s = (U8*)SvPV(sv,len);
2427 sv_setpvn(TARG, "", 0);
2432 (void)SvUPGRADE(TARG, SVt_PV);
2433 SvGROW(TARG, (len * 2) + 1);
2434 (void)SvPOK_only(TARG);
2435 d = (U8*)SvPVX(TARG);
2437 if (PL_op->op_private & OPpLOCALE) {
2441 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2447 d = uv_to_utf8(d, toLOWER_utf8(s));
2452 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2457 if (!SvPADTMP(sv)) {
2464 s = (U8*)SvPV_force(sv, len);
2466 register U8 *send = s + len;
2468 if (PL_op->op_private & OPpLOCALE) {
2471 for (; s < send; s++)
2472 *s = toLOWER_LC(*s);
2475 for (; s < send; s++)
2487 register char *s = SvPV(sv,len);
2491 (void)SvUPGRADE(TARG, SVt_PV);
2492 SvGROW(TARG, (len * 2) + 1);
2497 STRLEN ulen = UTF8SKIP(s);
2520 SvCUR_set(TARG, d - SvPVX(TARG));
2521 (void)SvPOK_only(TARG);
2524 sv_setpvn(TARG, s, len);
2533 djSP; dMARK; dORIGMARK;
2535 register AV* av = (AV*)POPs;
2536 register I32 lval = PL_op->op_flags & OPf_MOD;
2537 I32 arybase = PL_curcop->cop_arybase;
2540 if (SvTYPE(av) == SVt_PVAV) {
2541 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2543 for (svp = MARK + 1; svp <= SP; svp++) {
2548 if (max > AvMAX(av))
2551 while (++MARK <= SP) {
2552 elem = SvIVx(*MARK);
2556 svp = av_fetch(av, elem, lval);
2558 if (!svp || *svp == &PL_sv_undef)
2559 DIE(PL_no_aelem, elem);
2560 if (PL_op->op_private & OPpLVAL_INTRO)
2561 save_aelem(av, elem, svp);
2563 *MARK = svp ? *svp : &PL_sv_undef;
2566 if (GIMME != G_ARRAY) {
2574 /* Associative arrays. */
2579 HV *hash = (HV*)POPs;
2581 I32 gimme = GIMME_V;
2582 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2585 /* might clobber stack_sp */
2586 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2591 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2592 if (gimme == G_ARRAY) {
2594 /* might clobber stack_sp */
2595 sv_setsv(TARG, realhv ?
2596 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2601 else if (gimme == G_SCALAR)
2620 I32 gimme = GIMME_V;
2621 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2625 if (PL_op->op_private & OPpSLICE) {
2629 hvtype = SvTYPE(hv);
2630 while (++MARK <= SP) {
2631 if (hvtype == SVt_PVHV)
2632 sv = hv_delete_ent(hv, *MARK, discard, 0);
2634 DIE("Not a HASH reference");
2635 *MARK = sv ? sv : &PL_sv_undef;
2639 else if (gimme == G_SCALAR) {
2648 if (SvTYPE(hv) == SVt_PVHV)
2649 sv = hv_delete_ent(hv, keysv, discard, 0);
2651 DIE("Not a HASH reference");
2665 if (SvTYPE(hv) == SVt_PVHV) {
2666 if (hv_exists_ent(hv, tmpsv, 0))
2669 else if (SvTYPE(hv) == SVt_PVAV) {
2670 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2674 DIE("Not a HASH reference");
2681 djSP; dMARK; dORIGMARK;
2682 register HV *hv = (HV*)POPs;
2683 register I32 lval = PL_op->op_flags & OPf_MOD;
2684 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2686 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2687 DIE("Can't localize pseudo-hash element");
2689 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2690 while (++MARK <= SP) {
2694 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2695 svp = he ? &HeVAL(he) : 0;
2698 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2701 if (!svp || *svp == &PL_sv_undef) {
2703 DIE(PL_no_helem, SvPV(keysv, n_a));
2705 if (PL_op->op_private & OPpLVAL_INTRO)
2706 save_helem(hv, keysv, svp);
2708 *MARK = svp ? *svp : &PL_sv_undef;
2711 if (GIMME != G_ARRAY) {
2719 /* List operators. */
2724 if (GIMME != G_ARRAY) {
2726 *MARK = *SP; /* unwanted list, return last item */
2728 *MARK = &PL_sv_undef;
2737 SV **lastrelem = PL_stack_sp;
2738 SV **lastlelem = PL_stack_base + POPMARK;
2739 SV **firstlelem = PL_stack_base + POPMARK + 1;
2740 register SV **firstrelem = lastlelem + 1;
2741 I32 arybase = PL_curcop->cop_arybase;
2742 I32 lval = PL_op->op_flags & OPf_MOD;
2743 I32 is_something_there = lval;
2745 register I32 max = lastrelem - lastlelem;
2746 register SV **lelem;
2749 if (GIMME != G_ARRAY) {
2750 ix = SvIVx(*lastlelem);
2755 if (ix < 0 || ix >= max)
2756 *firstlelem = &PL_sv_undef;
2758 *firstlelem = firstrelem[ix];
2764 SP = firstlelem - 1;
2768 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2773 *lelem = &PL_sv_undef;
2774 else if (!(*lelem = firstrelem[ix]))
2775 *lelem = &PL_sv_undef;
2779 if (ix >= max || !(*lelem = firstrelem[ix]))
2780 *lelem = &PL_sv_undef;
2782 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2783 is_something_there = TRUE;
2785 if (is_something_there)
2788 SP = firstlelem - 1;
2794 djSP; dMARK; dORIGMARK;
2795 I32 items = SP - MARK;
2796 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2797 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2804 djSP; dMARK; dORIGMARK;
2805 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2809 SV *val = NEWSV(46, 0);
2811 sv_setsv(val, *++MARK);
2812 else if (ckWARN(WARN_UNSAFE))
2813 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2814 (void)hv_store_ent(hv,key,val,0);
2823 djSP; dMARK; dORIGMARK;
2824 register AV *ary = (AV*)*++MARK;
2828 register I32 offset;
2829 register I32 length;
2836 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2837 *MARK-- = SvTIED_obj((SV*)ary, mg);
2841 perl_call_method("SPLICE",GIMME_V);
2850 offset = i = SvIVx(*MARK);
2852 offset += AvFILLp(ary) + 1;
2854 offset -= PL_curcop->cop_arybase;
2856 DIE(PL_no_aelem, i);
2858 length = SvIVx(*MARK++);
2860 length += AvFILLp(ary) - offset + 1;
2866 length = AvMAX(ary) + 1; /* close enough to infinity */
2870 length = AvMAX(ary) + 1;
2872 if (offset > AvFILLp(ary) + 1)
2873 offset = AvFILLp(ary) + 1;
2874 after = AvFILLp(ary) + 1 - (offset + length);
2875 if (after < 0) { /* not that much array */
2876 length += after; /* offset+length now in array */
2882 /* At this point, MARK .. SP-1 is our new LIST */
2885 diff = newlen - length;
2886 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2889 if (diff < 0) { /* shrinking the area */
2891 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2892 Copy(MARK, tmparyval, newlen, SV*);
2895 MARK = ORIGMARK + 1;
2896 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2897 MEXTEND(MARK, length);
2898 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2900 EXTEND_MORTAL(length);
2901 for (i = length, dst = MARK; i; i--) {
2902 sv_2mortal(*dst); /* free them eventualy */
2909 *MARK = AvARRAY(ary)[offset+length-1];
2912 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2913 SvREFCNT_dec(*dst++); /* free them now */
2916 AvFILLp(ary) += diff;
2918 /* pull up or down? */
2920 if (offset < after) { /* easier to pull up */
2921 if (offset) { /* esp. if nothing to pull */
2922 src = &AvARRAY(ary)[offset-1];
2923 dst = src - diff; /* diff is negative */
2924 for (i = offset; i > 0; i--) /* can't trust Copy */
2928 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2932 if (after) { /* anything to pull down? */
2933 src = AvARRAY(ary) + offset + length;
2934 dst = src + diff; /* diff is negative */
2935 Move(src, dst, after, SV*);
2937 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2938 /* avoid later double free */
2942 dst[--i] = &PL_sv_undef;
2945 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2947 *dst = NEWSV(46, 0);
2948 sv_setsv(*dst++, *src++);
2950 Safefree(tmparyval);
2953 else { /* no, expanding (or same) */
2955 New(452, tmparyval, length, SV*); /* so remember deletion */
2956 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2959 if (diff > 0) { /* expanding */
2961 /* push up or down? */
2963 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2967 Move(src, dst, offset, SV*);
2969 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2971 AvFILLp(ary) += diff;
2974 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2975 av_extend(ary, AvFILLp(ary) + diff);
2976 AvFILLp(ary) += diff;
2979 dst = AvARRAY(ary) + AvFILLp(ary);
2981 for (i = after; i; i--) {
2988 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2989 *dst = NEWSV(46, 0);
2990 sv_setsv(*dst++, *src++);
2992 MARK = ORIGMARK + 1;
2993 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2995 Copy(tmparyval, MARK, length, SV*);
2997 EXTEND_MORTAL(length);
2998 for (i = length, dst = MARK; i; i--) {
2999 sv_2mortal(*dst); /* free them eventualy */
3003 Safefree(tmparyval);
3007 else if (length--) {
3008 *MARK = tmparyval[length];
3011 while (length-- > 0)
3012 SvREFCNT_dec(tmparyval[length]);
3014 Safefree(tmparyval);
3017 *MARK = &PL_sv_undef;
3025 djSP; dMARK; dORIGMARK; dTARGET;
3026 register AV *ary = (AV*)*++MARK;
3027 register SV *sv = &PL_sv_undef;
3030 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3031 *MARK-- = SvTIED_obj((SV*)ary, mg);
3035 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3040 /* Why no pre-extend of ary here ? */
3041 for (++MARK; MARK <= SP; MARK++) {
3044 sv_setsv(sv, *MARK);
3049 PUSHi( AvFILL(ary) + 1 );
3057 SV *sv = av_pop(av);
3059 (void)sv_2mortal(sv);
3068 SV *sv = av_shift(av);
3073 (void)sv_2mortal(sv);
3080 djSP; dMARK; dORIGMARK; dTARGET;
3081 register AV *ary = (AV*)*++MARK;
3086 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3087 *MARK-- = SvTIED_obj((SV*)ary, mg);
3091 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3096 av_unshift(ary, SP - MARK);
3099 sv_setsv(sv, *++MARK);
3100 (void)av_store(ary, i++, sv);
3104 PUSHi( AvFILL(ary) + 1 );
3114 if (GIMME == G_ARRAY) {
3125 register char *down;
3131 do_join(TARG, &PL_sv_no, MARK, SP);
3133 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3134 up = SvPV_force(TARG, len);
3136 if (IN_UTF8) { /* first reverse each character */
3137 U8* s = (U8*)SvPVX(TARG);
3138 U8* send = (U8*)(s + len);
3147 down = (char*)(s - 1);
3148 if (s > send || !((*down & 0xc0) == 0x80)) {
3149 warn("Malformed UTF-8 character");
3161 down = SvPVX(TARG) + len - 1;
3167 (void)SvPOK_only(TARG);
3176 mul128(SV *sv, U8 m)
3179 char *s = SvPV(sv, len);
3183 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3184 SV *tmpNew = newSVpv("0000000000", 10);
3186 sv_catsv(tmpNew, sv);
3187 SvREFCNT_dec(sv); /* free old sv */
3192 while (!*t) /* trailing '\0'? */
3195 i = ((*t - '0') << 7) + m;
3196 *(t--) = '0' + (i % 10);
3202 /* Explosives and implosives. */
3204 #if 'I' == 73 && 'J' == 74
3205 /* On an ASCII/ISO kind of system */
3206 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3209 Some other sort of character set - use memchr() so we don't match
3212 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3220 I32 gimme = GIMME_V;
3224 register char *pat = SvPV(left, llen);
3225 register char *s = SvPV(right, rlen);
3226 char *strend = s + rlen;
3228 register char *patend = pat + llen;
3233 /* These must not be in registers: */
3250 register U32 culong;
3253 #ifdef PERL_NATINT_PACK
3254 int natint; /* native integer */
3255 int unatint; /* unsigned native integer */
3258 if (gimme != G_ARRAY) { /* arrange to do first one only */
3260 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3261 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3263 while (isDIGIT(*patend) || *patend == '*')
3269 while (pat < patend) {
3271 datumtype = *pat++ & 0xFF;
3272 #ifdef PERL_NATINT_PACK
3275 if (isSPACE(datumtype))
3278 char *natstr = "sSiIlL";
3280 if (strchr(natstr, datumtype)) {
3281 #ifdef PERL_NATINT_PACK
3287 croak("'!' allowed only after types %s", natstr);
3291 else if (*pat == '*') {
3292 len = strend - strbeg; /* long enough */
3295 else if (isDIGIT(*pat)) {
3297 while (isDIGIT(*pat))
3298 len = (len * 10) + (*pat++ - '0');
3301 len = (datumtype != '@');
3304 croak("Invalid type in unpack: '%c'", (int)datumtype);
3305 case ',': /* grandfather in commas but with a warning */
3306 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3307 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3310 if (len == 1 && pat[-1] != '1')
3319 if (len > strend - strbeg)
3320 DIE("@ outside of string");
3324 if (len > s - strbeg)
3325 DIE("X outside of string");
3329 if (len > strend - s)
3330 DIE("x outside of string");
3336 if (len > strend - s)
3339 goto uchar_checksum;
3340 sv = NEWSV(35, len);
3341 sv_setpvn(sv, s, len);
3343 if (datumtype == 'A' || datumtype == 'Z') {
3344 aptr = s; /* borrow register */
3345 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3350 else { /* 'A' strips both nulls and spaces */
3351 s = SvPVX(sv) + len - 1;
3352 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3356 SvCUR_set(sv, s - SvPVX(sv));
3357 s = aptr; /* unborrow register */
3359 XPUSHs(sv_2mortal(sv));
3363 if (pat[-1] == '*' || len > (strend - s) * 8)
3364 len = (strend - s) * 8;
3367 Newz(601, PL_bitcount, 256, char);
3368 for (bits = 1; bits < 256; bits++) {
3369 if (bits & 1) PL_bitcount[bits]++;
3370 if (bits & 2) PL_bitcount[bits]++;
3371 if (bits & 4) PL_bitcount[bits]++;
3372 if (bits & 8) PL_bitcount[bits]++;
3373 if (bits & 16) PL_bitcount[bits]++;
3374 if (bits & 32) PL_bitcount[bits]++;
3375 if (bits & 64) PL_bitcount[bits]++;
3376 if (bits & 128) PL_bitcount[bits]++;
3380 culong += PL_bitcount[*(unsigned char*)s++];
3385 if (datumtype == 'b') {
3387 if (bits & 1) culong++;
3393 if (bits & 128) culong++;
3400 sv = NEWSV(35, len + 1);
3403 aptr = pat; /* borrow register */
3405 if (datumtype == 'b') {
3407 for (len = 0; len < aint; len++) {
3408 if (len & 7) /*SUPPRESS 595*/
3412 *pat++ = '0' + (bits & 1);
3417 for (len = 0; len < aint; len++) {
3422 *pat++ = '0' + ((bits & 128) != 0);
3426 pat = aptr; /* unborrow register */
3427 XPUSHs(sv_2mortal(sv));
3431 if (pat[-1] == '*' || len > (strend - s) * 2)
3432 len = (strend - s) * 2;
3433 sv = NEWSV(35, len + 1);
3436 aptr = pat; /* borrow register */
3438 if (datumtype == 'h') {
3440 for (len = 0; len < aint; len++) {
3445 *pat++ = PL_hexdigit[bits & 15];
3450 for (len = 0; len < aint; len++) {
3455 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3459 pat = aptr; /* unborrow register */
3460 XPUSHs(sv_2mortal(sv));
3463 if (len > strend - s)
3468 if (aint >= 128) /* fake up signed chars */
3478 if (aint >= 128) /* fake up signed chars */
3481 sv_setiv(sv, (IV)aint);
3482 PUSHs(sv_2mortal(sv));
3487 if (len > strend - s)
3502 sv_setiv(sv, (IV)auint);
3503 PUSHs(sv_2mortal(sv));
3508 if (len > strend - s)
3511 while (len-- > 0 && s < strend) {
3512 auint = utf8_to_uv((U8*)s, &along);
3515 cdouble += (double)auint;
3523 while (len-- > 0 && s < strend) {
3524 auint = utf8_to_uv((U8*)s, &along);
3527 sv_setuv(sv, (UV)auint);
3528 PUSHs(sv_2mortal(sv));
3533 #if SHORTSIZE == SIZE16
3534 along = (strend - s) / SIZE16;
3536 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3541 #if SHORTSIZE != SIZE16
3544 COPYNN(s, &ashort, sizeof(short));
3555 #if SHORTSIZE > SIZE16
3567 #if SHORTSIZE != SIZE16
3570 COPYNN(s, &ashort, sizeof(short));
3573 sv_setiv(sv, (IV)ashort);
3574 PUSHs(sv_2mortal(sv));
3582 #if SHORTSIZE > SIZE16
3588 sv_setiv(sv, (IV)ashort);
3589 PUSHs(sv_2mortal(sv));
3597 #if SHORTSIZE == SIZE16
3598 along = (strend - s) / SIZE16;
3600 unatint = natint && datumtype == 'S';
3601 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3606 #if SHORTSIZE != SIZE16
3609 COPYNN(s, &aushort, sizeof(unsigned short));
3610 s += sizeof(unsigned short);
3618 COPY16(s, &aushort);
3621 if (datumtype == 'n')
3622 aushort = PerlSock_ntohs(aushort);
3625 if (datumtype == 'v')
3626 aushort = vtohs(aushort);
3635 #if SHORTSIZE != SIZE16
3638 COPYNN(s, &aushort, sizeof(unsigned short));
3639 s += sizeof(unsigned short);
3641 sv_setiv(sv, (UV)aushort);
3642 PUSHs(sv_2mortal(sv));
3649 COPY16(s, &aushort);
3653 if (datumtype == 'n')
3654 aushort = PerlSock_ntohs(aushort);
3657 if (datumtype == 'v')
3658 aushort = vtohs(aushort);
3660 sv_setiv(sv, (UV)aushort);
3661 PUSHs(sv_2mortal(sv));
3667 along = (strend - s) / sizeof(int);
3672 Copy(s, &aint, 1, int);
3675 cdouble += (double)aint;
3684 Copy(s, &aint, 1, int);
3688 /* Without the dummy below unpack("i", pack("i",-1))
3689 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3690 * cc with optimization turned on */
3692 sv_setiv(sv, (IV)aint) :
3694 sv_setiv(sv, (IV)aint);
3695 PUSHs(sv_2mortal(sv));
3700 along = (strend - s) / sizeof(unsigned int);
3705 Copy(s, &auint, 1, unsigned int);
3706 s += sizeof(unsigned int);
3708 cdouble += (double)auint;
3717 Copy(s, &auint, 1, unsigned int);
3718 s += sizeof(unsigned int);
3721 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3722 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3723 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3724 * with optimization turned on.
3725 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3726 * does not have this problem even with -O4)
3729 sv_setuv(sv, (UV)auint) :
3731 sv_setuv(sv, (UV)auint);
3732 PUSHs(sv_2mortal(sv));
3737 #if LONGSIZE == SIZE32
3738 along = (strend - s) / SIZE32;
3740 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3745 #if LONGSIZE != SIZE32
3748 COPYNN(s, &along, sizeof(long));
3751 cdouble += (double)along;
3761 #if LONGSIZE > SIZE32
3762 if (along > 2147483647)
3763 along -= 4294967296;
3767 cdouble += (double)along;
3776 #if LONGSIZE != SIZE32
3779 COPYNN(s, &along, sizeof(long));
3782 sv_setiv(sv, (IV)along);
3783 PUSHs(sv_2mortal(sv));
3791 #if LONGSIZE > SIZE32
3792 if (along > 2147483647)
3793 along -= 4294967296;
3797 sv_setiv(sv, (IV)along);
3798 PUSHs(sv_2mortal(sv));
3806 #if LONGSIZE == SIZE32
3807 along = (strend - s) / SIZE32;
3809 unatint = natint && datumtype == 'L';
3810 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3815 #if LONGSIZE != SIZE32
3818 COPYNN(s, &aulong, sizeof(unsigned long));
3819 s += sizeof(unsigned long);
3821 cdouble += (double)aulong;
3833 if (datumtype == 'N')
3834 aulong = PerlSock_ntohl(aulong);
3837 if (datumtype == 'V')
3838 aulong = vtohl(aulong);
3841 cdouble += (double)aulong;
3850 #if LONGSIZE != SIZE32
3853 COPYNN(s, &aulong, sizeof(unsigned long));
3854 s += sizeof(unsigned long);
3856 sv_setuv(sv, (UV)aulong);
3857 PUSHs(sv_2mortal(sv));
3867 if (datumtype == 'N')
3868 aulong = PerlSock_ntohl(aulong);
3871 if (datumtype == 'V')
3872 aulong = vtohl(aulong);
3875 sv_setuv(sv, (UV)aulong);
3876 PUSHs(sv_2mortal(sv));
3882 along = (strend - s) / sizeof(char*);
3888 if (sizeof(char*) > strend - s)
3891 Copy(s, &aptr, 1, char*);
3897 PUSHs(sv_2mortal(sv));
3907 while ((len > 0) && (s < strend)) {
3908 auv = (auv << 7) | (*s & 0x7f);
3909 if (!(*s++ & 0x80)) {
3913 PUSHs(sv_2mortal(sv));
3917 else if (++bytes >= sizeof(UV)) { /* promote to string */
3921 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3922 while (s < strend) {
3923 sv = mul128(sv, *s & 0x7f);
3924 if (!(*s++ & 0x80)) {
3933 PUSHs(sv_2mortal(sv));
3938 if ((s >= strend) && bytes)
3939 croak("Unterminated compressed integer");
3944 if (sizeof(char*) > strend - s)
3947 Copy(s, &aptr, 1, char*);
3952 sv_setpvn(sv, aptr, len);
3953 PUSHs(sv_2mortal(sv));
3957 along = (strend - s) / sizeof(Quad_t);
3963 if (s + sizeof(Quad_t) > strend)
3966 Copy(s, &aquad, 1, Quad_t);
3967 s += sizeof(Quad_t);
3970 if (aquad >= IV_MIN && aquad <= IV_MAX)
3971 sv_setiv(sv, (IV)aquad);
3973 sv_setnv(sv, (double)aquad);
3974 PUSHs(sv_2mortal(sv));
3978 along = (strend - s) / sizeof(Quad_t);
3984 if (s + sizeof(Uquad_t) > strend)
3987 Copy(s, &auquad, 1, Uquad_t);
3988 s += sizeof(Uquad_t);
3991 if (auquad <= UV_MAX)
3992 sv_setuv(sv, (UV)auquad);
3994 sv_setnv(sv, (double)auquad);
3995 PUSHs(sv_2mortal(sv));
3999 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4002 along = (strend - s) / sizeof(float);
4007 Copy(s, &afloat, 1, float);
4016 Copy(s, &afloat, 1, float);
4019 sv_setnv(sv, (double)afloat);
4020 PUSHs(sv_2mortal(sv));
4026 along = (strend - s) / sizeof(double);
4031 Copy(s, &adouble, 1, double);
4032 s += sizeof(double);
4040 Copy(s, &adouble, 1, double);
4041 s += sizeof(double);
4043 sv_setnv(sv, (double)adouble);
4044 PUSHs(sv_2mortal(sv));
4050 * Initialise the decode mapping. By using a table driven
4051 * algorithm, the code will be character-set independent
4052 * (and just as fast as doing character arithmetic)
4054 if (PL_uudmap['M'] == 0) {
4057 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4058 PL_uudmap[PL_uuemap[i]] = i;
4060 * Because ' ' and '`' map to the same value,
4061 * we need to decode them both the same.
4066 along = (strend - s) * 3 / 4;
4067 sv = NEWSV(42, along);
4070 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4075 len = PL_uudmap[*s++] & 077;
4077 if (s < strend && ISUUCHAR(*s))
4078 a = PL_uudmap[*s++] & 077;
4081 if (s < strend && ISUUCHAR(*s))
4082 b = PL_uudmap[*s++] & 077;
4085 if (s < strend && ISUUCHAR(*s))
4086 c = PL_uudmap[*s++] & 077;
4089 if (s < strend && ISUUCHAR(*s))
4090 d = PL_uudmap[*s++] & 077;
4093 hunk[0] = (a << 2) | (b >> 4);
4094 hunk[1] = (b << 4) | (c >> 2);
4095 hunk[2] = (c << 6) | d;
4096 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4101 else if (s[1] == '\n') /* possible checksum byte */
4104 XPUSHs(sv_2mortal(sv));
4109 if (strchr("fFdD", datumtype) ||
4110 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4114 while (checksum >= 16) {
4118 while (checksum >= 4) {
4124 along = (1 << checksum) - 1;
4125 while (cdouble < 0.0)
4127 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4128 sv_setnv(sv, cdouble);
4131 if (checksum < 32) {
4132 aulong = (1 << checksum) - 1;
4135 sv_setuv(sv, (UV)culong);
4137 XPUSHs(sv_2mortal(sv));
4141 if (SP == oldsp && gimme == G_SCALAR)
4142 PUSHs(&PL_sv_undef);
4147 doencodes(register SV *sv, register char *s, register I32 len)
4151 *hunk = PL_uuemap[len];
4152 sv_catpvn(sv, hunk, 1);
4155 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4156 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4157 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4158 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4159 sv_catpvn(sv, hunk, 4);
4164 char r = (len > 1 ? s[1] : '\0');
4165 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4166 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4167 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4168 hunk[3] = PL_uuemap[0];
4169 sv_catpvn(sv, hunk, 4);
4171 sv_catpvn(sv, "\n", 1);
4175 is_an_int(char *s, STRLEN l)
4178 SV *result = newSVpv("", l);
4179 char *result_c = SvPV(result, n_a); /* convenience */
4180 char *out = result_c;
4190 SvREFCNT_dec(result);
4213 SvREFCNT_dec(result);
4219 SvCUR_set(result, out - result_c);
4224 div128(SV *pnum, bool *done)
4225 /* must be '\0' terminated */
4229 char *s = SvPV(pnum, len);
4238 i = m * 10 + (*t - '0');
4240 r = (i >> 7); /* r < 10 */
4247 SvCUR_set(pnum, (STRLEN) (t - s));
4254 djSP; dMARK; dORIGMARK; dTARGET;
4255 register SV *cat = TARG;
4258 register char *pat = SvPVx(*++MARK, fromlen);
4259 register char *patend = pat + fromlen;
4264 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4265 static char *space10 = " ";
4267 /* These must not be in registers: */
4282 #ifdef PERL_NATINT_PACK
4283 int natint; /* native integer */
4288 sv_setpvn(cat, "", 0);
4289 while (pat < patend) {
4290 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4291 datumtype = *pat++ & 0xFF;
4292 #ifdef PERL_NATINT_PACK
4295 if (isSPACE(datumtype))
4298 char *natstr = "sSiIlL";
4300 if (strchr(natstr, datumtype)) {
4301 #ifdef PERL_NATINT_PACK
4307 croak("'!' allowed only after types %s", natstr);
4310 len = strchr("@Xxu", datumtype) ? 0 : items;
4313 else if (isDIGIT(*pat)) {
4315 while (isDIGIT(*pat))
4316 len = (len * 10) + (*pat++ - '0');
4322 croak("Invalid type in pack: '%c'", (int)datumtype);
4323 case ',': /* grandfather in commas but with a warning */
4324 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4325 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4328 DIE("%% may only be used in unpack");
4339 if (SvCUR(cat) < len)
4340 DIE("X outside of string");
4347 sv_catpvn(cat, null10, 10);
4350 sv_catpvn(cat, null10, len);
4356 aptr = SvPV(fromstr, fromlen);
4360 sv_catpvn(cat, aptr, len);
4362 sv_catpvn(cat, aptr, fromlen);
4364 if (datumtype == 'A') {
4366 sv_catpvn(cat, space10, 10);
4369 sv_catpvn(cat, space10, len);
4373 sv_catpvn(cat, null10, 10);
4376 sv_catpvn(cat, null10, len);
4383 char *savepat = pat;
4388 aptr = SvPV(fromstr, fromlen);
4393 SvCUR(cat) += (len+7)/8;
4394 SvGROW(cat, SvCUR(cat) + 1);
4395 aptr = SvPVX(cat) + aint;
4400 if (datumtype == 'B') {
4401 for (len = 0; len++ < aint;) {
4402 items |= *pat++ & 1;
4406 *aptr++ = items & 0xff;
4412 for (len = 0; len++ < aint;) {
4418 *aptr++ = items & 0xff;
4424 if (datumtype == 'B')
4425 items <<= 7 - (aint & 7);
4427 items >>= 7 - (aint & 7);
4428 *aptr++ = items & 0xff;
4430 pat = SvPVX(cat) + SvCUR(cat);
4441 char *savepat = pat;
4446 aptr = SvPV(fromstr, fromlen);
4451 SvCUR(cat) += (len+1)/2;
4452 SvGROW(cat, SvCUR(cat) + 1);
4453 aptr = SvPVX(cat) + aint;
4458 if (datumtype == 'H') {
4459 for (len = 0; len++ < aint;) {
4461 items |= ((*pat++ & 15) + 9) & 15;
4463 items |= *pat++ & 15;
4467 *aptr++ = items & 0xff;
4473 for (len = 0; len++ < aint;) {
4475 items |= (((*pat++ & 15) + 9) & 15) << 4;
4477 items |= (*pat++ & 15) << 4;
4481 *aptr++ = items & 0xff;
4487 *aptr++ = items & 0xff;
4488 pat = SvPVX(cat) + SvCUR(cat);
4500 aint = SvIV(fromstr);
4502 sv_catpvn(cat, &achar, sizeof(char));
4508 auint = SvUV(fromstr);
4509 SvGROW(cat, SvCUR(cat) + 10);
4510 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4515 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4520 afloat = (float)SvNV(fromstr);
4521 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4528 adouble = (double)SvNV(fromstr);
4529 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4535 ashort = (I16)SvIV(fromstr);
4537 ashort = PerlSock_htons(ashort);
4539 CAT16(cat, &ashort);
4545 ashort = (I16)SvIV(fromstr);
4547 ashort = htovs(ashort);
4549 CAT16(cat, &ashort);
4553 #if SHORTSIZE != SIZE16
4555 unsigned short aushort;
4559 aushort = SvUV(fromstr);
4560 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4570 aushort = (U16)SvUV(fromstr);
4571 CAT16(cat, &aushort);
4577 #if SHORTSIZE != SIZE16
4581 ashort = SvIV(fromstr);
4582 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4590 ashort = (I16)SvIV(fromstr);
4591 CAT16(cat, &ashort);
4598 auint = SvUV(fromstr);
4599 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4605 adouble = floor(SvNV(fromstr));
4608 croak("Cannot compress negative numbers");
4614 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4615 adouble <= UV_MAX_cxux
4622 char buf[1 + sizeof(UV)];
4623 char *in = buf + sizeof(buf);
4624 UV auv = U_V(adouble);;
4627 *--in = (auv & 0x7f) | 0x80;
4630 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4631 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4633 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4634 char *from, *result, *in;
4639 /* Copy string and check for compliance */
4640 from = SvPV(fromstr, len);
4641 if ((norm = is_an_int(from, len)) == NULL)
4642 croak("can compress only unsigned integer");
4644 New('w', result, len, char);
4648 *--in = div128(norm, &done) | 0x80;
4649 result[len - 1] &= 0x7F; /* clear continue bit */
4650 sv_catpvn(cat, in, (result + len) - in);
4652 SvREFCNT_dec(norm); /* free norm */
4654 else if (SvNOKp(fromstr)) {
4655 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4656 char *in = buf + sizeof(buf);
4659 double next = floor(adouble / 128);
4660 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4661 if (--in < buf) /* this cannot happen ;-) */
4662 croak ("Cannot compress integer");
4664 } while (adouble > 0);
4665 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4666 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4669 croak("Cannot compress non integer");
4675 aint = SvIV(fromstr);
4676 sv_catpvn(cat, (char*)&aint, sizeof(int));
4682 aulong = SvUV(fromstr);
4684 aulong = PerlSock_htonl(aulong);
4686 CAT32(cat, &aulong);
4692 aulong = SvUV(fromstr);
4694 aulong = htovl(aulong);
4696 CAT32(cat, &aulong);
4700 #if LONGSIZE != SIZE32
4704 aulong = SvUV(fromstr);
4705 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4713 aulong = SvUV(fromstr);
4714 CAT32(cat, &aulong);
4719 #if LONGSIZE != SIZE32
4723 along = SvIV(fromstr);
4724 sv_catpvn(cat, (char *)&along, sizeof(long));
4732 along = SvIV(fromstr);
4741 auquad = (Uquad_t)SvIV(fromstr);
4742 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4748 aquad = (Quad_t)SvIV(fromstr);
4749 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4752 #endif /* HAS_QUAD */
4754 len = 1; /* assume SV is correct length */
4759 if (fromstr == &PL_sv_undef)
4763 /* XXX better yet, could spirit away the string to
4764 * a safe spot and hang on to it until the result
4765 * of pack() (and all copies of the result) are
4768 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4770 "Attempt to pack pointer to temporary value");
4771 if (SvPOK(fromstr) || SvNIOK(fromstr))
4772 aptr = SvPV(fromstr,n_a);
4774 aptr = SvPV_force(fromstr,n_a);
4776 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4781 aptr = SvPV(fromstr, fromlen);
4782 SvGROW(cat, fromlen * 4 / 3);
4787 while (fromlen > 0) {
4794 doencodes(cat, aptr, todo);
4813 register I32 limit = POPi; /* note, negative is forever */
4816 register char *s = SvPV(sv, len);
4817 char *strend = s + len;
4819 register REGEXP *rx;
4823 I32 maxiters = (strend - s) + 10;
4826 I32 origlimit = limit;
4829 AV *oldstack = PL_curstack;
4830 I32 gimme = GIMME_V;
4831 I32 oldsave = PL_savestack_ix;
4832 I32 make_mortal = 1;
4833 MAGIC *mg = (MAGIC *) NULL;
4836 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4841 DIE("panic: do_split");
4842 rx = pm->op_pmregexp;
4844 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4845 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4847 if (pm->op_pmreplroot)
4848 ary = GvAVn((GV*)pm->op_pmreplroot);
4849 else if (gimme != G_ARRAY)
4851 ary = (AV*)PL_curpad[0];
4853 ary = GvAVn(PL_defgv);
4854 #endif /* USE_THREADS */
4857 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4863 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4865 XPUSHs(SvTIED_obj((SV*)ary, mg));
4870 for (i = AvFILLp(ary); i >= 0; i--)
4871 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4873 /* temporarily switch stacks */
4874 SWITCHSTACK(PL_curstack, ary);
4878 base = SP - PL_stack_base;
4880 if (pm->op_pmflags & PMf_SKIPWHITE) {
4881 if (pm->op_pmflags & PMf_LOCALE) {
4882 while (isSPACE_LC(*s))
4890 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4891 SAVEINT(PL_multiline);
4892 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4896 limit = maxiters + 2;
4897 if (pm->op_pmflags & PMf_WHITE) {
4900 while (m < strend &&
4901 !((pm->op_pmflags & PMf_LOCALE)
4902 ? isSPACE_LC(*m) : isSPACE(*m)))
4907 dstr = NEWSV(30, m-s);
4908 sv_setpvn(dstr, s, m-s);
4914 while (s < strend &&
4915 ((pm->op_pmflags & PMf_LOCALE)
4916 ? isSPACE_LC(*s) : isSPACE(*s)))
4920 else if (strEQ("^", rx->precomp)) {
4923 for (m = s; m < strend && *m != '\n'; m++) ;
4927 dstr = NEWSV(30, m-s);
4928 sv_setpvn(dstr, s, m-s);
4935 else if (rx->check_substr && !rx->nparens
4936 && (rx->reganch & ROPT_CHECK_ALL)
4937 && !(rx->reganch & ROPT_ANCH)) {
4938 i = SvCUR(rx->check_substr);
4939 if (i == 1 && !SvTAIL(rx->check_substr)) {
4940 i = *SvPVX(rx->check_substr);
4943 for (m = s; m < strend && *m != i; m++) ;
4946 dstr = NEWSV(30, m-s);
4947 sv_setpvn(dstr, s, m-s);
4956 while (s < strend && --limit &&
4957 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4958 rx->check_substr, 0)) )
4961 dstr = NEWSV(31, m-s);
4962 sv_setpvn(dstr, s, m-s);
4971 maxiters += (strend - s) * rx->nparens;
4972 while (s < strend && --limit &&
4973 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4975 TAINT_IF(RX_MATCH_TAINTED(rx));
4977 && rx->subbase != orig) {
4982 strend = s + (strend - m);
4985 dstr = NEWSV(32, m-s);
4986 sv_setpvn(dstr, s, m-s);
4991 for (i = 1; i <= rx->nparens; i++) {
4995 dstr = NEWSV(33, m-s);
4996 sv_setpvn(dstr, s, m-s);
4999 dstr = NEWSV(33, 0);
5009 LEAVE_SCOPE(oldsave);
5010 iters = (SP - PL_stack_base) - base;
5011 if (iters > maxiters)
5014 /* keep field after final delim? */
5015 if (s < strend || (iters && origlimit)) {
5016 dstr = NEWSV(34, strend-s);
5017 sv_setpvn(dstr, s, strend-s);
5023 else if (!origlimit) {
5024 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5030 SWITCHSTACK(ary, oldstack);
5031 if (SvSMAGICAL(ary)) {
5036 if (gimme == G_ARRAY) {
5038 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5046 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5049 if (gimme == G_ARRAY) {
5050 /* EXTEND should not be needed - we just popped them */
5052 for (i=0; i < iters; i++) {
5053 SV **svp = av_fetch(ary, i, FALSE);
5054 PUSHs((svp) ? *svp : &PL_sv_undef);
5061 if (gimme == G_ARRAY)
5064 if (iters || !pm->op_pmreplroot) {
5074 unlock_condpair(void *svv)
5077 MAGIC *mg = mg_find((SV*)svv, 'm');
5080 croak("panic: unlock_condpair unlocking non-mutex");
5081 MUTEX_LOCK(MgMUTEXP(mg));
5082 if (MgOWNER(mg) != thr)
5083 croak("panic: unlock_condpair unlocking mutex that we don't own");
5085 COND_SIGNAL(MgOWNERCONDP(mg));
5086 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5087 (unsigned long)thr, (unsigned long)svv);)
5088 MUTEX_UNLOCK(MgMUTEXP(mg));
5090 #endif /* USE_THREADS */
5103 mg = condpair_magic(sv);
5104 MUTEX_LOCK(MgMUTEXP(mg));
5105 if (MgOWNER(mg) == thr)
5106 MUTEX_UNLOCK(MgMUTEXP(mg));
5109 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5111 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5112 (unsigned long)thr, (unsigned long)sv);)
5113 MUTEX_UNLOCK(MgMUTEXP(mg));
5114 save_destructor(unlock_condpair, sv);
5116 #endif /* USE_THREADS */
5117 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5118 || SvTYPE(retsv) == SVt_PVCV) {
5119 retsv = refto(retsv);
5130 if (PL_op->op_private & OPpLVAL_INTRO)
5131 PUSHs(*save_threadsv(PL_op->op_targ));
5133 PUSHs(THREADSV(PL_op->op_targ));
5136 DIE("tried to access per-thread data in non-threaded perl");
5137 #endif /* USE_THREADS */