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)))
518 else if (SvPADTMP(sv))
522 (void)SvREFCNT_inc(sv);
525 sv_upgrade(rv, SVt_RV);
539 if (sv && SvGMAGICAL(sv))
542 if (!sv || !SvROK(sv))
546 pv = sv_reftype(sv,TRUE);
547 PUSHp(pv, strlen(pv));
557 stash = PL_curcop->cop_stash;
561 char *ptr = SvPV(ssv,len);
562 if (ckWARN(WARN_UNSAFE) && len == 0)
564 "Explicit blessing to '' (assuming package main)");
565 stash = gv_stashpvn(ptr, len, TRUE);
568 (void)sv_bless(TOPs, stash);
582 elem = SvPV(sv, n_a);
586 switch (elem ? *elem : '\0')
589 if (strEQ(elem, "ARRAY"))
590 tmpRef = (SV*)GvAV(gv);
593 if (strEQ(elem, "CODE"))
594 tmpRef = (SV*)GvCVu(gv);
597 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
598 tmpRef = (SV*)GvIOp(gv);
601 if (strEQ(elem, "GLOB"))
605 if (strEQ(elem, "HASH"))
606 tmpRef = (SV*)GvHV(gv);
609 if (strEQ(elem, "IO"))
610 tmpRef = (SV*)GvIOp(gv);
613 if (strEQ(elem, "NAME"))
614 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
617 if (strEQ(elem, "PACKAGE"))
618 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
621 if (strEQ(elem, "SCALAR"))
635 /* Pattern matching */
640 register UNOP *unop = cUNOP;
641 register unsigned char *s;
644 register I32 *sfirst;
648 if (sv == PL_lastscream) {
654 SvSCREAM_off(PL_lastscream);
655 SvREFCNT_dec(PL_lastscream);
657 PL_lastscream = SvREFCNT_inc(sv);
660 s = (unsigned char*)(SvPV(sv, len));
664 if (pos > PL_maxscream) {
665 if (PL_maxscream < 0) {
666 PL_maxscream = pos + 80;
667 New(301, PL_screamfirst, 256, I32);
668 New(302, PL_screamnext, PL_maxscream, I32);
671 PL_maxscream = pos + pos / 4;
672 Renew(PL_screamnext, PL_maxscream, I32);
676 sfirst = PL_screamfirst;
677 snext = PL_screamnext;
679 if (!sfirst || !snext)
680 DIE("do_study: out of memory");
682 for (ch = 256; ch; --ch)
689 snext[pos] = sfirst[ch] - pos;
696 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
705 if (PL_op->op_flags & OPf_STACKED)
711 TARG = sv_newmortal();
716 /* Lvalue operators. */
728 djSP; dMARK; dTARGET;
738 SETi(do_chomp(TOPs));
744 djSP; dMARK; dTARGET;
745 register I32 count = 0;
748 count += do_chomp(POPs);
759 if (!sv || !SvANY(sv))
761 switch (SvTYPE(sv)) {
763 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
767 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
771 if (CvROOT(sv) || CvXSUB(sv))
788 if (!PL_op->op_private) {
797 if (SvTHINKFIRST(sv))
800 switch (SvTYPE(sv)) {
810 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
811 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
812 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
816 /* let user-undef'd sub keep its identity */
817 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
824 SvSetMagicSV(sv, &PL_sv_undef);
828 Newz(602, gp, 1, GP);
829 GvGP(sv) = gp_ref(gp);
830 GvSV(sv) = NEWSV(72,0);
831 GvLINE(sv) = PL_curcop->cop_line;
837 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
840 SvPV_set(sv, Nullch);
853 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
855 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
856 SvIVX(TOPs) != IV_MIN)
859 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
870 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
872 sv_setsv(TARG, TOPs);
873 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
874 SvIVX(TOPs) != IV_MAX)
877 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
891 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
893 sv_setsv(TARG, TOPs);
894 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
895 SvIVX(TOPs) != IV_MIN)
898 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
907 /* Ordinary operators. */
911 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
914 SETn( pow( left, right) );
921 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
924 SETn( left * right );
931 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
936 DIE("Illegal division by zero");
938 /* insure that 20./5. == 4. */
941 if ((double)I_V(left) == left &&
942 (double)I_V(right) == right &&
943 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
947 value = left / right;
951 value = left / right;
960 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
968 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
970 right = (right_neg = (i < 0)) ? -i : i;
974 right = U_V((right_neg = (n < 0)) ? -n : n);
977 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
979 left = (left_neg = (i < 0)) ? -i : i;
983 left = U_V((left_neg = (n < 0)) ? -n : n);
987 DIE("Illegal modulus zero");
990 if ((left_neg != right_neg) && ans)
993 /* XXX may warn: unary minus operator applied to unsigned type */
994 /* could change -foo to be (~foo)+1 instead */
995 if (ans <= ~((UV)IV_MAX)+1)
996 sv_setiv(TARG, ~ans+1);
998 sv_setnv(TARG, -(double)ans);
1001 sv_setuv(TARG, ans);
1009 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1011 register I32 count = POPi;
1012 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1014 I32 items = SP - MARK;
1017 max = items * count;
1026 repeatcpy((char*)(MARK + items), (char*)MARK,
1027 items * sizeof(SV*), count - 1);
1030 else if (count <= 0)
1033 else { /* Note: mark already snarfed by pp_list */
1038 SvSetSV(TARG, tmpstr);
1039 SvPV_force(TARG, len);
1044 SvGROW(TARG, (count * len) + 1);
1045 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1046 SvCUR(TARG) *= count;
1048 *SvEND(TARG) = '\0';
1050 (void)SvPOK_only(TARG);
1059 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1062 SETn( left - right );
1069 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1072 if (PL_op->op_private & HINT_INTEGER) {
1074 i = BWi(i) << shift;
1088 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1091 if (PL_op->op_private & HINT_INTEGER) {
1093 i = BWi(i) >> shift;
1107 djSP; tryAMAGICbinSET(lt,0);
1110 SETs(boolSV(TOPn < value));
1117 djSP; tryAMAGICbinSET(gt,0);
1120 SETs(boolSV(TOPn > value));
1127 djSP; tryAMAGICbinSET(le,0);
1130 SETs(boolSV(TOPn <= value));
1137 djSP; tryAMAGICbinSET(ge,0);
1140 SETs(boolSV(TOPn >= value));
1147 djSP; tryAMAGICbinSET(ne,0);
1150 SETs(boolSV(TOPn != value));
1157 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1164 else if (left < right)
1166 else if (left > right)
1179 djSP; tryAMAGICbinSET(slt,0);
1182 int cmp = ((PL_op->op_private & OPpLOCALE)
1183 ? sv_cmp_locale(left, right)
1184 : sv_cmp(left, right));
1185 SETs(boolSV(cmp < 0));
1192 djSP; tryAMAGICbinSET(sgt,0);
1195 int cmp = ((PL_op->op_private & OPpLOCALE)
1196 ? sv_cmp_locale(left, right)
1197 : sv_cmp(left, right));
1198 SETs(boolSV(cmp > 0));
1205 djSP; tryAMAGICbinSET(sle,0);
1208 int cmp = ((PL_op->op_private & OPpLOCALE)
1209 ? sv_cmp_locale(left, right)
1210 : sv_cmp(left, right));
1211 SETs(boolSV(cmp <= 0));
1218 djSP; tryAMAGICbinSET(sge,0);
1221 int cmp = ((PL_op->op_private & OPpLOCALE)
1222 ? sv_cmp_locale(left, right)
1223 : sv_cmp(left, right));
1224 SETs(boolSV(cmp >= 0));
1231 djSP; tryAMAGICbinSET(seq,0);
1234 SETs(boolSV(sv_eq(left, right)));
1241 djSP; tryAMAGICbinSET(sne,0);
1244 SETs(boolSV(!sv_eq(left, right)));
1251 djSP; dTARGET; tryAMAGICbin(scmp,0);
1254 int cmp = ((PL_op->op_private & OPpLOCALE)
1255 ? sv_cmp_locale(left, right)
1256 : sv_cmp(left, right));
1264 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1267 if (SvNIOKp(left) || SvNIOKp(right)) {
1268 if (PL_op->op_private & HINT_INTEGER) {
1269 IBW value = SvIV(left) & SvIV(right);
1273 UBW value = SvUV(left) & SvUV(right);
1278 do_vop(PL_op->op_type, TARG, left, right);
1287 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1290 if (SvNIOKp(left) || SvNIOKp(right)) {
1291 if (PL_op->op_private & HINT_INTEGER) {
1292 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1296 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1301 do_vop(PL_op->op_type, TARG, left, right);
1310 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1313 if (SvNIOKp(left) || SvNIOKp(right)) {
1314 if (PL_op->op_private & HINT_INTEGER) {
1315 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1319 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1324 do_vop(PL_op->op_type, TARG, left, right);
1333 djSP; dTARGET; tryAMAGICun(neg);
1338 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1340 else if (SvNIOKp(sv))
1342 else if (SvPOKp(sv)) {
1344 char *s = SvPV(sv, len);
1345 if (isIDFIRST(*s)) {
1346 sv_setpvn(TARG, "-", 1);
1349 else if (*s == '+' || *s == '-') {
1351 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1353 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1354 sv_setpvn(TARG, "-", 1);
1358 sv_setnv(TARG, -SvNV(sv));
1369 djSP; tryAMAGICunSET(not);
1370 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1376 djSP; dTARGET; tryAMAGICun(compl);
1380 if (PL_op->op_private & HINT_INTEGER) {
1381 IBW value = ~SvIV(sv);
1385 UBW value = ~SvUV(sv);
1390 register char *tmps;
1391 register long *tmpl;
1396 tmps = SvPV_force(TARG, len);
1399 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1402 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1406 for ( ; anum > 0; anum--, tmps++)
1415 /* integer versions of some of the above */
1419 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1422 SETi( left * right );
1429 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1433 DIE("Illegal division by zero");
1434 value = POPi / value;
1442 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1446 DIE("Illegal modulus zero");
1447 SETi( left % right );
1454 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1457 SETi( left + right );
1464 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1467 SETi( left - right );
1474 djSP; tryAMAGICbinSET(lt,0);
1477 SETs(boolSV(left < right));
1484 djSP; tryAMAGICbinSET(gt,0);
1487 SETs(boolSV(left > right));
1494 djSP; tryAMAGICbinSET(le,0);
1497 SETs(boolSV(left <= right));
1504 djSP; tryAMAGICbinSET(ge,0);
1507 SETs(boolSV(left >= right));
1514 djSP; tryAMAGICbinSET(eq,0);
1517 SETs(boolSV(left == right));
1524 djSP; tryAMAGICbinSET(ne,0);
1527 SETs(boolSV(left != right));
1534 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1541 else if (left < right)
1552 djSP; dTARGET; tryAMAGICun(neg);
1557 /* High falutin' math. */
1561 djSP; dTARGET; tryAMAGICbin(atan2,0);
1564 SETn(atan2(left, right));
1571 djSP; dTARGET; tryAMAGICun(sin);
1583 djSP; dTARGET; tryAMAGICun(cos);
1593 /* Support Configure command-line overrides for rand() functions.
1594 After 5.005, perhaps we should replace this by Configure support
1595 for drand48(), random(), or rand(). For 5.005, though, maintain
1596 compatibility by calling rand() but allow the user to override it.
1597 See INSTALL for details. --Andy Dougherty 15 July 1998
1599 /* Now it's after 5.005, and Configure supports drand48() and random(),
1600 in addition to rand(). So the overrides should not be needed any more.
1601 --Jarkko Hietaniemi 27 September 1998
1604 #ifndef HAS_DRAND48_PROTO
1605 extern double drand48 _((void));
1618 if (!PL_srand_called) {
1619 (void)seedDrand01((Rand_seed_t)seed());
1620 PL_srand_called = TRUE;
1635 (void)seedDrand01((Rand_seed_t)anum);
1636 PL_srand_called = TRUE;
1645 * This is really just a quick hack which grabs various garbage
1646 * values. It really should be a real hash algorithm which
1647 * spreads the effect of every input bit onto every output bit,
1648 * if someone who knows about such things would bother to write it.
1649 * Might be a good idea to add that function to CORE as well.
1650 * No numbers below come from careful analysis or anything here,
1651 * except they are primes and SEED_C1 > 1E6 to get a full-width
1652 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1653 * probably be bigger too.
1656 # define SEED_C1 1000003
1657 #define SEED_C4 73819
1659 # define SEED_C1 25747
1660 #define SEED_C4 20639
1664 #define SEED_C5 26107
1667 #ifndef PERL_NO_DEV_RANDOM
1672 # include <starlet.h>
1673 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1674 * in 100-ns units, typically incremented ever 10 ms. */
1675 unsigned int when[2];
1677 # ifdef HAS_GETTIMEOFDAY
1678 struct timeval when;
1684 /* This test is an escape hatch, this symbol isn't set by Configure. */
1685 #ifndef PERL_NO_DEV_RANDOM
1686 #ifndef PERL_RANDOM_DEVICE
1687 /* /dev/random isn't used by default because reads from it will block
1688 * if there isn't enough entropy available. You can compile with
1689 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1690 * is enough real entropy to fill the seed. */
1691 # define PERL_RANDOM_DEVICE "/dev/urandom"
1693 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1695 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1704 _ckvmssts(sys$gettim(when));
1705 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1707 # ifdef HAS_GETTIMEOFDAY
1708 gettimeofday(&when,(struct timezone *) 0);
1709 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1712 u = (U32)SEED_C1 * when;
1715 u += SEED_C3 * (U32)getpid();
1716 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1717 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1718 u += SEED_C5 * (U32)(UV)&when;
1725 djSP; dTARGET; tryAMAGICun(exp);
1737 djSP; dTARGET; tryAMAGICun(log);
1742 SET_NUMERIC_STANDARD();
1743 DIE("Can't take log of %g", value);
1753 djSP; dTARGET; tryAMAGICun(sqrt);
1758 SET_NUMERIC_STANDARD();
1759 DIE("Can't take sqrt of %g", value);
1761 value = sqrt(value);
1771 double value = TOPn;
1774 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1780 (void)modf(value, &value);
1782 (void)modf(-value, &value);
1797 djSP; dTARGET; tryAMAGICun(abs);
1799 double value = TOPn;
1802 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1803 (iv = SvIVX(TOPs)) != IV_MIN) {
1825 XPUSHu(scan_hex(tmps, 99, &argtype));
1838 while (*tmps && isSPACE(*tmps))
1843 value = scan_hex(++tmps, 99, &argtype);
1844 else if (*tmps == 'b')
1845 value = scan_bin(++tmps, 99, &argtype);
1847 value = scan_oct(tmps, 99, &argtype);
1859 SETi( sv_len_utf8(TOPs) );
1863 SETi( sv_len(TOPs) );
1877 I32 lvalue = PL_op->op_flags & OPf_MOD;
1879 I32 arybase = PL_curcop->cop_arybase;
1883 SvTAINTED_off(TARG); /* decontaminate */
1887 repl = SvPV(sv, repl_len);
1894 tmps = SvPV(sv, curlen);
1896 utfcurlen = sv_len_utf8(sv);
1897 if (utfcurlen == curlen)
1905 if (pos >= arybase) {
1923 else if (len >= 0) {
1925 if (rem > (I32)curlen)
1939 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1940 warner(WARN_SUBSTR, "substr outside of string");
1945 sv_pos_u2b(sv, &pos, &rem);
1947 sv_setpvn(TARG, tmps, rem);
1948 if (lvalue) { /* it's an lvalue! */
1949 if (!SvGMAGICAL(sv)) {
1953 if (ckWARN(WARN_SUBSTR))
1955 "Attempt to use reference as lvalue in substr");
1957 if (SvOK(sv)) /* is it defined ? */
1958 (void)SvPOK_only(sv);
1960 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1963 if (SvTYPE(TARG) < SVt_PVLV) {
1964 sv_upgrade(TARG, SVt_PVLV);
1965 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1969 if (LvTARG(TARG) != sv) {
1971 SvREFCNT_dec(LvTARG(TARG));
1972 LvTARG(TARG) = SvREFCNT_inc(sv);
1974 LvTARGOFF(TARG) = pos;
1975 LvTARGLEN(TARG) = rem;
1978 sv_insert(sv, pos, rem, repl, repl_len);
1981 PUSHs(TARG); /* avoid SvSETMAGIC here */
1988 register I32 size = POPi;
1989 register I32 offset = POPi;
1990 register SV *src = POPs;
1991 I32 lvalue = PL_op->op_flags & OPf_MOD;
1993 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1994 unsigned long retnum;
1997 SvTAINTED_off(TARG); /* decontaminate */
1998 offset *= size; /* turn into bit offset */
1999 len = (offset + size + 7) / 8;
2000 if (offset < 0 || size < 1)
2003 if (lvalue) { /* it's an lvalue! */
2004 if (SvTYPE(TARG) < SVt_PVLV) {
2005 sv_upgrade(TARG, SVt_PVLV);
2006 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2010 if (LvTARG(TARG) != src) {
2012 SvREFCNT_dec(LvTARG(TARG));
2013 LvTARG(TARG) = SvREFCNT_inc(src);
2015 LvTARGOFF(TARG) = offset;
2016 LvTARGLEN(TARG) = size;
2024 if (offset >= srclen)
2027 retnum = (unsigned long) s[offset] << 8;
2029 else if (size == 32) {
2030 if (offset >= srclen)
2032 else if (offset + 1 >= srclen)
2033 retnum = (unsigned long) s[offset] << 24;
2034 else if (offset + 2 >= srclen)
2035 retnum = ((unsigned long) s[offset] << 24) +
2036 ((unsigned long) s[offset + 1] << 16);
2038 retnum = ((unsigned long) s[offset] << 24) +
2039 ((unsigned long) s[offset + 1] << 16) +
2040 (s[offset + 2] << 8);
2045 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2050 else if (size == 16)
2051 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2052 else if (size == 32)
2053 retnum = ((unsigned long) s[offset] << 24) +
2054 ((unsigned long) s[offset + 1] << 16) +
2055 (s[offset + 2] << 8) + s[offset+3];
2059 sv_setuv(TARG, (UV)retnum);
2074 I32 arybase = PL_curcop->cop_arybase;
2079 offset = POPi - arybase;
2082 tmps = SvPV(big, biglen);
2083 if (IN_UTF8 && offset > 0)
2084 sv_pos_u2b(big, &offset, 0);
2087 else if (offset > biglen)
2089 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2090 (unsigned char*)tmps + biglen, little, 0)))
2093 retval = tmps2 - tmps;
2094 if (IN_UTF8 && retval > 0)
2095 sv_pos_b2u(big, &retval);
2096 PUSHi(retval + arybase);
2111 I32 arybase = PL_curcop->cop_arybase;
2117 tmps2 = SvPV(little, llen);
2118 tmps = SvPV(big, blen);
2122 if (IN_UTF8 && offset > 0)
2123 sv_pos_u2b(big, &offset, 0);
2124 offset = offset - arybase + llen;
2128 else if (offset > blen)
2130 if (!(tmps2 = rninstr(tmps, tmps + offset,
2131 tmps2, tmps2 + llen)))
2134 retval = tmps2 - tmps;
2135 if (IN_UTF8 && retval > 0)
2136 sv_pos_b2u(big, &retval);
2137 PUSHi(retval + arybase);
2143 djSP; dMARK; dORIGMARK; dTARGET;
2144 #ifdef USE_LOCALE_NUMERIC
2145 if (PL_op->op_private & OPpLOCALE)
2146 SET_NUMERIC_LOCAL();
2148 SET_NUMERIC_STANDARD();
2150 do_sprintf(TARG, SP-MARK, MARK+1);
2151 TAINT_IF(SvTAINTED(TARG));
2162 U8 *tmps = (U8*)POPpx;
2165 if (IN_UTF8 && (*tmps & 0x80))
2166 value = utf8_to_uv(tmps, &retlen);
2168 value = (UV)(*tmps & 255);
2179 (void)SvUPGRADE(TARG,SVt_PV);
2181 if (IN_UTF8 && value >= 128) {
2184 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2185 SvCUR_set(TARG, tmps - SvPVX(TARG));
2187 (void)SvPOK_only(TARG);
2197 (void)SvPOK_only(TARG);
2204 djSP; dTARGET; dPOPTOPssrl;
2207 char *tmps = SvPV(left, n_a);
2209 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2211 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2215 "The crypt() function is unimplemented due to excessive paranoia.");
2228 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2232 UV uv = utf8_to_uv(s, &ulen);
2234 if (PL_op->op_private & OPpLOCALE) {
2237 uv = toTITLE_LC_uni(uv);
2240 uv = toTITLE_utf8(s);
2242 tend = uv_to_utf8(tmpbuf, uv);
2244 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2246 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2247 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2251 s = (U8*)SvPV_force(sv, slen);
2252 Copy(tmpbuf, s, ulen, U8);
2257 if (!SvPADTMP(sv)) {
2263 s = (U8*)SvPV_force(sv, slen);
2265 if (PL_op->op_private & OPpLOCALE) {
2268 *s = toUPPER_LC(*s);
2284 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2288 UV uv = utf8_to_uv(s, &ulen);
2290 if (PL_op->op_private & OPpLOCALE) {
2293 uv = toLOWER_LC_uni(uv);
2296 uv = toLOWER_utf8(s);
2298 tend = uv_to_utf8(tmpbuf, uv);
2300 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2302 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2303 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2307 s = (U8*)SvPV_force(sv, slen);
2308 Copy(tmpbuf, s, ulen, U8);
2313 if (!SvPADTMP(sv)) {
2319 s = (U8*)SvPV_force(sv, slen);
2321 if (PL_op->op_private & OPpLOCALE) {
2324 *s = toLOWER_LC(*s);
2347 s = (U8*)SvPV(sv,len);
2349 sv_setpvn(TARG, "", 0);
2354 (void)SvUPGRADE(TARG, SVt_PV);
2355 SvGROW(TARG, (len * 2) + 1);
2356 (void)SvPOK_only(TARG);
2357 d = (U8*)SvPVX(TARG);
2359 if (PL_op->op_private & OPpLOCALE) {
2363 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2369 d = uv_to_utf8(d, toUPPER_utf8( s ));
2374 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2379 if (!SvPADTMP(sv)) {
2386 s = (U8*)SvPV_force(sv, len);
2388 register U8 *send = s + len;
2390 if (PL_op->op_private & OPpLOCALE) {
2393 for (; s < send; s++)
2394 *s = toUPPER_LC(*s);
2397 for (; s < send; s++)
2417 s = (U8*)SvPV(sv,len);
2419 sv_setpvn(TARG, "", 0);
2424 (void)SvUPGRADE(TARG, SVt_PV);
2425 SvGROW(TARG, (len * 2) + 1);
2426 (void)SvPOK_only(TARG);
2427 d = (U8*)SvPVX(TARG);
2429 if (PL_op->op_private & OPpLOCALE) {
2433 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2439 d = uv_to_utf8(d, toLOWER_utf8(s));
2444 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2449 if (!SvPADTMP(sv)) {
2456 s = (U8*)SvPV_force(sv, len);
2458 register U8 *send = s + len;
2460 if (PL_op->op_private & OPpLOCALE) {
2463 for (; s < send; s++)
2464 *s = toLOWER_LC(*s);
2467 for (; s < send; s++)
2479 register char *s = SvPV(sv,len);
2483 (void)SvUPGRADE(TARG, SVt_PV);
2484 SvGROW(TARG, (len * 2) + 1);
2489 STRLEN ulen = UTF8SKIP(s);
2512 SvCUR_set(TARG, d - SvPVX(TARG));
2513 (void)SvPOK_only(TARG);
2516 sv_setpvn(TARG, s, len);
2525 djSP; dMARK; dORIGMARK;
2527 register AV* av = (AV*)POPs;
2528 register I32 lval = PL_op->op_flags & OPf_MOD;
2529 I32 arybase = PL_curcop->cop_arybase;
2532 if (SvTYPE(av) == SVt_PVAV) {
2533 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2535 for (svp = MARK + 1; svp <= SP; svp++) {
2540 if (max > AvMAX(av))
2543 while (++MARK <= SP) {
2544 elem = SvIVx(*MARK);
2548 svp = av_fetch(av, elem, lval);
2550 if (!svp || *svp == &PL_sv_undef)
2551 DIE(PL_no_aelem, elem);
2552 if (PL_op->op_private & OPpLVAL_INTRO)
2553 save_aelem(av, elem, svp);
2555 *MARK = svp ? *svp : &PL_sv_undef;
2558 if (GIMME != G_ARRAY) {
2566 /* Associative arrays. */
2571 HV *hash = (HV*)POPs;
2573 I32 gimme = GIMME_V;
2574 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2577 /* might clobber stack_sp */
2578 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2583 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2584 if (gimme == G_ARRAY) {
2586 /* might clobber stack_sp */
2587 sv_setsv(TARG, realhv ?
2588 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2593 else if (gimme == G_SCALAR)
2612 I32 gimme = GIMME_V;
2613 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2617 if (PL_op->op_private & OPpSLICE) {
2621 hvtype = SvTYPE(hv);
2622 while (++MARK <= SP) {
2623 if (hvtype == SVt_PVHV)
2624 sv = hv_delete_ent(hv, *MARK, discard, 0);
2626 DIE("Not a HASH reference");
2627 *MARK = sv ? sv : &PL_sv_undef;
2631 else if (gimme == G_SCALAR) {
2640 if (SvTYPE(hv) == SVt_PVHV)
2641 sv = hv_delete_ent(hv, keysv, discard, 0);
2643 DIE("Not a HASH reference");
2657 if (SvTYPE(hv) == SVt_PVHV) {
2658 if (hv_exists_ent(hv, tmpsv, 0))
2661 else if (SvTYPE(hv) == SVt_PVAV) {
2662 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2666 DIE("Not a HASH reference");
2673 djSP; dMARK; dORIGMARK;
2674 register HV *hv = (HV*)POPs;
2675 register I32 lval = PL_op->op_flags & OPf_MOD;
2676 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2678 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2679 DIE("Can't localize pseudo-hash element");
2681 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2682 while (++MARK <= SP) {
2686 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2687 svp = he ? &HeVAL(he) : 0;
2690 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2693 if (!svp || *svp == &PL_sv_undef) {
2695 DIE(PL_no_helem, SvPV(keysv, n_a));
2697 if (PL_op->op_private & OPpLVAL_INTRO)
2698 save_helem(hv, keysv, svp);
2700 *MARK = svp ? *svp : &PL_sv_undef;
2703 if (GIMME != G_ARRAY) {
2711 /* List operators. */
2716 if (GIMME != G_ARRAY) {
2718 *MARK = *SP; /* unwanted list, return last item */
2720 *MARK = &PL_sv_undef;
2729 SV **lastrelem = PL_stack_sp;
2730 SV **lastlelem = PL_stack_base + POPMARK;
2731 SV **firstlelem = PL_stack_base + POPMARK + 1;
2732 register SV **firstrelem = lastlelem + 1;
2733 I32 arybase = PL_curcop->cop_arybase;
2734 I32 lval = PL_op->op_flags & OPf_MOD;
2735 I32 is_something_there = lval;
2737 register I32 max = lastrelem - lastlelem;
2738 register SV **lelem;
2741 if (GIMME != G_ARRAY) {
2742 ix = SvIVx(*lastlelem);
2747 if (ix < 0 || ix >= max)
2748 *firstlelem = &PL_sv_undef;
2750 *firstlelem = firstrelem[ix];
2756 SP = firstlelem - 1;
2760 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2765 *lelem = &PL_sv_undef;
2766 else if (!(*lelem = firstrelem[ix]))
2767 *lelem = &PL_sv_undef;
2771 if (ix >= max || !(*lelem = firstrelem[ix]))
2772 *lelem = &PL_sv_undef;
2774 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2775 is_something_there = TRUE;
2777 if (is_something_there)
2780 SP = firstlelem - 1;
2786 djSP; dMARK; dORIGMARK;
2787 I32 items = SP - MARK;
2788 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2789 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2796 djSP; dMARK; dORIGMARK;
2797 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2801 SV *val = NEWSV(46, 0);
2803 sv_setsv(val, *++MARK);
2804 else if (ckWARN(WARN_UNSAFE))
2805 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2806 (void)hv_store_ent(hv,key,val,0);
2815 djSP; dMARK; dORIGMARK;
2816 register AV *ary = (AV*)*++MARK;
2820 register I32 offset;
2821 register I32 length;
2828 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2829 *MARK-- = SvTIED_obj((SV*)ary, mg);
2833 perl_call_method("SPLICE",GIMME_V);
2842 offset = i = SvIVx(*MARK);
2844 offset += AvFILLp(ary) + 1;
2846 offset -= PL_curcop->cop_arybase;
2848 DIE(PL_no_aelem, i);
2850 length = SvIVx(*MARK++);
2852 length += AvFILLp(ary) - offset + 1;
2858 length = AvMAX(ary) + 1; /* close enough to infinity */
2862 length = AvMAX(ary) + 1;
2864 if (offset > AvFILLp(ary) + 1)
2865 offset = AvFILLp(ary) + 1;
2866 after = AvFILLp(ary) + 1 - (offset + length);
2867 if (after < 0) { /* not that much array */
2868 length += after; /* offset+length now in array */
2874 /* At this point, MARK .. SP-1 is our new LIST */
2877 diff = newlen - length;
2878 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2881 if (diff < 0) { /* shrinking the area */
2883 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2884 Copy(MARK, tmparyval, newlen, SV*);
2887 MARK = ORIGMARK + 1;
2888 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2889 MEXTEND(MARK, length);
2890 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2892 EXTEND_MORTAL(length);
2893 for (i = length, dst = MARK; i; i--) {
2894 sv_2mortal(*dst); /* free them eventualy */
2901 *MARK = AvARRAY(ary)[offset+length-1];
2904 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2905 SvREFCNT_dec(*dst++); /* free them now */
2908 AvFILLp(ary) += diff;
2910 /* pull up or down? */
2912 if (offset < after) { /* easier to pull up */
2913 if (offset) { /* esp. if nothing to pull */
2914 src = &AvARRAY(ary)[offset-1];
2915 dst = src - diff; /* diff is negative */
2916 for (i = offset; i > 0; i--) /* can't trust Copy */
2920 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2924 if (after) { /* anything to pull down? */
2925 src = AvARRAY(ary) + offset + length;
2926 dst = src + diff; /* diff is negative */
2927 Move(src, dst, after, SV*);
2929 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2930 /* avoid later double free */
2934 dst[--i] = &PL_sv_undef;
2937 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2939 *dst = NEWSV(46, 0);
2940 sv_setsv(*dst++, *src++);
2942 Safefree(tmparyval);
2945 else { /* no, expanding (or same) */
2947 New(452, tmparyval, length, SV*); /* so remember deletion */
2948 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2951 if (diff > 0) { /* expanding */
2953 /* push up or down? */
2955 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2959 Move(src, dst, offset, SV*);
2961 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2963 AvFILLp(ary) += diff;
2966 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2967 av_extend(ary, AvFILLp(ary) + diff);
2968 AvFILLp(ary) += diff;
2971 dst = AvARRAY(ary) + AvFILLp(ary);
2973 for (i = after; i; i--) {
2980 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2981 *dst = NEWSV(46, 0);
2982 sv_setsv(*dst++, *src++);
2984 MARK = ORIGMARK + 1;
2985 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2987 Copy(tmparyval, MARK, length, SV*);
2989 EXTEND_MORTAL(length);
2990 for (i = length, dst = MARK; i; i--) {
2991 sv_2mortal(*dst); /* free them eventualy */
2995 Safefree(tmparyval);
2999 else if (length--) {
3000 *MARK = tmparyval[length];
3003 while (length-- > 0)
3004 SvREFCNT_dec(tmparyval[length]);
3006 Safefree(tmparyval);
3009 *MARK = &PL_sv_undef;
3017 djSP; dMARK; dORIGMARK; dTARGET;
3018 register AV *ary = (AV*)*++MARK;
3019 register SV *sv = &PL_sv_undef;
3022 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3023 *MARK-- = SvTIED_obj((SV*)ary, mg);
3027 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3032 /* Why no pre-extend of ary here ? */
3033 for (++MARK; MARK <= SP; MARK++) {
3036 sv_setsv(sv, *MARK);
3041 PUSHi( AvFILL(ary) + 1 );
3049 SV *sv = av_pop(av);
3051 (void)sv_2mortal(sv);
3060 SV *sv = av_shift(av);
3065 (void)sv_2mortal(sv);
3072 djSP; dMARK; dORIGMARK; dTARGET;
3073 register AV *ary = (AV*)*++MARK;
3078 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3079 *MARK-- = SvTIED_obj((SV*)ary, mg);
3083 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3088 av_unshift(ary, SP - MARK);
3091 sv_setsv(sv, *++MARK);
3092 (void)av_store(ary, i++, sv);
3096 PUSHi( AvFILL(ary) + 1 );
3106 if (GIMME == G_ARRAY) {
3117 register char *down;
3123 do_join(TARG, &PL_sv_no, MARK, SP);
3125 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3126 up = SvPV_force(TARG, len);
3128 if (IN_UTF8) { /* first reverse each character */
3129 U8* s = (U8*)SvPVX(TARG);
3130 U8* send = (U8*)(s + len);
3139 down = (char*)(s - 1);
3140 if (s > send || !((*down & 0xc0) == 0x80)) {
3141 warn("Malformed UTF-8 character");
3153 down = SvPVX(TARG) + len - 1;
3159 (void)SvPOK_only(TARG);
3168 mul128(SV *sv, U8 m)
3171 char *s = SvPV(sv, len);
3175 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3176 SV *tmpNew = newSVpvn("0000000000", 10);
3178 sv_catsv(tmpNew, sv);
3179 SvREFCNT_dec(sv); /* free old sv */
3184 while (!*t) /* trailing '\0'? */
3187 i = ((*t - '0') << 7) + m;
3188 *(t--) = '0' + (i % 10);
3194 /* Explosives and implosives. */
3196 #if 'I' == 73 && 'J' == 74
3197 /* On an ASCII/ISO kind of system */
3198 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3201 Some other sort of character set - use memchr() so we don't match
3204 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3212 I32 gimme = GIMME_V;
3216 register char *pat = SvPV(left, llen);
3217 register char *s = SvPV(right, rlen);
3218 char *strend = s + rlen;
3220 register char *patend = pat + llen;
3225 /* These must not be in registers: */
3242 register U32 culong;
3245 #ifdef PERL_NATINT_PACK
3246 int natint; /* native integer */
3247 int unatint; /* unsigned native integer */
3250 if (gimme != G_ARRAY) { /* arrange to do first one only */
3252 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3253 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3255 while (isDIGIT(*patend) || *patend == '*')
3261 while (pat < patend) {
3263 datumtype = *pat++ & 0xFF;
3264 #ifdef PERL_NATINT_PACK
3267 if (isSPACE(datumtype))
3270 char *natstr = "sSiIlL";
3272 if (strchr(natstr, datumtype)) {
3273 #ifdef PERL_NATINT_PACK
3279 croak("'!' allowed only after types %s", natstr);
3283 else if (*pat == '*') {
3284 len = strend - strbeg; /* long enough */
3287 else if (isDIGIT(*pat)) {
3289 while (isDIGIT(*pat))
3290 len = (len * 10) + (*pat++ - '0');
3293 len = (datumtype != '@');
3296 croak("Invalid type in unpack: '%c'", (int)datumtype);
3297 case ',': /* grandfather in commas but with a warning */
3298 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3299 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3302 if (len == 1 && pat[-1] != '1')
3311 if (len > strend - strbeg)
3312 DIE("@ outside of string");
3316 if (len > s - strbeg)
3317 DIE("X outside of string");
3321 if (len > strend - s)
3322 DIE("x outside of string");
3328 if (len > strend - s)
3331 goto uchar_checksum;
3332 sv = NEWSV(35, len);
3333 sv_setpvn(sv, s, len);
3335 if (datumtype == 'A' || datumtype == 'Z') {
3336 aptr = s; /* borrow register */
3337 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3342 else { /* 'A' strips both nulls and spaces */
3343 s = SvPVX(sv) + len - 1;
3344 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3348 SvCUR_set(sv, s - SvPVX(sv));
3349 s = aptr; /* unborrow register */
3351 XPUSHs(sv_2mortal(sv));
3355 if (pat[-1] == '*' || len > (strend - s) * 8)
3356 len = (strend - s) * 8;
3359 Newz(601, PL_bitcount, 256, char);
3360 for (bits = 1; bits < 256; bits++) {
3361 if (bits & 1) PL_bitcount[bits]++;
3362 if (bits & 2) PL_bitcount[bits]++;
3363 if (bits & 4) PL_bitcount[bits]++;
3364 if (bits & 8) PL_bitcount[bits]++;
3365 if (bits & 16) PL_bitcount[bits]++;
3366 if (bits & 32) PL_bitcount[bits]++;
3367 if (bits & 64) PL_bitcount[bits]++;
3368 if (bits & 128) PL_bitcount[bits]++;
3372 culong += PL_bitcount[*(unsigned char*)s++];
3377 if (datumtype == 'b') {
3379 if (bits & 1) culong++;
3385 if (bits & 128) culong++;
3392 sv = NEWSV(35, len + 1);
3395 aptr = pat; /* borrow register */
3397 if (datumtype == 'b') {
3399 for (len = 0; len < aint; len++) {
3400 if (len & 7) /*SUPPRESS 595*/
3404 *pat++ = '0' + (bits & 1);
3409 for (len = 0; len < aint; len++) {
3414 *pat++ = '0' + ((bits & 128) != 0);
3418 pat = aptr; /* unborrow register */
3419 XPUSHs(sv_2mortal(sv));
3423 if (pat[-1] == '*' || len > (strend - s) * 2)
3424 len = (strend - s) * 2;
3425 sv = NEWSV(35, len + 1);
3428 aptr = pat; /* borrow register */
3430 if (datumtype == 'h') {
3432 for (len = 0; len < aint; len++) {
3437 *pat++ = PL_hexdigit[bits & 15];
3442 for (len = 0; len < aint; len++) {
3447 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3451 pat = aptr; /* unborrow register */
3452 XPUSHs(sv_2mortal(sv));
3455 if (len > strend - s)
3460 if (aint >= 128) /* fake up signed chars */
3470 if (aint >= 128) /* fake up signed chars */
3473 sv_setiv(sv, (IV)aint);
3474 PUSHs(sv_2mortal(sv));
3479 if (len > strend - s)
3494 sv_setiv(sv, (IV)auint);
3495 PUSHs(sv_2mortal(sv));
3500 if (len > strend - s)
3503 while (len-- > 0 && s < strend) {
3504 auint = utf8_to_uv((U8*)s, &along);
3507 cdouble += (double)auint;
3515 while (len-- > 0 && s < strend) {
3516 auint = utf8_to_uv((U8*)s, &along);
3519 sv_setuv(sv, (UV)auint);
3520 PUSHs(sv_2mortal(sv));
3525 #if SHORTSIZE == SIZE16
3526 along = (strend - s) / SIZE16;
3528 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3533 #if SHORTSIZE != SIZE16
3536 COPYNN(s, &ashort, sizeof(short));
3547 #if SHORTSIZE > SIZE16
3559 #if SHORTSIZE != SIZE16
3562 COPYNN(s, &ashort, sizeof(short));
3565 sv_setiv(sv, (IV)ashort);
3566 PUSHs(sv_2mortal(sv));
3574 #if SHORTSIZE > SIZE16
3580 sv_setiv(sv, (IV)ashort);
3581 PUSHs(sv_2mortal(sv));
3589 #if SHORTSIZE == SIZE16
3590 along = (strend - s) / SIZE16;
3592 unatint = natint && datumtype == 'S';
3593 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3598 #if SHORTSIZE != SIZE16
3601 COPYNN(s, &aushort, sizeof(unsigned short));
3602 s += sizeof(unsigned short);
3610 COPY16(s, &aushort);
3613 if (datumtype == 'n')
3614 aushort = PerlSock_ntohs(aushort);
3617 if (datumtype == 'v')
3618 aushort = vtohs(aushort);
3627 #if SHORTSIZE != SIZE16
3630 COPYNN(s, &aushort, sizeof(unsigned short));
3631 s += sizeof(unsigned short);
3633 sv_setiv(sv, (UV)aushort);
3634 PUSHs(sv_2mortal(sv));
3641 COPY16(s, &aushort);
3645 if (datumtype == 'n')
3646 aushort = PerlSock_ntohs(aushort);
3649 if (datumtype == 'v')
3650 aushort = vtohs(aushort);
3652 sv_setiv(sv, (UV)aushort);
3653 PUSHs(sv_2mortal(sv));
3659 along = (strend - s) / sizeof(int);
3664 Copy(s, &aint, 1, int);
3667 cdouble += (double)aint;
3676 Copy(s, &aint, 1, int);
3680 /* Without the dummy below unpack("i", pack("i",-1))
3681 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3682 * cc with optimization turned on.
3684 * The bug was detected in
3685 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3686 * with optimization (-O4) turned on.
3687 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3688 * does not have this problem even with -O4.
3690 * This bug was reported as DECC_BUGS 1431
3691 * and tracked internally as GEM_BUGS 7775.
3693 * The bug is fixed in
3694 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3695 * UNIX V4.0F support: DEC C V5.9-006 or later
3696 * UNIX V4.0E support: DEC C V5.8-011 or later
3699 * See also few lines later for the same bug.
3702 sv_setiv(sv, (IV)aint) :
3704 sv_setiv(sv, (IV)aint);
3705 PUSHs(sv_2mortal(sv));
3710 along = (strend - s) / sizeof(unsigned int);
3715 Copy(s, &auint, 1, unsigned int);
3716 s += sizeof(unsigned int);
3718 cdouble += (double)auint;
3727 Copy(s, &auint, 1, unsigned int);
3728 s += sizeof(unsigned int);
3731 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3732 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3733 * See details few lines earlier. */
3735 sv_setuv(sv, (UV)auint) :
3737 sv_setuv(sv, (UV)auint);
3738 PUSHs(sv_2mortal(sv));
3743 #if LONGSIZE == SIZE32
3744 along = (strend - s) / SIZE32;
3746 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3751 #if LONGSIZE != SIZE32
3754 COPYNN(s, &along, sizeof(long));
3757 cdouble += (double)along;
3767 #if LONGSIZE > SIZE32
3768 if (along > 2147483647)
3769 along -= 4294967296;
3773 cdouble += (double)along;
3782 #if LONGSIZE != SIZE32
3785 COPYNN(s, &along, sizeof(long));
3788 sv_setiv(sv, (IV)along);
3789 PUSHs(sv_2mortal(sv));
3797 #if LONGSIZE > SIZE32
3798 if (along > 2147483647)
3799 along -= 4294967296;
3803 sv_setiv(sv, (IV)along);
3804 PUSHs(sv_2mortal(sv));
3812 #if LONGSIZE == SIZE32
3813 along = (strend - s) / SIZE32;
3815 unatint = natint && datumtype == 'L';
3816 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3821 #if LONGSIZE != SIZE32
3824 COPYNN(s, &aulong, sizeof(unsigned long));
3825 s += sizeof(unsigned long);
3827 cdouble += (double)aulong;
3839 if (datumtype == 'N')
3840 aulong = PerlSock_ntohl(aulong);
3843 if (datumtype == 'V')
3844 aulong = vtohl(aulong);
3847 cdouble += (double)aulong;
3856 #if LONGSIZE != SIZE32
3859 COPYNN(s, &aulong, sizeof(unsigned long));
3860 s += sizeof(unsigned long);
3862 sv_setuv(sv, (UV)aulong);
3863 PUSHs(sv_2mortal(sv));
3873 if (datumtype == 'N')
3874 aulong = PerlSock_ntohl(aulong);
3877 if (datumtype == 'V')
3878 aulong = vtohl(aulong);
3881 sv_setuv(sv, (UV)aulong);
3882 PUSHs(sv_2mortal(sv));
3888 along = (strend - s) / sizeof(char*);
3894 if (sizeof(char*) > strend - s)
3897 Copy(s, &aptr, 1, char*);
3903 PUSHs(sv_2mortal(sv));
3913 while ((len > 0) && (s < strend)) {
3914 auv = (auv << 7) | (*s & 0x7f);
3915 if (!(*s++ & 0x80)) {
3919 PUSHs(sv_2mortal(sv));
3923 else if (++bytes >= sizeof(UV)) { /* promote to string */
3927 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3928 while (s < strend) {
3929 sv = mul128(sv, *s & 0x7f);
3930 if (!(*s++ & 0x80)) {
3939 PUSHs(sv_2mortal(sv));
3944 if ((s >= strend) && bytes)
3945 croak("Unterminated compressed integer");
3950 if (sizeof(char*) > strend - s)
3953 Copy(s, &aptr, 1, char*);
3958 sv_setpvn(sv, aptr, len);
3959 PUSHs(sv_2mortal(sv));
3963 along = (strend - s) / sizeof(Quad_t);
3969 if (s + sizeof(Quad_t) > strend)
3972 Copy(s, &aquad, 1, Quad_t);
3973 s += sizeof(Quad_t);
3976 if (aquad >= IV_MIN && aquad <= IV_MAX)
3977 sv_setiv(sv, (IV)aquad);
3979 sv_setnv(sv, (double)aquad);
3980 PUSHs(sv_2mortal(sv));
3984 along = (strend - s) / sizeof(Quad_t);
3990 if (s + sizeof(Uquad_t) > strend)
3993 Copy(s, &auquad, 1, Uquad_t);
3994 s += sizeof(Uquad_t);
3997 if (auquad <= UV_MAX)
3998 sv_setuv(sv, (UV)auquad);
4000 sv_setnv(sv, (double)auquad);
4001 PUSHs(sv_2mortal(sv));
4005 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4008 along = (strend - s) / sizeof(float);
4013 Copy(s, &afloat, 1, float);
4022 Copy(s, &afloat, 1, float);
4025 sv_setnv(sv, (double)afloat);
4026 PUSHs(sv_2mortal(sv));
4032 along = (strend - s) / sizeof(double);
4037 Copy(s, &adouble, 1, double);
4038 s += sizeof(double);
4046 Copy(s, &adouble, 1, double);
4047 s += sizeof(double);
4049 sv_setnv(sv, (double)adouble);
4050 PUSHs(sv_2mortal(sv));
4056 * Initialise the decode mapping. By using a table driven
4057 * algorithm, the code will be character-set independent
4058 * (and just as fast as doing character arithmetic)
4060 if (PL_uudmap['M'] == 0) {
4063 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4064 PL_uudmap[PL_uuemap[i]] = i;
4066 * Because ' ' and '`' map to the same value,
4067 * we need to decode them both the same.
4072 along = (strend - s) * 3 / 4;
4073 sv = NEWSV(42, along);
4076 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4081 len = PL_uudmap[*s++] & 077;
4083 if (s < strend && ISUUCHAR(*s))
4084 a = PL_uudmap[*s++] & 077;
4087 if (s < strend && ISUUCHAR(*s))
4088 b = PL_uudmap[*s++] & 077;
4091 if (s < strend && ISUUCHAR(*s))
4092 c = PL_uudmap[*s++] & 077;
4095 if (s < strend && ISUUCHAR(*s))
4096 d = PL_uudmap[*s++] & 077;
4099 hunk[0] = (a << 2) | (b >> 4);
4100 hunk[1] = (b << 4) | (c >> 2);
4101 hunk[2] = (c << 6) | d;
4102 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4107 else if (s[1] == '\n') /* possible checksum byte */
4110 XPUSHs(sv_2mortal(sv));
4115 if (strchr("fFdD", datumtype) ||
4116 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4120 while (checksum >= 16) {
4124 while (checksum >= 4) {
4130 along = (1 << checksum) - 1;
4131 while (cdouble < 0.0)
4133 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4134 sv_setnv(sv, cdouble);
4137 if (checksum < 32) {
4138 aulong = (1 << checksum) - 1;
4141 sv_setuv(sv, (UV)culong);
4143 XPUSHs(sv_2mortal(sv));
4147 if (SP == oldsp && gimme == G_SCALAR)
4148 PUSHs(&PL_sv_undef);
4153 doencodes(register SV *sv, register char *s, register I32 len)
4157 *hunk = PL_uuemap[len];
4158 sv_catpvn(sv, hunk, 1);
4161 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4162 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4163 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4164 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4165 sv_catpvn(sv, hunk, 4);
4170 char r = (len > 1 ? s[1] : '\0');
4171 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4172 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4173 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4174 hunk[3] = PL_uuemap[0];
4175 sv_catpvn(sv, hunk, 4);
4177 sv_catpvn(sv, "\n", 1);
4181 is_an_int(char *s, STRLEN l)
4184 SV *result = newSVpvn(s, l);
4185 char *result_c = SvPV(result, n_a); /* convenience */
4186 char *out = result_c;
4196 SvREFCNT_dec(result);
4219 SvREFCNT_dec(result);
4225 SvCUR_set(result, out - result_c);
4230 div128(SV *pnum, bool *done)
4231 /* must be '\0' terminated */
4235 char *s = SvPV(pnum, len);
4244 i = m * 10 + (*t - '0');
4246 r = (i >> 7); /* r < 10 */
4253 SvCUR_set(pnum, (STRLEN) (t - s));
4260 djSP; dMARK; dORIGMARK; dTARGET;
4261 register SV *cat = TARG;
4264 register char *pat = SvPVx(*++MARK, fromlen);
4265 register char *patend = pat + fromlen;
4270 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4271 static char *space10 = " ";
4273 /* These must not be in registers: */
4288 #ifdef PERL_NATINT_PACK
4289 int natint; /* native integer */
4294 sv_setpvn(cat, "", 0);
4295 while (pat < patend) {
4296 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4297 datumtype = *pat++ & 0xFF;
4298 #ifdef PERL_NATINT_PACK
4301 if (isSPACE(datumtype))
4304 char *natstr = "sSiIlL";
4306 if (strchr(natstr, datumtype)) {
4307 #ifdef PERL_NATINT_PACK
4313 croak("'!' allowed only after types %s", natstr);
4316 len = strchr("@Xxu", datumtype) ? 0 : items;
4319 else if (isDIGIT(*pat)) {
4321 while (isDIGIT(*pat))
4322 len = (len * 10) + (*pat++ - '0');
4328 croak("Invalid type in pack: '%c'", (int)datumtype);
4329 case ',': /* grandfather in commas but with a warning */
4330 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4331 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4334 DIE("%% may only be used in unpack");
4345 if (SvCUR(cat) < len)
4346 DIE("X outside of string");
4353 sv_catpvn(cat, null10, 10);
4356 sv_catpvn(cat, null10, len);
4362 aptr = SvPV(fromstr, fromlen);
4366 sv_catpvn(cat, aptr, len);
4368 sv_catpvn(cat, aptr, fromlen);
4370 if (datumtype == 'A') {
4372 sv_catpvn(cat, space10, 10);
4375 sv_catpvn(cat, space10, len);
4379 sv_catpvn(cat, null10, 10);
4382 sv_catpvn(cat, null10, len);
4389 char *savepat = pat;
4394 aptr = SvPV(fromstr, fromlen);
4399 SvCUR(cat) += (len+7)/8;
4400 SvGROW(cat, SvCUR(cat) + 1);
4401 aptr = SvPVX(cat) + aint;
4406 if (datumtype == 'B') {
4407 for (len = 0; len++ < aint;) {
4408 items |= *pat++ & 1;
4412 *aptr++ = items & 0xff;
4418 for (len = 0; len++ < aint;) {
4424 *aptr++ = items & 0xff;
4430 if (datumtype == 'B')
4431 items <<= 7 - (aint & 7);
4433 items >>= 7 - (aint & 7);
4434 *aptr++ = items & 0xff;
4436 pat = SvPVX(cat) + SvCUR(cat);
4447 char *savepat = pat;
4452 aptr = SvPV(fromstr, fromlen);
4457 SvCUR(cat) += (len+1)/2;
4458 SvGROW(cat, SvCUR(cat) + 1);
4459 aptr = SvPVX(cat) + aint;
4464 if (datumtype == 'H') {
4465 for (len = 0; len++ < aint;) {
4467 items |= ((*pat++ & 15) + 9) & 15;
4469 items |= *pat++ & 15;
4473 *aptr++ = items & 0xff;
4479 for (len = 0; len++ < aint;) {
4481 items |= (((*pat++ & 15) + 9) & 15) << 4;
4483 items |= (*pat++ & 15) << 4;
4487 *aptr++ = items & 0xff;
4493 *aptr++ = items & 0xff;
4494 pat = SvPVX(cat) + SvCUR(cat);
4506 aint = SvIV(fromstr);
4508 sv_catpvn(cat, &achar, sizeof(char));
4514 auint = SvUV(fromstr);
4515 SvGROW(cat, SvCUR(cat) + 10);
4516 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4521 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4526 afloat = (float)SvNV(fromstr);
4527 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4534 adouble = (double)SvNV(fromstr);
4535 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4541 ashort = (I16)SvIV(fromstr);
4543 ashort = PerlSock_htons(ashort);
4545 CAT16(cat, &ashort);
4551 ashort = (I16)SvIV(fromstr);
4553 ashort = htovs(ashort);
4555 CAT16(cat, &ashort);
4559 #if SHORTSIZE != SIZE16
4561 unsigned short aushort;
4565 aushort = SvUV(fromstr);
4566 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4576 aushort = (U16)SvUV(fromstr);
4577 CAT16(cat, &aushort);
4583 #if SHORTSIZE != SIZE16
4587 ashort = SvIV(fromstr);
4588 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4596 ashort = (I16)SvIV(fromstr);
4597 CAT16(cat, &ashort);
4604 auint = SvUV(fromstr);
4605 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4611 adouble = floor(SvNV(fromstr));
4614 croak("Cannot compress negative numbers");
4620 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4621 adouble <= UV_MAX_cxux
4628 char buf[1 + sizeof(UV)];
4629 char *in = buf + sizeof(buf);
4630 UV auv = U_V(adouble);;
4633 *--in = (auv & 0x7f) | 0x80;
4636 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4637 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4639 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4640 char *from, *result, *in;
4645 /* Copy string and check for compliance */
4646 from = SvPV(fromstr, len);
4647 if ((norm = is_an_int(from, len)) == NULL)
4648 croak("can compress only unsigned integer");
4650 New('w', result, len, char);
4654 *--in = div128(norm, &done) | 0x80;
4655 result[len - 1] &= 0x7F; /* clear continue bit */
4656 sv_catpvn(cat, in, (result + len) - in);
4658 SvREFCNT_dec(norm); /* free norm */
4660 else if (SvNOKp(fromstr)) {
4661 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4662 char *in = buf + sizeof(buf);
4665 double next = floor(adouble / 128);
4666 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4667 if (--in < buf) /* this cannot happen ;-) */
4668 croak ("Cannot compress integer");
4670 } while (adouble > 0);
4671 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4672 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4675 croak("Cannot compress non integer");
4681 aint = SvIV(fromstr);
4682 sv_catpvn(cat, (char*)&aint, sizeof(int));
4688 aulong = SvUV(fromstr);
4690 aulong = PerlSock_htonl(aulong);
4692 CAT32(cat, &aulong);
4698 aulong = SvUV(fromstr);
4700 aulong = htovl(aulong);
4702 CAT32(cat, &aulong);
4706 #if LONGSIZE != SIZE32
4710 aulong = SvUV(fromstr);
4711 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4719 aulong = SvUV(fromstr);
4720 CAT32(cat, &aulong);
4725 #if LONGSIZE != SIZE32
4729 along = SvIV(fromstr);
4730 sv_catpvn(cat, (char *)&along, sizeof(long));
4738 along = SvIV(fromstr);
4747 auquad = (Uquad_t)SvIV(fromstr);
4748 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4754 aquad = (Quad_t)SvIV(fromstr);
4755 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4758 #endif /* HAS_QUAD */
4760 len = 1; /* assume SV is correct length */
4765 if (fromstr == &PL_sv_undef)
4769 /* XXX better yet, could spirit away the string to
4770 * a safe spot and hang on to it until the result
4771 * of pack() (and all copies of the result) are
4774 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4776 "Attempt to pack pointer to temporary value");
4777 if (SvPOK(fromstr) || SvNIOK(fromstr))
4778 aptr = SvPV(fromstr,n_a);
4780 aptr = SvPV_force(fromstr,n_a);
4782 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4787 aptr = SvPV(fromstr, fromlen);
4788 SvGROW(cat, fromlen * 4 / 3);
4793 while (fromlen > 0) {
4800 doencodes(cat, aptr, todo);
4819 register I32 limit = POPi; /* note, negative is forever */
4822 register char *s = SvPV(sv, len);
4823 char *strend = s + len;
4825 register REGEXP *rx;
4829 I32 maxiters = (strend - s) + 10;
4832 I32 origlimit = limit;
4835 AV *oldstack = PL_curstack;
4836 I32 gimme = GIMME_V;
4837 I32 oldsave = PL_savestack_ix;
4838 I32 make_mortal = 1;
4839 MAGIC *mg = (MAGIC *) NULL;
4842 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4847 DIE("panic: do_split");
4848 rx = pm->op_pmregexp;
4850 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4851 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4853 if (pm->op_pmreplroot)
4854 ary = GvAVn((GV*)pm->op_pmreplroot);
4855 else if (gimme != G_ARRAY)
4857 ary = (AV*)PL_curpad[0];
4859 ary = GvAVn(PL_defgv);
4860 #endif /* USE_THREADS */
4863 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4869 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4871 XPUSHs(SvTIED_obj((SV*)ary, mg));
4876 for (i = AvFILLp(ary); i >= 0; i--)
4877 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4879 /* temporarily switch stacks */
4880 SWITCHSTACK(PL_curstack, ary);
4884 base = SP - PL_stack_base;
4886 if (pm->op_pmflags & PMf_SKIPWHITE) {
4887 if (pm->op_pmflags & PMf_LOCALE) {
4888 while (isSPACE_LC(*s))
4896 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4897 SAVEINT(PL_multiline);
4898 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4902 limit = maxiters + 2;
4903 if (pm->op_pmflags & PMf_WHITE) {
4906 while (m < strend &&
4907 !((pm->op_pmflags & PMf_LOCALE)
4908 ? isSPACE_LC(*m) : isSPACE(*m)))
4913 dstr = NEWSV(30, m-s);
4914 sv_setpvn(dstr, s, m-s);
4920 while (s < strend &&
4921 ((pm->op_pmflags & PMf_LOCALE)
4922 ? isSPACE_LC(*s) : isSPACE(*s)))
4926 else if (strEQ("^", rx->precomp)) {
4929 for (m = s; m < strend && *m != '\n'; m++) ;
4933 dstr = NEWSV(30, m-s);
4934 sv_setpvn(dstr, s, m-s);
4941 else if (rx->check_substr && !rx->nparens
4942 && (rx->reganch & ROPT_CHECK_ALL)
4943 && !(rx->reganch & ROPT_ANCH)) {
4944 i = SvCUR(rx->check_substr);
4945 if (i == 1 && !SvTAIL(rx->check_substr)) {
4946 i = *SvPVX(rx->check_substr);
4949 for (m = s; m < strend && *m != i; m++) ;
4952 dstr = NEWSV(30, m-s);
4953 sv_setpvn(dstr, s, m-s);
4962 while (s < strend && --limit &&
4963 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4964 rx->check_substr, 0)) )
4967 dstr = NEWSV(31, m-s);
4968 sv_setpvn(dstr, s, m-s);
4977 maxiters += (strend - s) * rx->nparens;
4978 while (s < strend && --limit &&
4979 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4981 TAINT_IF(RX_MATCH_TAINTED(rx));
4983 && rx->subbase != orig) {
4988 strend = s + (strend - m);
4991 dstr = NEWSV(32, m-s);
4992 sv_setpvn(dstr, s, m-s);
4997 for (i = 1; i <= rx->nparens; i++) {
5001 dstr = NEWSV(33, m-s);
5002 sv_setpvn(dstr, s, m-s);
5005 dstr = NEWSV(33, 0);
5015 LEAVE_SCOPE(oldsave);
5016 iters = (SP - PL_stack_base) - base;
5017 if (iters > maxiters)
5020 /* keep field after final delim? */
5021 if (s < strend || (iters && origlimit)) {
5022 dstr = NEWSV(34, strend-s);
5023 sv_setpvn(dstr, s, strend-s);
5029 else if (!origlimit) {
5030 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5036 SWITCHSTACK(ary, oldstack);
5037 if (SvSMAGICAL(ary)) {
5042 if (gimme == G_ARRAY) {
5044 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5052 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5055 if (gimme == G_ARRAY) {
5056 /* EXTEND should not be needed - we just popped them */
5058 for (i=0; i < iters; i++) {
5059 SV **svp = av_fetch(ary, i, FALSE);
5060 PUSHs((svp) ? *svp : &PL_sv_undef);
5067 if (gimme == G_ARRAY)
5070 if (iters || !pm->op_pmreplroot) {
5080 unlock_condpair(void *svv)
5083 MAGIC *mg = mg_find((SV*)svv, 'm');
5086 croak("panic: unlock_condpair unlocking non-mutex");
5087 MUTEX_LOCK(MgMUTEXP(mg));
5088 if (MgOWNER(mg) != thr)
5089 croak("panic: unlock_condpair unlocking mutex that we don't own");
5091 COND_SIGNAL(MgOWNERCONDP(mg));
5092 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5093 (unsigned long)thr, (unsigned long)svv);)
5094 MUTEX_UNLOCK(MgMUTEXP(mg));
5096 #endif /* USE_THREADS */
5109 mg = condpair_magic(sv);
5110 MUTEX_LOCK(MgMUTEXP(mg));
5111 if (MgOWNER(mg) == thr)
5112 MUTEX_UNLOCK(MgMUTEXP(mg));
5115 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5117 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5118 (unsigned long)thr, (unsigned long)sv);)
5119 MUTEX_UNLOCK(MgMUTEXP(mg));
5120 save_destructor(unlock_condpair, sv);
5122 #endif /* USE_THREADS */
5123 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5124 || SvTYPE(retsv) == SVt_PVCV) {
5125 retsv = refto(retsv);
5136 if (PL_op->op_private & OPpLVAL_INTRO)
5137 PUSHs(*save_threadsv(PL_op->op_targ));
5139 PUSHs(THREADSV(PL_op->op_targ));
5142 DIE("tried to access per-thread data in non-threaded perl");
5143 #endif /* USE_THREADS */