3 * Copyright (c) 1991-1999, 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(newSVpvn(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(newSVpvn(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 = newSVpvn(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))
798 switch (SvTYPE(sv)) {
808 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
809 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
810 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
814 /* let user-undef'd sub keep its identity */
815 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
822 SvSetMagicSV(sv, &PL_sv_undef);
826 Newz(602, gp, 1, GP);
827 GvGP(sv) = gp_ref(gp);
828 GvSV(sv) = NEWSV(72,0);
829 GvLINE(sv) = PL_curcop->cop_line;
835 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
838 SvPV_set(sv, Nullch);
851 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
853 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
854 SvIVX(TOPs) != IV_MIN)
857 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
868 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
870 sv_setsv(TARG, TOPs);
871 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
872 SvIVX(TOPs) != IV_MAX)
875 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
889 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
891 sv_setsv(TARG, TOPs);
892 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
893 SvIVX(TOPs) != IV_MIN)
896 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
905 /* Ordinary operators. */
909 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
912 SETn( pow( left, right) );
919 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
922 SETn( left * right );
929 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
934 DIE("Illegal division by zero");
936 /* insure that 20./5. == 4. */
939 if ((double)I_V(left) == left &&
940 (double)I_V(right) == right &&
941 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
945 value = left / right;
949 value = left / right;
958 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
966 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
968 right = (right_neg = (i < 0)) ? -i : i;
972 right = U_V((right_neg = (n < 0)) ? -n : n);
975 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
977 left = (left_neg = (i < 0)) ? -i : i;
981 left = U_V((left_neg = (n < 0)) ? -n : n);
985 DIE("Illegal modulus zero");
988 if ((left_neg != right_neg) && ans)
991 /* XXX may warn: unary minus operator applied to unsigned type */
992 /* could change -foo to be (~foo)+1 instead */
993 if (ans <= ~((UV)IV_MAX)+1)
994 sv_setiv(TARG, ~ans+1);
996 sv_setnv(TARG, -(double)ans);
1007 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1009 register I32 count = POPi;
1010 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1012 I32 items = SP - MARK;
1015 max = items * count;
1024 repeatcpy((char*)(MARK + items), (char*)MARK,
1025 items * sizeof(SV*), count - 1);
1028 else if (count <= 0)
1031 else { /* Note: mark already snarfed by pp_list */
1036 SvSetSV(TARG, tmpstr);
1037 SvPV_force(TARG, len);
1042 SvGROW(TARG, (count * len) + 1);
1043 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1044 SvCUR(TARG) *= count;
1046 *SvEND(TARG) = '\0';
1048 (void)SvPOK_only(TARG);
1057 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1060 SETn( left - right );
1067 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1070 if (PL_op->op_private & HINT_INTEGER) {
1072 i = BWi(i) << shift;
1086 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1089 if (PL_op->op_private & HINT_INTEGER) {
1091 i = BWi(i) >> shift;
1105 djSP; tryAMAGICbinSET(lt,0);
1108 SETs(boolSV(TOPn < value));
1115 djSP; tryAMAGICbinSET(gt,0);
1118 SETs(boolSV(TOPn > value));
1125 djSP; tryAMAGICbinSET(le,0);
1128 SETs(boolSV(TOPn <= value));
1135 djSP; tryAMAGICbinSET(ge,0);
1138 SETs(boolSV(TOPn >= value));
1145 djSP; tryAMAGICbinSET(ne,0);
1148 SETs(boolSV(TOPn != value));
1155 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1162 else if (left < right)
1164 else if (left > right)
1177 djSP; tryAMAGICbinSET(slt,0);
1180 int cmp = ((PL_op->op_private & OPpLOCALE)
1181 ? sv_cmp_locale(left, right)
1182 : sv_cmp(left, right));
1183 SETs(boolSV(cmp < 0));
1190 djSP; tryAMAGICbinSET(sgt,0);
1193 int cmp = ((PL_op->op_private & OPpLOCALE)
1194 ? sv_cmp_locale(left, right)
1195 : sv_cmp(left, right));
1196 SETs(boolSV(cmp > 0));
1203 djSP; tryAMAGICbinSET(sle,0);
1206 int cmp = ((PL_op->op_private & OPpLOCALE)
1207 ? sv_cmp_locale(left, right)
1208 : sv_cmp(left, right));
1209 SETs(boolSV(cmp <= 0));
1216 djSP; tryAMAGICbinSET(sge,0);
1219 int cmp = ((PL_op->op_private & OPpLOCALE)
1220 ? sv_cmp_locale(left, right)
1221 : sv_cmp(left, right));
1222 SETs(boolSV(cmp >= 0));
1229 djSP; tryAMAGICbinSET(seq,0);
1232 SETs(boolSV(sv_eq(left, right)));
1239 djSP; tryAMAGICbinSET(sne,0);
1242 SETs(boolSV(!sv_eq(left, right)));
1249 djSP; dTARGET; tryAMAGICbin(scmp,0);
1252 int cmp = ((PL_op->op_private & OPpLOCALE)
1253 ? sv_cmp_locale(left, right)
1254 : sv_cmp(left, right));
1262 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1265 if (SvNIOKp(left) || SvNIOKp(right)) {
1266 if (PL_op->op_private & HINT_INTEGER) {
1267 IBW value = SvIV(left) & SvIV(right);
1271 UBW value = SvUV(left) & SvUV(right);
1276 do_vop(PL_op->op_type, TARG, left, right);
1285 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1288 if (SvNIOKp(left) || SvNIOKp(right)) {
1289 if (PL_op->op_private & HINT_INTEGER) {
1290 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1294 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1299 do_vop(PL_op->op_type, TARG, left, right);
1308 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1311 if (SvNIOKp(left) || SvNIOKp(right)) {
1312 if (PL_op->op_private & HINT_INTEGER) {
1313 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1317 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1322 do_vop(PL_op->op_type, TARG, left, right);
1331 djSP; dTARGET; tryAMAGICun(neg);
1336 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1338 else if (SvNIOKp(sv))
1340 else if (SvPOKp(sv)) {
1342 char *s = SvPV(sv, len);
1343 if (isIDFIRST(*s)) {
1344 sv_setpvn(TARG, "-", 1);
1347 else if (*s == '+' || *s == '-') {
1349 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1351 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1352 sv_setpvn(TARG, "-", 1);
1356 sv_setnv(TARG, -SvNV(sv));
1367 djSP; tryAMAGICunSET(not);
1368 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1374 djSP; dTARGET; tryAMAGICun(compl);
1378 if (PL_op->op_private & HINT_INTEGER) {
1379 IBW value = ~SvIV(sv);
1383 UBW value = ~SvUV(sv);
1388 register char *tmps;
1389 register long *tmpl;
1394 tmps = SvPV_force(TARG, len);
1397 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1400 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1404 for ( ; anum > 0; anum--, tmps++)
1413 /* integer versions of some of the above */
1417 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1420 SETi( left * right );
1427 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1431 DIE("Illegal division by zero");
1432 value = POPi / value;
1440 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1444 DIE("Illegal modulus zero");
1445 SETi( left % right );
1452 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1455 SETi( left + right );
1462 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1465 SETi( left - right );
1472 djSP; tryAMAGICbinSET(lt,0);
1475 SETs(boolSV(left < right));
1482 djSP; tryAMAGICbinSET(gt,0);
1485 SETs(boolSV(left > right));
1492 djSP; tryAMAGICbinSET(le,0);
1495 SETs(boolSV(left <= right));
1502 djSP; tryAMAGICbinSET(ge,0);
1505 SETs(boolSV(left >= right));
1512 djSP; tryAMAGICbinSET(eq,0);
1515 SETs(boolSV(left == right));
1522 djSP; tryAMAGICbinSET(ne,0);
1525 SETs(boolSV(left != right));
1532 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1539 else if (left < right)
1550 djSP; dTARGET; tryAMAGICun(neg);
1555 /* High falutin' math. */
1559 djSP; dTARGET; tryAMAGICbin(atan2,0);
1562 SETn(atan2(left, right));
1569 djSP; dTARGET; tryAMAGICun(sin);
1581 djSP; dTARGET; tryAMAGICun(cos);
1591 /* Support Configure command-line overrides for rand() functions.
1592 After 5.005, perhaps we should replace this by Configure support
1593 for drand48(), random(), or rand(). For 5.005, though, maintain
1594 compatibility by calling rand() but allow the user to override it.
1595 See INSTALL for details. --Andy Dougherty 15 July 1998
1597 /* Now it's after 5.005, and Configure supports drand48() and random(),
1598 in addition to rand(). So the overrides should not be needed any more.
1599 --Jarkko Hietaniemi 27 September 1998
1602 #ifndef HAS_DRAND48_PROTO
1603 extern double drand48 _((void));
1616 if (!PL_srand_called) {
1617 (void)seedDrand01((Rand_seed_t)seed());
1618 PL_srand_called = TRUE;
1633 (void)seedDrand01((Rand_seed_t)anum);
1634 PL_srand_called = TRUE;
1643 * This is really just a quick hack which grabs various garbage
1644 * values. It really should be a real hash algorithm which
1645 * spreads the effect of every input bit onto every output bit,
1646 * if someone who knows about such things would bother to write it.
1647 * Might be a good idea to add that function to CORE as well.
1648 * No numbers below come from careful analysis or anything here,
1649 * except they are primes and SEED_C1 > 1E6 to get a full-width
1650 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1651 * probably be bigger too.
1654 # define SEED_C1 1000003
1655 #define SEED_C4 73819
1657 # define SEED_C1 25747
1658 #define SEED_C4 20639
1662 #define SEED_C5 26107
1665 #ifndef PERL_NO_DEV_RANDOM
1670 # include <starlet.h>
1671 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1672 * in 100-ns units, typically incremented ever 10 ms. */
1673 unsigned int when[2];
1675 # ifdef HAS_GETTIMEOFDAY
1676 struct timeval when;
1682 /* This test is an escape hatch, this symbol isn't set by Configure. */
1683 #ifndef PERL_NO_DEV_RANDOM
1684 #ifndef PERL_RANDOM_DEVICE
1685 /* /dev/random isn't used by default because reads from it will block
1686 * if there isn't enough entropy available. You can compile with
1687 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1688 * is enough real entropy to fill the seed. */
1689 # define PERL_RANDOM_DEVICE "/dev/urandom"
1691 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1693 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1702 _ckvmssts(sys$gettim(when));
1703 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1705 # ifdef HAS_GETTIMEOFDAY
1706 gettimeofday(&when,(struct timezone *) 0);
1707 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1710 u = (U32)SEED_C1 * when;
1713 u += SEED_C3 * (U32)getpid();
1714 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1715 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1716 u += SEED_C5 * (U32)(UV)&when;
1723 djSP; dTARGET; tryAMAGICun(exp);
1735 djSP; dTARGET; tryAMAGICun(log);
1740 SET_NUMERIC_STANDARD();
1741 DIE("Can't take log of %g", value);
1751 djSP; dTARGET; tryAMAGICun(sqrt);
1756 SET_NUMERIC_STANDARD();
1757 DIE("Can't take sqrt of %g", value);
1759 value = sqrt(value);
1769 double value = TOPn;
1772 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1778 (void)modf(value, &value);
1780 (void)modf(-value, &value);
1795 djSP; dTARGET; tryAMAGICun(abs);
1797 double value = TOPn;
1800 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1801 (iv = SvIVX(TOPs)) != IV_MIN) {
1823 XPUSHu(scan_hex(tmps, 99, &argtype));
1836 while (*tmps && isSPACE(*tmps))
1841 value = scan_hex(++tmps, 99, &argtype);
1842 else if (*tmps == 'b')
1843 value = scan_bin(++tmps, 99, &argtype);
1845 value = scan_oct(tmps, 99, &argtype);
1857 SETi( sv_len_utf8(TOPs) );
1861 SETi( sv_len(TOPs) );
1875 I32 lvalue = PL_op->op_flags & OPf_MOD;
1877 I32 arybase = PL_curcop->cop_arybase;
1881 SvTAINTED_off(TARG); /* decontaminate */
1885 repl = SvPV(sv, repl_len);
1892 tmps = SvPV(sv, curlen);
1894 utfcurlen = sv_len_utf8(sv);
1895 if (utfcurlen == curlen)
1903 if (pos >= arybase) {
1921 else if (len >= 0) {
1923 if (rem > (I32)curlen)
1937 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1938 warner(WARN_SUBSTR, "substr outside of string");
1943 sv_pos_u2b(sv, &pos, &rem);
1945 sv_setpvn(TARG, tmps, rem);
1946 if (lvalue) { /* it's an lvalue! */
1947 if (!SvGMAGICAL(sv)) {
1951 if (ckWARN(WARN_SUBSTR))
1953 "Attempt to use reference as lvalue in substr");
1955 if (SvOK(sv)) /* is it defined ? */
1956 (void)SvPOK_only(sv);
1958 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1961 if (SvTYPE(TARG) < SVt_PVLV) {
1962 sv_upgrade(TARG, SVt_PVLV);
1963 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1967 if (LvTARG(TARG) != sv) {
1969 SvREFCNT_dec(LvTARG(TARG));
1970 LvTARG(TARG) = SvREFCNT_inc(sv);
1972 LvTARGOFF(TARG) = pos;
1973 LvTARGLEN(TARG) = rem;
1976 sv_insert(sv, pos, rem, repl, repl_len);
1979 PUSHs(TARG); /* avoid SvSETMAGIC here */
1986 register I32 size = POPi;
1987 register I32 offset = POPi;
1988 register SV *src = POPs;
1989 I32 lvalue = PL_op->op_flags & OPf_MOD;
1991 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1992 unsigned long retnum;
1995 SvTAINTED_off(TARG); /* decontaminate */
1996 offset *= size; /* turn into bit offset */
1997 len = (offset + size + 7) / 8;
1998 if (offset < 0 || size < 1)
2001 if (lvalue) { /* it's an lvalue! */
2002 if (SvTYPE(TARG) < SVt_PVLV) {
2003 sv_upgrade(TARG, SVt_PVLV);
2004 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2008 if (LvTARG(TARG) != src) {
2010 SvREFCNT_dec(LvTARG(TARG));
2011 LvTARG(TARG) = SvREFCNT_inc(src);
2013 LvTARGOFF(TARG) = offset;
2014 LvTARGLEN(TARG) = size;
2022 if (offset >= srclen)
2025 retnum = (unsigned long) s[offset] << 8;
2027 else if (size == 32) {
2028 if (offset >= srclen)
2030 else if (offset + 1 >= srclen)
2031 retnum = (unsigned long) s[offset] << 24;
2032 else if (offset + 2 >= srclen)
2033 retnum = ((unsigned long) s[offset] << 24) +
2034 ((unsigned long) s[offset + 1] << 16);
2036 retnum = ((unsigned long) s[offset] << 24) +
2037 ((unsigned long) s[offset + 1] << 16) +
2038 (s[offset + 2] << 8);
2043 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2048 else if (size == 16)
2049 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2050 else if (size == 32)
2051 retnum = ((unsigned long) s[offset] << 24) +
2052 ((unsigned long) s[offset + 1] << 16) +
2053 (s[offset + 2] << 8) + s[offset+3];
2057 sv_setuv(TARG, (UV)retnum);
2072 I32 arybase = PL_curcop->cop_arybase;
2077 offset = POPi - arybase;
2080 tmps = SvPV(big, biglen);
2081 if (IN_UTF8 && offset > 0)
2082 sv_pos_u2b(big, &offset, 0);
2085 else if (offset > biglen)
2087 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2088 (unsigned char*)tmps + biglen, little, 0)))
2091 retval = tmps2 - tmps;
2092 if (IN_UTF8 && retval > 0)
2093 sv_pos_b2u(big, &retval);
2094 PUSHi(retval + arybase);
2109 I32 arybase = PL_curcop->cop_arybase;
2115 tmps2 = SvPV(little, llen);
2116 tmps = SvPV(big, blen);
2120 if (IN_UTF8 && offset > 0)
2121 sv_pos_u2b(big, &offset, 0);
2122 offset = offset - arybase + llen;
2126 else if (offset > blen)
2128 if (!(tmps2 = rninstr(tmps, tmps + offset,
2129 tmps2, tmps2 + llen)))
2132 retval = tmps2 - tmps;
2133 if (IN_UTF8 && retval > 0)
2134 sv_pos_b2u(big, &retval);
2135 PUSHi(retval + arybase);
2141 djSP; dMARK; dORIGMARK; dTARGET;
2142 #ifdef USE_LOCALE_NUMERIC
2143 if (PL_op->op_private & OPpLOCALE)
2144 SET_NUMERIC_LOCAL();
2146 SET_NUMERIC_STANDARD();
2148 do_sprintf(TARG, SP-MARK, MARK+1);
2149 TAINT_IF(SvTAINTED(TARG));
2160 U8 *tmps = (U8*)POPpx;
2163 if (IN_UTF8 && (*tmps & 0x80))
2164 value = utf8_to_uv(tmps, &retlen);
2166 value = (UV)(*tmps & 255);
2177 (void)SvUPGRADE(TARG,SVt_PV);
2179 if (IN_UTF8 && value >= 128) {
2182 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2183 SvCUR_set(TARG, tmps - SvPVX(TARG));
2185 (void)SvPOK_only(TARG);
2195 (void)SvPOK_only(TARG);
2202 djSP; dTARGET; dPOPTOPssrl;
2205 char *tmps = SvPV(left, n_a);
2207 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2209 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2213 "The crypt() function is unimplemented due to excessive paranoia.");
2226 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2230 UV uv = utf8_to_uv(s, &ulen);
2232 if (PL_op->op_private & OPpLOCALE) {
2235 uv = toTITLE_LC_uni(uv);
2238 uv = toTITLE_utf8(s);
2240 tend = uv_to_utf8(tmpbuf, uv);
2242 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2244 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2245 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2249 s = (U8*)SvPV_force(sv, slen);
2250 Copy(tmpbuf, s, ulen, U8);
2255 if (!SvPADTMP(sv)) {
2261 s = (U8*)SvPV_force(sv, slen);
2263 if (PL_op->op_private & OPpLOCALE) {
2266 *s = toUPPER_LC(*s);
2282 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2286 UV uv = utf8_to_uv(s, &ulen);
2288 if (PL_op->op_private & OPpLOCALE) {
2291 uv = toLOWER_LC_uni(uv);
2294 uv = toLOWER_utf8(s);
2296 tend = uv_to_utf8(tmpbuf, uv);
2298 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2300 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2301 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2305 s = (U8*)SvPV_force(sv, slen);
2306 Copy(tmpbuf, s, ulen, U8);
2311 if (!SvPADTMP(sv)) {
2317 s = (U8*)SvPV_force(sv, slen);
2319 if (PL_op->op_private & OPpLOCALE) {
2322 *s = toLOWER_LC(*s);
2345 s = (U8*)SvPV(sv,len);
2347 sv_setpvn(TARG, "", 0);
2352 (void)SvUPGRADE(TARG, SVt_PV);
2353 SvGROW(TARG, (len * 2) + 1);
2354 (void)SvPOK_only(TARG);
2355 d = (U8*)SvPVX(TARG);
2357 if (PL_op->op_private & OPpLOCALE) {
2361 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2367 d = uv_to_utf8(d, toUPPER_utf8( s ));
2372 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2377 if (!SvPADTMP(sv)) {
2384 s = (U8*)SvPV_force(sv, len);
2386 register U8 *send = s + len;
2388 if (PL_op->op_private & OPpLOCALE) {
2391 for (; s < send; s++)
2392 *s = toUPPER_LC(*s);
2395 for (; s < send; s++)
2415 s = (U8*)SvPV(sv,len);
2417 sv_setpvn(TARG, "", 0);
2422 (void)SvUPGRADE(TARG, SVt_PV);
2423 SvGROW(TARG, (len * 2) + 1);
2424 (void)SvPOK_only(TARG);
2425 d = (U8*)SvPVX(TARG);
2427 if (PL_op->op_private & OPpLOCALE) {
2431 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2437 d = uv_to_utf8(d, toLOWER_utf8(s));
2442 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2447 if (!SvPADTMP(sv)) {
2454 s = (U8*)SvPV_force(sv, len);
2456 register U8 *send = s + len;
2458 if (PL_op->op_private & OPpLOCALE) {
2461 for (; s < send; s++)
2462 *s = toLOWER_LC(*s);
2465 for (; s < send; s++)
2477 register char *s = SvPV(sv,len);
2481 (void)SvUPGRADE(TARG, SVt_PV);
2482 SvGROW(TARG, (len * 2) + 1);
2487 STRLEN ulen = UTF8SKIP(s);
2510 SvCUR_set(TARG, d - SvPVX(TARG));
2511 (void)SvPOK_only(TARG);
2514 sv_setpvn(TARG, s, len);
2523 djSP; dMARK; dORIGMARK;
2525 register AV* av = (AV*)POPs;
2526 register I32 lval = PL_op->op_flags & OPf_MOD;
2527 I32 arybase = PL_curcop->cop_arybase;
2530 if (SvTYPE(av) == SVt_PVAV) {
2531 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2533 for (svp = MARK + 1; svp <= SP; svp++) {
2538 if (max > AvMAX(av))
2541 while (++MARK <= SP) {
2542 elem = SvIVx(*MARK);
2546 svp = av_fetch(av, elem, lval);
2548 if (!svp || *svp == &PL_sv_undef)
2549 DIE(PL_no_aelem, elem);
2550 if (PL_op->op_private & OPpLVAL_INTRO)
2551 save_aelem(av, elem, svp);
2553 *MARK = svp ? *svp : &PL_sv_undef;
2556 if (GIMME != G_ARRAY) {
2564 /* Associative arrays. */
2569 HV *hash = (HV*)POPs;
2571 I32 gimme = GIMME_V;
2572 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2575 /* might clobber stack_sp */
2576 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2581 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2582 if (gimme == G_ARRAY) {
2584 /* might clobber stack_sp */
2585 sv_setsv(TARG, realhv ?
2586 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2591 else if (gimme == G_SCALAR)
2610 I32 gimme = GIMME_V;
2611 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2615 if (PL_op->op_private & OPpSLICE) {
2619 hvtype = SvTYPE(hv);
2620 while (++MARK <= SP) {
2621 if (hvtype == SVt_PVHV)
2622 sv = hv_delete_ent(hv, *MARK, discard, 0);
2624 DIE("Not a HASH reference");
2625 *MARK = sv ? sv : &PL_sv_undef;
2629 else if (gimme == G_SCALAR) {
2638 if (SvTYPE(hv) == SVt_PVHV)
2639 sv = hv_delete_ent(hv, keysv, discard, 0);
2641 DIE("Not a HASH reference");
2655 if (SvTYPE(hv) == SVt_PVHV) {
2656 if (hv_exists_ent(hv, tmpsv, 0))
2659 else if (SvTYPE(hv) == SVt_PVAV) {
2660 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2664 DIE("Not a HASH reference");
2671 djSP; dMARK; dORIGMARK;
2672 register HV *hv = (HV*)POPs;
2673 register I32 lval = PL_op->op_flags & OPf_MOD;
2674 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2676 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2677 DIE("Can't localize pseudo-hash element");
2679 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2680 while (++MARK <= SP) {
2684 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2685 svp = he ? &HeVAL(he) : 0;
2688 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2691 if (!svp || *svp == &PL_sv_undef) {
2693 DIE(PL_no_helem, SvPV(keysv, n_a));
2695 if (PL_op->op_private & OPpLVAL_INTRO)
2696 save_helem(hv, keysv, svp);
2698 *MARK = svp ? *svp : &PL_sv_undef;
2701 if (GIMME != G_ARRAY) {
2709 /* List operators. */
2714 if (GIMME != G_ARRAY) {
2716 *MARK = *SP; /* unwanted list, return last item */
2718 *MARK = &PL_sv_undef;
2727 SV **lastrelem = PL_stack_sp;
2728 SV **lastlelem = PL_stack_base + POPMARK;
2729 SV **firstlelem = PL_stack_base + POPMARK + 1;
2730 register SV **firstrelem = lastlelem + 1;
2731 I32 arybase = PL_curcop->cop_arybase;
2732 I32 lval = PL_op->op_flags & OPf_MOD;
2733 I32 is_something_there = lval;
2735 register I32 max = lastrelem - lastlelem;
2736 register SV **lelem;
2739 if (GIMME != G_ARRAY) {
2740 ix = SvIVx(*lastlelem);
2745 if (ix < 0 || ix >= max)
2746 *firstlelem = &PL_sv_undef;
2748 *firstlelem = firstrelem[ix];
2754 SP = firstlelem - 1;
2758 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2763 *lelem = &PL_sv_undef;
2764 else if (!(*lelem = firstrelem[ix]))
2765 *lelem = &PL_sv_undef;
2769 if (ix >= max || !(*lelem = firstrelem[ix]))
2770 *lelem = &PL_sv_undef;
2772 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2773 is_something_there = TRUE;
2775 if (is_something_there)
2778 SP = firstlelem - 1;
2784 djSP; dMARK; dORIGMARK;
2785 I32 items = SP - MARK;
2786 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2787 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2794 djSP; dMARK; dORIGMARK;
2795 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2799 SV *val = NEWSV(46, 0);
2801 sv_setsv(val, *++MARK);
2802 else if (ckWARN(WARN_UNSAFE))
2803 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2804 (void)hv_store_ent(hv,key,val,0);
2813 djSP; dMARK; dORIGMARK;
2814 register AV *ary = (AV*)*++MARK;
2818 register I32 offset;
2819 register I32 length;
2826 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2827 *MARK-- = SvTIED_obj((SV*)ary, mg);
2831 perl_call_method("SPLICE",GIMME_V);
2840 offset = i = SvIVx(*MARK);
2842 offset += AvFILLp(ary) + 1;
2844 offset -= PL_curcop->cop_arybase;
2846 DIE(PL_no_aelem, i);
2848 length = SvIVx(*MARK++);
2850 length += AvFILLp(ary) - offset + 1;
2856 length = AvMAX(ary) + 1; /* close enough to infinity */
2860 length = AvMAX(ary) + 1;
2862 if (offset > AvFILLp(ary) + 1)
2863 offset = AvFILLp(ary) + 1;
2864 after = AvFILLp(ary) + 1 - (offset + length);
2865 if (after < 0) { /* not that much array */
2866 length += after; /* offset+length now in array */
2872 /* At this point, MARK .. SP-1 is our new LIST */
2875 diff = newlen - length;
2876 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2879 if (diff < 0) { /* shrinking the area */
2881 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2882 Copy(MARK, tmparyval, newlen, SV*);
2885 MARK = ORIGMARK + 1;
2886 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2887 MEXTEND(MARK, length);
2888 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2890 EXTEND_MORTAL(length);
2891 for (i = length, dst = MARK; i; i--) {
2892 sv_2mortal(*dst); /* free them eventualy */
2899 *MARK = AvARRAY(ary)[offset+length-1];
2902 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2903 SvREFCNT_dec(*dst++); /* free them now */
2906 AvFILLp(ary) += diff;
2908 /* pull up or down? */
2910 if (offset < after) { /* easier to pull up */
2911 if (offset) { /* esp. if nothing to pull */
2912 src = &AvARRAY(ary)[offset-1];
2913 dst = src - diff; /* diff is negative */
2914 for (i = offset; i > 0; i--) /* can't trust Copy */
2918 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2922 if (after) { /* anything to pull down? */
2923 src = AvARRAY(ary) + offset + length;
2924 dst = src + diff; /* diff is negative */
2925 Move(src, dst, after, SV*);
2927 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2928 /* avoid later double free */
2932 dst[--i] = &PL_sv_undef;
2935 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2937 *dst = NEWSV(46, 0);
2938 sv_setsv(*dst++, *src++);
2940 Safefree(tmparyval);
2943 else { /* no, expanding (or same) */
2945 New(452, tmparyval, length, SV*); /* so remember deletion */
2946 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2949 if (diff > 0) { /* expanding */
2951 /* push up or down? */
2953 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2957 Move(src, dst, offset, SV*);
2959 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2961 AvFILLp(ary) += diff;
2964 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2965 av_extend(ary, AvFILLp(ary) + diff);
2966 AvFILLp(ary) += diff;
2969 dst = AvARRAY(ary) + AvFILLp(ary);
2971 for (i = after; i; i--) {
2978 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2979 *dst = NEWSV(46, 0);
2980 sv_setsv(*dst++, *src++);
2982 MARK = ORIGMARK + 1;
2983 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2985 Copy(tmparyval, MARK, length, SV*);
2987 EXTEND_MORTAL(length);
2988 for (i = length, dst = MARK; i; i--) {
2989 sv_2mortal(*dst); /* free them eventualy */
2993 Safefree(tmparyval);
2997 else if (length--) {
2998 *MARK = tmparyval[length];
3001 while (length-- > 0)
3002 SvREFCNT_dec(tmparyval[length]);
3004 Safefree(tmparyval);
3007 *MARK = &PL_sv_undef;
3015 djSP; dMARK; dORIGMARK; dTARGET;
3016 register AV *ary = (AV*)*++MARK;
3017 register SV *sv = &PL_sv_undef;
3020 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3021 *MARK-- = SvTIED_obj((SV*)ary, mg);
3025 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3030 /* Why no pre-extend of ary here ? */
3031 for (++MARK; MARK <= SP; MARK++) {
3034 sv_setsv(sv, *MARK);
3039 PUSHi( AvFILL(ary) + 1 );
3047 SV *sv = av_pop(av);
3049 (void)sv_2mortal(sv);
3058 SV *sv = av_shift(av);
3063 (void)sv_2mortal(sv);
3070 djSP; dMARK; dORIGMARK; dTARGET;
3071 register AV *ary = (AV*)*++MARK;
3076 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3077 *MARK-- = SvTIED_obj((SV*)ary, mg);
3081 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3086 av_unshift(ary, SP - MARK);
3089 sv_setsv(sv, *++MARK);
3090 (void)av_store(ary, i++, sv);
3094 PUSHi( AvFILL(ary) + 1 );
3104 if (GIMME == G_ARRAY) {
3115 register char *down;
3121 do_join(TARG, &PL_sv_no, MARK, SP);
3123 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3124 up = SvPV_force(TARG, len);
3126 if (IN_UTF8) { /* first reverse each character */
3127 U8* s = (U8*)SvPVX(TARG);
3128 U8* send = (U8*)(s + len);
3137 down = (char*)(s - 1);
3138 if (s > send || !((*down & 0xc0) == 0x80)) {
3139 warn("Malformed UTF-8 character");
3151 down = SvPVX(TARG) + len - 1;
3157 (void)SvPOK_only(TARG);
3166 mul128(SV *sv, U8 m)
3169 char *s = SvPV(sv, len);
3173 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3174 SV *tmpNew = newSVpvn("0000000000", 10);
3176 sv_catsv(tmpNew, sv);
3177 SvREFCNT_dec(sv); /* free old sv */
3182 while (!*t) /* trailing '\0'? */
3185 i = ((*t - '0') << 7) + m;
3186 *(t--) = '0' + (i % 10);
3192 /* Explosives and implosives. */
3194 #if 'I' == 73 && 'J' == 74
3195 /* On an ASCII/ISO kind of system */
3196 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3199 Some other sort of character set - use memchr() so we don't match
3202 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3210 I32 gimme = GIMME_V;
3214 register char *pat = SvPV(left, llen);
3215 register char *s = SvPV(right, rlen);
3216 char *strend = s + rlen;
3218 register char *patend = pat + llen;
3223 /* These must not be in registers: */
3240 register U32 culong;
3243 #ifdef PERL_NATINT_PACK
3244 int natint; /* native integer */
3245 int unatint; /* unsigned native integer */
3248 if (gimme != G_ARRAY) { /* arrange to do first one only */
3250 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3251 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3253 while (isDIGIT(*patend) || *patend == '*')
3259 while (pat < patend) {
3261 datumtype = *pat++ & 0xFF;
3262 #ifdef PERL_NATINT_PACK
3265 if (isSPACE(datumtype))
3268 char *natstr = "sSiIlL";
3270 if (strchr(natstr, datumtype)) {
3271 #ifdef PERL_NATINT_PACK
3277 croak("'!' allowed only after types %s", natstr);
3281 else if (*pat == '*') {
3282 len = strend - strbeg; /* long enough */
3285 else if (isDIGIT(*pat)) {
3287 while (isDIGIT(*pat))
3288 len = (len * 10) + (*pat++ - '0');
3291 len = (datumtype != '@');
3294 croak("Invalid type in unpack: '%c'", (int)datumtype);
3295 case ',': /* grandfather in commas but with a warning */
3296 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3297 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3300 if (len == 1 && pat[-1] != '1')
3309 if (len > strend - strbeg)
3310 DIE("@ outside of string");
3314 if (len > s - strbeg)
3315 DIE("X outside of string");
3319 if (len > strend - s)
3320 DIE("x outside of string");
3326 if (len > strend - s)
3329 goto uchar_checksum;
3330 sv = NEWSV(35, len);
3331 sv_setpvn(sv, s, len);
3333 if (datumtype == 'A' || datumtype == 'Z') {
3334 aptr = s; /* borrow register */
3335 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3340 else { /* 'A' strips both nulls and spaces */
3341 s = SvPVX(sv) + len - 1;
3342 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3346 SvCUR_set(sv, s - SvPVX(sv));
3347 s = aptr; /* unborrow register */
3349 XPUSHs(sv_2mortal(sv));
3353 if (pat[-1] == '*' || len > (strend - s) * 8)
3354 len = (strend - s) * 8;
3357 Newz(601, PL_bitcount, 256, char);
3358 for (bits = 1; bits < 256; bits++) {
3359 if (bits & 1) PL_bitcount[bits]++;
3360 if (bits & 2) PL_bitcount[bits]++;
3361 if (bits & 4) PL_bitcount[bits]++;
3362 if (bits & 8) PL_bitcount[bits]++;
3363 if (bits & 16) PL_bitcount[bits]++;
3364 if (bits & 32) PL_bitcount[bits]++;
3365 if (bits & 64) PL_bitcount[bits]++;
3366 if (bits & 128) PL_bitcount[bits]++;
3370 culong += PL_bitcount[*(unsigned char*)s++];
3375 if (datumtype == 'b') {
3377 if (bits & 1) culong++;
3383 if (bits & 128) culong++;
3390 sv = NEWSV(35, len + 1);
3393 aptr = pat; /* borrow register */
3395 if (datumtype == 'b') {
3397 for (len = 0; len < aint; len++) {
3398 if (len & 7) /*SUPPRESS 595*/
3402 *pat++ = '0' + (bits & 1);
3407 for (len = 0; len < aint; len++) {
3412 *pat++ = '0' + ((bits & 128) != 0);
3416 pat = aptr; /* unborrow register */
3417 XPUSHs(sv_2mortal(sv));
3421 if (pat[-1] == '*' || len > (strend - s) * 2)
3422 len = (strend - s) * 2;
3423 sv = NEWSV(35, len + 1);
3426 aptr = pat; /* borrow register */
3428 if (datumtype == 'h') {
3430 for (len = 0; len < aint; len++) {
3435 *pat++ = PL_hexdigit[bits & 15];
3440 for (len = 0; len < aint; len++) {
3445 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3449 pat = aptr; /* unborrow register */
3450 XPUSHs(sv_2mortal(sv));
3453 if (len > strend - s)
3458 if (aint >= 128) /* fake up signed chars */
3468 if (aint >= 128) /* fake up signed chars */
3471 sv_setiv(sv, (IV)aint);
3472 PUSHs(sv_2mortal(sv));
3477 if (len > strend - s)
3492 sv_setiv(sv, (IV)auint);
3493 PUSHs(sv_2mortal(sv));
3498 if (len > strend - s)
3501 while (len-- > 0 && s < strend) {
3502 auint = utf8_to_uv((U8*)s, &along);
3505 cdouble += (double)auint;
3513 while (len-- > 0 && s < strend) {
3514 auint = utf8_to_uv((U8*)s, &along);
3517 sv_setuv(sv, (UV)auint);
3518 PUSHs(sv_2mortal(sv));
3523 #if SHORTSIZE == SIZE16
3524 along = (strend - s) / SIZE16;
3526 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3531 #if SHORTSIZE != SIZE16
3534 COPYNN(s, &ashort, sizeof(short));
3545 #if SHORTSIZE > SIZE16
3557 #if SHORTSIZE != SIZE16
3560 COPYNN(s, &ashort, sizeof(short));
3563 sv_setiv(sv, (IV)ashort);
3564 PUSHs(sv_2mortal(sv));
3572 #if SHORTSIZE > SIZE16
3578 sv_setiv(sv, (IV)ashort);
3579 PUSHs(sv_2mortal(sv));
3587 #if SHORTSIZE == SIZE16
3588 along = (strend - s) / SIZE16;
3590 unatint = natint && datumtype == 'S';
3591 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3596 #if SHORTSIZE != SIZE16
3599 COPYNN(s, &aushort, sizeof(unsigned short));
3600 s += sizeof(unsigned short);
3608 COPY16(s, &aushort);
3611 if (datumtype == 'n')
3612 aushort = PerlSock_ntohs(aushort);
3615 if (datumtype == 'v')
3616 aushort = vtohs(aushort);
3625 #if SHORTSIZE != SIZE16
3628 COPYNN(s, &aushort, sizeof(unsigned short));
3629 s += sizeof(unsigned short);
3631 sv_setiv(sv, (UV)aushort);
3632 PUSHs(sv_2mortal(sv));
3639 COPY16(s, &aushort);
3643 if (datumtype == 'n')
3644 aushort = PerlSock_ntohs(aushort);
3647 if (datumtype == 'v')
3648 aushort = vtohs(aushort);
3650 sv_setiv(sv, (UV)aushort);
3651 PUSHs(sv_2mortal(sv));
3657 along = (strend - s) / sizeof(int);
3662 Copy(s, &aint, 1, int);
3665 cdouble += (double)aint;
3674 Copy(s, &aint, 1, int);
3678 /* Without the dummy below unpack("i", pack("i",-1))
3679 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3680 * cc with optimization turned on */
3682 sv_setiv(sv, (IV)aint) :
3684 sv_setiv(sv, (IV)aint);
3685 PUSHs(sv_2mortal(sv));
3690 along = (strend - s) / sizeof(unsigned int);
3695 Copy(s, &auint, 1, unsigned int);
3696 s += sizeof(unsigned int);
3698 cdouble += (double)auint;
3707 Copy(s, &auint, 1, unsigned int);
3708 s += sizeof(unsigned int);
3711 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3712 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3713 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3714 * with optimization turned on.
3715 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3716 * does not have this problem even with -O4)
3719 sv_setuv(sv, (UV)auint) :
3721 sv_setuv(sv, (UV)auint);
3722 PUSHs(sv_2mortal(sv));
3727 #if LONGSIZE == SIZE32
3728 along = (strend - s) / SIZE32;
3730 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3735 #if LONGSIZE != SIZE32
3738 COPYNN(s, &along, sizeof(long));
3741 cdouble += (double)along;
3751 #if LONGSIZE > SIZE32
3752 if (along > 2147483647)
3753 along -= 4294967296;
3757 cdouble += (double)along;
3766 #if LONGSIZE != SIZE32
3769 COPYNN(s, &along, sizeof(long));
3772 sv_setiv(sv, (IV)along);
3773 PUSHs(sv_2mortal(sv));
3781 #if LONGSIZE > SIZE32
3782 if (along > 2147483647)
3783 along -= 4294967296;
3787 sv_setiv(sv, (IV)along);
3788 PUSHs(sv_2mortal(sv));
3796 #if LONGSIZE == SIZE32
3797 along = (strend - s) / SIZE32;
3799 unatint = natint && datumtype == 'L';
3800 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3805 #if LONGSIZE != SIZE32
3808 COPYNN(s, &aulong, sizeof(unsigned long));
3809 s += sizeof(unsigned long);
3811 cdouble += (double)aulong;
3823 if (datumtype == 'N')
3824 aulong = PerlSock_ntohl(aulong);
3827 if (datumtype == 'V')
3828 aulong = vtohl(aulong);
3831 cdouble += (double)aulong;
3840 #if LONGSIZE != SIZE32
3843 COPYNN(s, &aulong, sizeof(unsigned long));
3844 s += sizeof(unsigned long);
3846 sv_setuv(sv, (UV)aulong);
3847 PUSHs(sv_2mortal(sv));
3857 if (datumtype == 'N')
3858 aulong = PerlSock_ntohl(aulong);
3861 if (datumtype == 'V')
3862 aulong = vtohl(aulong);
3865 sv_setuv(sv, (UV)aulong);
3866 PUSHs(sv_2mortal(sv));
3872 along = (strend - s) / sizeof(char*);
3878 if (sizeof(char*) > strend - s)
3881 Copy(s, &aptr, 1, char*);
3887 PUSHs(sv_2mortal(sv));
3897 while ((len > 0) && (s < strend)) {
3898 auv = (auv << 7) | (*s & 0x7f);
3899 if (!(*s++ & 0x80)) {
3903 PUSHs(sv_2mortal(sv));
3907 else if (++bytes >= sizeof(UV)) { /* promote to string */
3911 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3912 while (s < strend) {
3913 sv = mul128(sv, *s & 0x7f);
3914 if (!(*s++ & 0x80)) {
3923 PUSHs(sv_2mortal(sv));
3928 if ((s >= strend) && bytes)
3929 croak("Unterminated compressed integer");
3934 if (sizeof(char*) > strend - s)
3937 Copy(s, &aptr, 1, char*);
3942 sv_setpvn(sv, aptr, len);
3943 PUSHs(sv_2mortal(sv));
3947 along = (strend - s) / sizeof(Quad_t);
3953 if (s + sizeof(Quad_t) > strend)
3956 Copy(s, &aquad, 1, Quad_t);
3957 s += sizeof(Quad_t);
3960 if (aquad >= IV_MIN && aquad <= IV_MAX)
3961 sv_setiv(sv, (IV)aquad);
3963 sv_setnv(sv, (double)aquad);
3964 PUSHs(sv_2mortal(sv));
3968 along = (strend - s) / sizeof(Quad_t);
3974 if (s + sizeof(Uquad_t) > strend)
3977 Copy(s, &auquad, 1, Uquad_t);
3978 s += sizeof(Uquad_t);
3981 if (auquad <= UV_MAX)
3982 sv_setuv(sv, (UV)auquad);
3984 sv_setnv(sv, (double)auquad);
3985 PUSHs(sv_2mortal(sv));
3989 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3992 along = (strend - s) / sizeof(float);
3997 Copy(s, &afloat, 1, float);
4006 Copy(s, &afloat, 1, float);
4009 sv_setnv(sv, (double)afloat);
4010 PUSHs(sv_2mortal(sv));
4016 along = (strend - s) / sizeof(double);
4021 Copy(s, &adouble, 1, double);
4022 s += sizeof(double);
4030 Copy(s, &adouble, 1, double);
4031 s += sizeof(double);
4033 sv_setnv(sv, (double)adouble);
4034 PUSHs(sv_2mortal(sv));
4040 * Initialise the decode mapping. By using a table driven
4041 * algorithm, the code will be character-set independent
4042 * (and just as fast as doing character arithmetic)
4044 if (PL_uudmap['M'] == 0) {
4047 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4048 PL_uudmap[PL_uuemap[i]] = i;
4050 * Because ' ' and '`' map to the same value,
4051 * we need to decode them both the same.
4056 along = (strend - s) * 3 / 4;
4057 sv = NEWSV(42, along);
4060 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4065 len = PL_uudmap[*s++] & 077;
4067 if (s < strend && ISUUCHAR(*s))
4068 a = PL_uudmap[*s++] & 077;
4071 if (s < strend && ISUUCHAR(*s))
4072 b = PL_uudmap[*s++] & 077;
4075 if (s < strend && ISUUCHAR(*s))
4076 c = PL_uudmap[*s++] & 077;
4079 if (s < strend && ISUUCHAR(*s))
4080 d = PL_uudmap[*s++] & 077;
4083 hunk[0] = (a << 2) | (b >> 4);
4084 hunk[1] = (b << 4) | (c >> 2);
4085 hunk[2] = (c << 6) | d;
4086 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4091 else if (s[1] == '\n') /* possible checksum byte */
4094 XPUSHs(sv_2mortal(sv));
4099 if (strchr("fFdD", datumtype) ||
4100 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4104 while (checksum >= 16) {
4108 while (checksum >= 4) {
4114 along = (1 << checksum) - 1;
4115 while (cdouble < 0.0)
4117 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4118 sv_setnv(sv, cdouble);
4121 if (checksum < 32) {
4122 aulong = (1 << checksum) - 1;
4125 sv_setuv(sv, (UV)culong);
4127 XPUSHs(sv_2mortal(sv));
4131 if (SP == oldsp && gimme == G_SCALAR)
4132 PUSHs(&PL_sv_undef);
4137 doencodes(register SV *sv, register char *s, register I32 len)
4141 *hunk = PL_uuemap[len];
4142 sv_catpvn(sv, hunk, 1);
4145 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4146 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4147 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4148 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4149 sv_catpvn(sv, hunk, 4);
4154 char r = (len > 1 ? s[1] : '\0');
4155 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4156 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4157 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4158 hunk[3] = PL_uuemap[0];
4159 sv_catpvn(sv, hunk, 4);
4161 sv_catpvn(sv, "\n", 1);
4165 is_an_int(char *s, STRLEN l)
4168 SV *result = newSVpvn(s, l);
4169 char *result_c = SvPV(result, n_a); /* convenience */
4170 char *out = result_c;
4180 SvREFCNT_dec(result);
4203 SvREFCNT_dec(result);
4209 SvCUR_set(result, out - result_c);
4214 div128(SV *pnum, bool *done)
4215 /* must be '\0' terminated */
4219 char *s = SvPV(pnum, len);
4228 i = m * 10 + (*t - '0');
4230 r = (i >> 7); /* r < 10 */
4237 SvCUR_set(pnum, (STRLEN) (t - s));
4244 djSP; dMARK; dORIGMARK; dTARGET;
4245 register SV *cat = TARG;
4248 register char *pat = SvPVx(*++MARK, fromlen);
4249 register char *patend = pat + fromlen;
4254 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4255 static char *space10 = " ";
4257 /* These must not be in registers: */
4272 #ifdef PERL_NATINT_PACK
4273 int natint; /* native integer */
4278 sv_setpvn(cat, "", 0);
4279 while (pat < patend) {
4280 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4281 datumtype = *pat++ & 0xFF;
4282 #ifdef PERL_NATINT_PACK
4285 if (isSPACE(datumtype))
4288 char *natstr = "sSiIlL";
4290 if (strchr(natstr, datumtype)) {
4291 #ifdef PERL_NATINT_PACK
4297 croak("'!' allowed only after types %s", natstr);
4300 len = strchr("@Xxu", datumtype) ? 0 : items;
4303 else if (isDIGIT(*pat)) {
4305 while (isDIGIT(*pat))
4306 len = (len * 10) + (*pat++ - '0');
4312 croak("Invalid type in pack: '%c'", (int)datumtype);
4313 case ',': /* grandfather in commas but with a warning */
4314 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4315 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4318 DIE("%% may only be used in unpack");
4329 if (SvCUR(cat) < len)
4330 DIE("X outside of string");
4337 sv_catpvn(cat, null10, 10);
4340 sv_catpvn(cat, null10, len);
4346 aptr = SvPV(fromstr, fromlen);
4350 sv_catpvn(cat, aptr, len);
4352 sv_catpvn(cat, aptr, fromlen);
4354 if (datumtype == 'A') {
4356 sv_catpvn(cat, space10, 10);
4359 sv_catpvn(cat, space10, len);
4363 sv_catpvn(cat, null10, 10);
4366 sv_catpvn(cat, null10, len);
4373 char *savepat = pat;
4378 aptr = SvPV(fromstr, fromlen);
4383 SvCUR(cat) += (len+7)/8;
4384 SvGROW(cat, SvCUR(cat) + 1);
4385 aptr = SvPVX(cat) + aint;
4390 if (datumtype == 'B') {
4391 for (len = 0; len++ < aint;) {
4392 items |= *pat++ & 1;
4396 *aptr++ = items & 0xff;
4402 for (len = 0; len++ < aint;) {
4408 *aptr++ = items & 0xff;
4414 if (datumtype == 'B')
4415 items <<= 7 - (aint & 7);
4417 items >>= 7 - (aint & 7);
4418 *aptr++ = items & 0xff;
4420 pat = SvPVX(cat) + SvCUR(cat);
4431 char *savepat = pat;
4436 aptr = SvPV(fromstr, fromlen);
4441 SvCUR(cat) += (len+1)/2;
4442 SvGROW(cat, SvCUR(cat) + 1);
4443 aptr = SvPVX(cat) + aint;
4448 if (datumtype == 'H') {
4449 for (len = 0; len++ < aint;) {
4451 items |= ((*pat++ & 15) + 9) & 15;
4453 items |= *pat++ & 15;
4457 *aptr++ = items & 0xff;
4463 for (len = 0; len++ < aint;) {
4465 items |= (((*pat++ & 15) + 9) & 15) << 4;
4467 items |= (*pat++ & 15) << 4;
4471 *aptr++ = items & 0xff;
4477 *aptr++ = items & 0xff;
4478 pat = SvPVX(cat) + SvCUR(cat);
4490 aint = SvIV(fromstr);
4492 sv_catpvn(cat, &achar, sizeof(char));
4498 auint = SvUV(fromstr);
4499 SvGROW(cat, SvCUR(cat) + 10);
4500 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4505 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4510 afloat = (float)SvNV(fromstr);
4511 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4518 adouble = (double)SvNV(fromstr);
4519 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4525 ashort = (I16)SvIV(fromstr);
4527 ashort = PerlSock_htons(ashort);
4529 CAT16(cat, &ashort);
4535 ashort = (I16)SvIV(fromstr);
4537 ashort = htovs(ashort);
4539 CAT16(cat, &ashort);
4543 #if SHORTSIZE != SIZE16
4545 unsigned short aushort;
4549 aushort = SvUV(fromstr);
4550 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4560 aushort = (U16)SvUV(fromstr);
4561 CAT16(cat, &aushort);
4567 #if SHORTSIZE != SIZE16
4571 ashort = SvIV(fromstr);
4572 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4580 ashort = (I16)SvIV(fromstr);
4581 CAT16(cat, &ashort);
4588 auint = SvUV(fromstr);
4589 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4595 adouble = floor(SvNV(fromstr));
4598 croak("Cannot compress negative numbers");
4604 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4605 adouble <= UV_MAX_cxux
4612 char buf[1 + sizeof(UV)];
4613 char *in = buf + sizeof(buf);
4614 UV auv = U_V(adouble);;
4617 *--in = (auv & 0x7f) | 0x80;
4620 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4621 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4623 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4624 char *from, *result, *in;
4629 /* Copy string and check for compliance */
4630 from = SvPV(fromstr, len);
4631 if ((norm = is_an_int(from, len)) == NULL)
4632 croak("can compress only unsigned integer");
4634 New('w', result, len, char);
4638 *--in = div128(norm, &done) | 0x80;
4639 result[len - 1] &= 0x7F; /* clear continue bit */
4640 sv_catpvn(cat, in, (result + len) - in);
4642 SvREFCNT_dec(norm); /* free norm */
4644 else if (SvNOKp(fromstr)) {
4645 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4646 char *in = buf + sizeof(buf);
4649 double next = floor(adouble / 128);
4650 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4651 if (--in < buf) /* this cannot happen ;-) */
4652 croak ("Cannot compress integer");
4654 } while (adouble > 0);
4655 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4656 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4659 croak("Cannot compress non integer");
4665 aint = SvIV(fromstr);
4666 sv_catpvn(cat, (char*)&aint, sizeof(int));
4672 aulong = SvUV(fromstr);
4674 aulong = PerlSock_htonl(aulong);
4676 CAT32(cat, &aulong);
4682 aulong = SvUV(fromstr);
4684 aulong = htovl(aulong);
4686 CAT32(cat, &aulong);
4690 #if LONGSIZE != SIZE32
4694 aulong = SvUV(fromstr);
4695 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4703 aulong = SvUV(fromstr);
4704 CAT32(cat, &aulong);
4709 #if LONGSIZE != SIZE32
4713 along = SvIV(fromstr);
4714 sv_catpvn(cat, (char *)&along, sizeof(long));
4722 along = SvIV(fromstr);
4731 auquad = (Uquad_t)SvIV(fromstr);
4732 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4738 aquad = (Quad_t)SvIV(fromstr);
4739 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4742 #endif /* HAS_QUAD */
4744 len = 1; /* assume SV is correct length */
4749 if (fromstr == &PL_sv_undef)
4753 /* XXX better yet, could spirit away the string to
4754 * a safe spot and hang on to it until the result
4755 * of pack() (and all copies of the result) are
4758 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4760 "Attempt to pack pointer to temporary value");
4761 if (SvPOK(fromstr) || SvNIOK(fromstr))
4762 aptr = SvPV(fromstr,n_a);
4764 aptr = SvPV_force(fromstr,n_a);
4766 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4771 aptr = SvPV(fromstr, fromlen);
4772 SvGROW(cat, fromlen * 4 / 3);
4777 while (fromlen > 0) {
4784 doencodes(cat, aptr, todo);
4803 register I32 limit = POPi; /* note, negative is forever */
4806 register char *s = SvPV(sv, len);
4807 char *strend = s + len;
4809 register REGEXP *rx;
4813 I32 maxiters = (strend - s) + 10;
4816 I32 origlimit = limit;
4819 AV *oldstack = PL_curstack;
4820 I32 gimme = GIMME_V;
4821 I32 oldsave = PL_savestack_ix;
4822 I32 make_mortal = 1;
4823 MAGIC *mg = (MAGIC *) NULL;
4826 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4831 DIE("panic: do_split");
4832 rx = pm->op_pmregexp;
4834 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4835 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4837 if (pm->op_pmreplroot)
4838 ary = GvAVn((GV*)pm->op_pmreplroot);
4839 else if (gimme != G_ARRAY)
4841 ary = (AV*)PL_curpad[0];
4843 ary = GvAVn(PL_defgv);
4844 #endif /* USE_THREADS */
4847 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4853 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4855 XPUSHs(SvTIED_obj((SV*)ary, mg));
4860 for (i = AvFILLp(ary); i >= 0; i--)
4861 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4863 /* temporarily switch stacks */
4864 SWITCHSTACK(PL_curstack, ary);
4868 base = SP - PL_stack_base;
4870 if (pm->op_pmflags & PMf_SKIPWHITE) {
4871 if (pm->op_pmflags & PMf_LOCALE) {
4872 while (isSPACE_LC(*s))
4880 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4881 SAVEINT(PL_multiline);
4882 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4886 limit = maxiters + 2;
4887 if (pm->op_pmflags & PMf_WHITE) {
4890 while (m < strend &&
4891 !((pm->op_pmflags & PMf_LOCALE)
4892 ? isSPACE_LC(*m) : isSPACE(*m)))
4897 dstr = NEWSV(30, m-s);
4898 sv_setpvn(dstr, s, m-s);
4904 while (s < strend &&
4905 ((pm->op_pmflags & PMf_LOCALE)
4906 ? isSPACE_LC(*s) : isSPACE(*s)))
4910 else if (strEQ("^", rx->precomp)) {
4913 for (m = s; m < strend && *m != '\n'; m++) ;
4917 dstr = NEWSV(30, m-s);
4918 sv_setpvn(dstr, s, m-s);
4925 else if (rx->check_substr && !rx->nparens
4926 && (rx->reganch & ROPT_CHECK_ALL)
4927 && !(rx->reganch & ROPT_ANCH)) {
4928 i = SvCUR(rx->check_substr);
4929 if (i == 1 && !SvTAIL(rx->check_substr)) {
4930 i = *SvPVX(rx->check_substr);
4933 for (m = s; m < strend && *m != i; m++) ;
4936 dstr = NEWSV(30, m-s);
4937 sv_setpvn(dstr, s, m-s);
4946 while (s < strend && --limit &&
4947 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4948 rx->check_substr, 0)) )
4951 dstr = NEWSV(31, m-s);
4952 sv_setpvn(dstr, s, m-s);
4961 maxiters += (strend - s) * rx->nparens;
4962 while (s < strend && --limit &&
4963 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4965 TAINT_IF(RX_MATCH_TAINTED(rx));
4967 && rx->subbase != orig) {
4972 strend = s + (strend - m);
4975 dstr = NEWSV(32, m-s);
4976 sv_setpvn(dstr, s, m-s);
4981 for (i = 1; i <= rx->nparens; i++) {
4985 dstr = NEWSV(33, m-s);
4986 sv_setpvn(dstr, s, m-s);
4989 dstr = NEWSV(33, 0);
4999 LEAVE_SCOPE(oldsave);
5000 iters = (SP - PL_stack_base) - base;
5001 if (iters > maxiters)
5004 /* keep field after final delim? */
5005 if (s < strend || (iters && origlimit)) {
5006 dstr = NEWSV(34, strend-s);
5007 sv_setpvn(dstr, s, strend-s);
5013 else if (!origlimit) {
5014 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5020 SWITCHSTACK(ary, oldstack);
5021 if (SvSMAGICAL(ary)) {
5026 if (gimme == G_ARRAY) {
5028 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5036 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5039 if (gimme == G_ARRAY) {
5040 /* EXTEND should not be needed - we just popped them */
5042 for (i=0; i < iters; i++) {
5043 SV **svp = av_fetch(ary, i, FALSE);
5044 PUSHs((svp) ? *svp : &PL_sv_undef);
5051 if (gimme == G_ARRAY)
5054 if (iters || !pm->op_pmreplroot) {
5064 unlock_condpair(void *svv)
5067 MAGIC *mg = mg_find((SV*)svv, 'm');
5070 croak("panic: unlock_condpair unlocking non-mutex");
5071 MUTEX_LOCK(MgMUTEXP(mg));
5072 if (MgOWNER(mg) != thr)
5073 croak("panic: unlock_condpair unlocking mutex that we don't own");
5075 COND_SIGNAL(MgOWNERCONDP(mg));
5076 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5077 (unsigned long)thr, (unsigned long)svv);)
5078 MUTEX_UNLOCK(MgMUTEXP(mg));
5080 #endif /* USE_THREADS */
5093 mg = condpair_magic(sv);
5094 MUTEX_LOCK(MgMUTEXP(mg));
5095 if (MgOWNER(mg) == thr)
5096 MUTEX_UNLOCK(MgMUTEXP(mg));
5099 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5101 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5102 (unsigned long)thr, (unsigned long)sv);)
5103 MUTEX_UNLOCK(MgMUTEXP(mg));
5104 save_destructor(unlock_condpair, sv);
5106 #endif /* USE_THREADS */
5107 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5108 || SvTYPE(retsv) == SVt_PVCV) {
5109 retsv = refto(retsv);
5120 if (PL_op->op_private & OPpLVAL_INTRO)
5121 PUSHs(*save_threadsv(PL_op->op_targ));
5123 PUSHs(THREADSV(PL_op->op_targ));
5126 DIE("tried to access per-thread data in non-threaded perl");
5127 #endif /* USE_THREADS */