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);
970 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
972 right = (right_neg = (i < 0)) ? -i : i;
977 right_neg = dright < 0;
982 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
984 left = (left_neg = (i < 0)) ? -i : i;
992 left_neg = dleft < 0;
1001 /* Tried: DOUBLESIZE <= UV_SIZE = Precision of UV more than of NV.
1002 * But in fact this is an optimization - trunc may be slow */
1004 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1006 # define CAST_D2UV(d) U_V(d)
1008 # define CAST_D2UV(d) ((UV)(d))
1011 if (dright <= UV_MAX && dleft <= UV_MAX) {
1012 right = CAST_D2UV(dright);
1013 left = CAST_D2UV(dleft);
1018 /* Backward-compatibility clause: */
1019 dright = trunc(dright + 0.5);
1020 dleft = trunc(dleft + 0.5);
1023 DIE("Illegal modulus zero");
1025 dans = fmod(dleft, dright);
1026 if ((left_neg != right_neg) && dans)
1027 dans = dright - dans;
1030 sv_setnv(TARG, dans);
1037 DIE("Illegal modulus zero");
1040 if ((left_neg != right_neg) && ans)
1043 /* XXX may warn: unary minus operator applied to unsigned type */
1044 /* could change -foo to be (~foo)+1 instead */
1045 if (ans <= ~((UV)IV_MAX)+1)
1046 sv_setiv(TARG, ~ans+1);
1048 sv_setnv(TARG, -(double)ans);
1051 sv_setuv(TARG, ans);
1060 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1062 register I32 count = POPi;
1063 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1065 I32 items = SP - MARK;
1068 max = items * count;
1077 repeatcpy((char*)(MARK + items), (char*)MARK,
1078 items * sizeof(SV*), count - 1);
1081 else if (count <= 0)
1084 else { /* Note: mark already snarfed by pp_list */
1089 SvSetSV(TARG, tmpstr);
1090 SvPV_force(TARG, len);
1095 SvGROW(TARG, (count * len) + 1);
1096 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1097 SvCUR(TARG) *= count;
1099 *SvEND(TARG) = '\0';
1101 (void)SvPOK_only(TARG);
1110 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1113 SETn( left - right );
1120 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1123 if (PL_op->op_private & HINT_INTEGER) {
1125 i = BWi(i) << shift;
1139 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1142 if (PL_op->op_private & HINT_INTEGER) {
1144 i = BWi(i) >> shift;
1158 djSP; tryAMAGICbinSET(lt,0);
1161 SETs(boolSV(TOPn < value));
1168 djSP; tryAMAGICbinSET(gt,0);
1171 SETs(boolSV(TOPn > value));
1178 djSP; tryAMAGICbinSET(le,0);
1181 SETs(boolSV(TOPn <= value));
1188 djSP; tryAMAGICbinSET(ge,0);
1191 SETs(boolSV(TOPn >= value));
1198 djSP; tryAMAGICbinSET(ne,0);
1201 SETs(boolSV(TOPn != value));
1208 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1215 else if (left < right)
1217 else if (left > right)
1230 djSP; tryAMAGICbinSET(slt,0);
1233 int cmp = ((PL_op->op_private & OPpLOCALE)
1234 ? sv_cmp_locale(left, right)
1235 : sv_cmp(left, right));
1236 SETs(boolSV(cmp < 0));
1243 djSP; tryAMAGICbinSET(sgt,0);
1246 int cmp = ((PL_op->op_private & OPpLOCALE)
1247 ? sv_cmp_locale(left, right)
1248 : sv_cmp(left, right));
1249 SETs(boolSV(cmp > 0));
1256 djSP; tryAMAGICbinSET(sle,0);
1259 int cmp = ((PL_op->op_private & OPpLOCALE)
1260 ? sv_cmp_locale(left, right)
1261 : sv_cmp(left, right));
1262 SETs(boolSV(cmp <= 0));
1269 djSP; tryAMAGICbinSET(sge,0);
1272 int cmp = ((PL_op->op_private & OPpLOCALE)
1273 ? sv_cmp_locale(left, right)
1274 : sv_cmp(left, right));
1275 SETs(boolSV(cmp >= 0));
1282 djSP; tryAMAGICbinSET(seq,0);
1285 SETs(boolSV(sv_eq(left, right)));
1292 djSP; tryAMAGICbinSET(sne,0);
1295 SETs(boolSV(!sv_eq(left, right)));
1302 djSP; dTARGET; tryAMAGICbin(scmp,0);
1305 int cmp = ((PL_op->op_private & OPpLOCALE)
1306 ? sv_cmp_locale(left, right)
1307 : sv_cmp(left, right));
1315 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1318 if (SvNIOKp(left) || SvNIOKp(right)) {
1319 if (PL_op->op_private & HINT_INTEGER) {
1320 IBW value = SvIV(left) & SvIV(right);
1324 UBW value = SvUV(left) & SvUV(right);
1329 do_vop(PL_op->op_type, TARG, left, right);
1338 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1341 if (SvNIOKp(left) || SvNIOKp(right)) {
1342 if (PL_op->op_private & HINT_INTEGER) {
1343 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1347 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1352 do_vop(PL_op->op_type, TARG, left, right);
1361 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1364 if (SvNIOKp(left) || SvNIOKp(right)) {
1365 if (PL_op->op_private & HINT_INTEGER) {
1366 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1370 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1375 do_vop(PL_op->op_type, TARG, left, right);
1384 djSP; dTARGET; tryAMAGICun(neg);
1389 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1391 else if (SvNIOKp(sv))
1393 else if (SvPOKp(sv)) {
1395 char *s = SvPV(sv, len);
1396 if (isIDFIRST(*s)) {
1397 sv_setpvn(TARG, "-", 1);
1400 else if (*s == '+' || *s == '-') {
1402 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1404 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1405 sv_setpvn(TARG, "-", 1);
1409 sv_setnv(TARG, -SvNV(sv));
1420 djSP; tryAMAGICunSET(not);
1421 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1427 djSP; dTARGET; tryAMAGICun(compl);
1431 if (PL_op->op_private & HINT_INTEGER) {
1432 IBW value = ~SvIV(sv);
1436 UBW value = ~SvUV(sv);
1441 register char *tmps;
1442 register long *tmpl;
1447 tmps = SvPV_force(TARG, len);
1450 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1453 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1457 for ( ; anum > 0; anum--, tmps++)
1466 /* integer versions of some of the above */
1470 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1473 SETi( left * right );
1480 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1484 DIE("Illegal division by zero");
1485 value = POPi / value;
1493 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1497 DIE("Illegal modulus zero");
1498 SETi( left % right );
1505 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1508 SETi( left + right );
1515 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1518 SETi( left - right );
1525 djSP; tryAMAGICbinSET(lt,0);
1528 SETs(boolSV(left < right));
1535 djSP; tryAMAGICbinSET(gt,0);
1538 SETs(boolSV(left > right));
1545 djSP; tryAMAGICbinSET(le,0);
1548 SETs(boolSV(left <= right));
1555 djSP; tryAMAGICbinSET(ge,0);
1558 SETs(boolSV(left >= right));
1565 djSP; tryAMAGICbinSET(eq,0);
1568 SETs(boolSV(left == right));
1575 djSP; tryAMAGICbinSET(ne,0);
1578 SETs(boolSV(left != right));
1585 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1592 else if (left < right)
1603 djSP; dTARGET; tryAMAGICun(neg);
1608 /* High falutin' math. */
1612 djSP; dTARGET; tryAMAGICbin(atan2,0);
1615 SETn(atan2(left, right));
1622 djSP; dTARGET; tryAMAGICun(sin);
1634 djSP; dTARGET; tryAMAGICun(cos);
1644 /* Support Configure command-line overrides for rand() functions.
1645 After 5.005, perhaps we should replace this by Configure support
1646 for drand48(), random(), or rand(). For 5.005, though, maintain
1647 compatibility by calling rand() but allow the user to override it.
1648 See INSTALL for details. --Andy Dougherty 15 July 1998
1650 /* Now it's after 5.005, and Configure supports drand48() and random(),
1651 in addition to rand(). So the overrides should not be needed any more.
1652 --Jarkko Hietaniemi 27 September 1998
1655 #ifndef HAS_DRAND48_PROTO
1656 extern double drand48 _((void));
1669 if (!PL_srand_called) {
1670 (void)seedDrand01((Rand_seed_t)seed());
1671 PL_srand_called = TRUE;
1686 (void)seedDrand01((Rand_seed_t)anum);
1687 PL_srand_called = TRUE;
1696 * This is really just a quick hack which grabs various garbage
1697 * values. It really should be a real hash algorithm which
1698 * spreads the effect of every input bit onto every output bit,
1699 * if someone who knows about such things would bother to write it.
1700 * Might be a good idea to add that function to CORE as well.
1701 * No numbers below come from careful analysis or anything here,
1702 * except they are primes and SEED_C1 > 1E6 to get a full-width
1703 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1704 * probably be bigger too.
1707 # define SEED_C1 1000003
1708 #define SEED_C4 73819
1710 # define SEED_C1 25747
1711 #define SEED_C4 20639
1715 #define SEED_C5 26107
1718 #ifndef PERL_NO_DEV_RANDOM
1723 # include <starlet.h>
1724 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1725 * in 100-ns units, typically incremented ever 10 ms. */
1726 unsigned int when[2];
1728 # ifdef HAS_GETTIMEOFDAY
1729 struct timeval when;
1735 /* This test is an escape hatch, this symbol isn't set by Configure. */
1736 #ifndef PERL_NO_DEV_RANDOM
1737 #ifndef PERL_RANDOM_DEVICE
1738 /* /dev/random isn't used by default because reads from it will block
1739 * if there isn't enough entropy available. You can compile with
1740 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1741 * is enough real entropy to fill the seed. */
1742 # define PERL_RANDOM_DEVICE "/dev/urandom"
1744 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1746 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1755 _ckvmssts(sys$gettim(when));
1756 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1758 # ifdef HAS_GETTIMEOFDAY
1759 gettimeofday(&when,(struct timezone *) 0);
1760 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1763 u = (U32)SEED_C1 * when;
1766 u += SEED_C3 * (U32)getpid();
1767 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1768 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1769 u += SEED_C5 * (U32)(UV)&when;
1776 djSP; dTARGET; tryAMAGICun(exp);
1788 djSP; dTARGET; tryAMAGICun(log);
1793 SET_NUMERIC_STANDARD();
1794 DIE("Can't take log of %g", value);
1804 djSP; dTARGET; tryAMAGICun(sqrt);
1809 SET_NUMERIC_STANDARD();
1810 DIE("Can't take sqrt of %g", value);
1812 value = sqrt(value);
1822 double value = TOPn;
1825 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1831 (void)modf(value, &value);
1833 (void)modf(-value, &value);
1848 djSP; dTARGET; tryAMAGICun(abs);
1850 double value = TOPn;
1853 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1854 (iv = SvIVX(TOPs)) != IV_MIN) {
1876 XPUSHu(scan_hex(tmps, 99, &argtype));
1889 while (*tmps && isSPACE(*tmps))
1894 value = scan_hex(++tmps, 99, &argtype);
1895 else if (*tmps == 'b')
1896 value = scan_bin(++tmps, 99, &argtype);
1898 value = scan_oct(tmps, 99, &argtype);
1910 SETi( sv_len_utf8(TOPs) );
1914 SETi( sv_len(TOPs) );
1928 I32 lvalue = PL_op->op_flags & OPf_MOD;
1930 I32 arybase = PL_curcop->cop_arybase;
1934 SvTAINTED_off(TARG); /* decontaminate */
1938 repl = SvPV(sv, repl_len);
1945 tmps = SvPV(sv, curlen);
1947 utfcurlen = sv_len_utf8(sv);
1948 if (utfcurlen == curlen)
1956 if (pos >= arybase) {
1974 else if (len >= 0) {
1976 if (rem > (I32)curlen)
1990 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1991 warner(WARN_SUBSTR, "substr outside of string");
1996 sv_pos_u2b(sv, &pos, &rem);
1998 sv_setpvn(TARG, tmps, rem);
1999 if (lvalue) { /* it's an lvalue! */
2000 if (!SvGMAGICAL(sv)) {
2004 if (ckWARN(WARN_SUBSTR))
2006 "Attempt to use reference as lvalue in substr");
2008 if (SvOK(sv)) /* is it defined ? */
2009 (void)SvPOK_only(sv);
2011 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2014 if (SvTYPE(TARG) < SVt_PVLV) {
2015 sv_upgrade(TARG, SVt_PVLV);
2016 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2020 if (LvTARG(TARG) != sv) {
2022 SvREFCNT_dec(LvTARG(TARG));
2023 LvTARG(TARG) = SvREFCNT_inc(sv);
2025 LvTARGOFF(TARG) = pos;
2026 LvTARGLEN(TARG) = rem;
2029 sv_insert(sv, pos, rem, repl, repl_len);
2032 PUSHs(TARG); /* avoid SvSETMAGIC here */
2039 register I32 size = POPi;
2040 register I32 offset = POPi;
2041 register SV *src = POPs;
2042 I32 lvalue = PL_op->op_flags & OPf_MOD;
2044 unsigned char *s = (unsigned char*)SvPV(src, srclen);
2045 unsigned long retnum;
2048 SvTAINTED_off(TARG); /* decontaminate */
2049 offset *= size; /* turn into bit offset */
2050 len = (offset + size + 7) / 8;
2051 if (offset < 0 || size < 1)
2054 if (lvalue) { /* it's an lvalue! */
2055 if (SvTYPE(TARG) < SVt_PVLV) {
2056 sv_upgrade(TARG, SVt_PVLV);
2057 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2061 if (LvTARG(TARG) != src) {
2063 SvREFCNT_dec(LvTARG(TARG));
2064 LvTARG(TARG) = SvREFCNT_inc(src);
2066 LvTARGOFF(TARG) = offset;
2067 LvTARGLEN(TARG) = size;
2075 if (offset >= srclen)
2078 retnum = (unsigned long) s[offset] << 8;
2080 else if (size == 32) {
2081 if (offset >= srclen)
2083 else if (offset + 1 >= srclen)
2084 retnum = (unsigned long) s[offset] << 24;
2085 else if (offset + 2 >= srclen)
2086 retnum = ((unsigned long) s[offset] << 24) +
2087 ((unsigned long) s[offset + 1] << 16);
2089 retnum = ((unsigned long) s[offset] << 24) +
2090 ((unsigned long) s[offset + 1] << 16) +
2091 (s[offset + 2] << 8);
2096 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2101 else if (size == 16)
2102 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2103 else if (size == 32)
2104 retnum = ((unsigned long) s[offset] << 24) +
2105 ((unsigned long) s[offset + 1] << 16) +
2106 (s[offset + 2] << 8) + s[offset+3];
2110 sv_setuv(TARG, (UV)retnum);
2125 I32 arybase = PL_curcop->cop_arybase;
2130 offset = POPi - arybase;
2133 tmps = SvPV(big, biglen);
2134 if (IN_UTF8 && offset > 0)
2135 sv_pos_u2b(big, &offset, 0);
2138 else if (offset > biglen)
2140 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2141 (unsigned char*)tmps + biglen, little, 0)))
2144 retval = tmps2 - tmps;
2145 if (IN_UTF8 && retval > 0)
2146 sv_pos_b2u(big, &retval);
2147 PUSHi(retval + arybase);
2162 I32 arybase = PL_curcop->cop_arybase;
2168 tmps2 = SvPV(little, llen);
2169 tmps = SvPV(big, blen);
2173 if (IN_UTF8 && offset > 0)
2174 sv_pos_u2b(big, &offset, 0);
2175 offset = offset - arybase + llen;
2179 else if (offset > blen)
2181 if (!(tmps2 = rninstr(tmps, tmps + offset,
2182 tmps2, tmps2 + llen)))
2185 retval = tmps2 - tmps;
2186 if (IN_UTF8 && retval > 0)
2187 sv_pos_b2u(big, &retval);
2188 PUSHi(retval + arybase);
2194 djSP; dMARK; dORIGMARK; dTARGET;
2195 #ifdef USE_LOCALE_NUMERIC
2196 if (PL_op->op_private & OPpLOCALE)
2197 SET_NUMERIC_LOCAL();
2199 SET_NUMERIC_STANDARD();
2201 do_sprintf(TARG, SP-MARK, MARK+1);
2202 TAINT_IF(SvTAINTED(TARG));
2213 U8 *tmps = (U8*)POPpx;
2216 if (IN_UTF8 && (*tmps & 0x80))
2217 value = utf8_to_uv(tmps, &retlen);
2219 value = (UV)(*tmps & 255);
2230 (void)SvUPGRADE(TARG,SVt_PV);
2232 if (IN_UTF8 && value >= 128) {
2235 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2236 SvCUR_set(TARG, tmps - SvPVX(TARG));
2238 (void)SvPOK_only(TARG);
2248 (void)SvPOK_only(TARG);
2255 djSP; dTARGET; dPOPTOPssrl;
2258 char *tmps = SvPV(left, n_a);
2260 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2262 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2266 "The crypt() function is unimplemented due to excessive paranoia.");
2279 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2283 UV uv = utf8_to_uv(s, &ulen);
2285 if (PL_op->op_private & OPpLOCALE) {
2288 uv = toTITLE_LC_uni(uv);
2291 uv = toTITLE_utf8(s);
2293 tend = uv_to_utf8(tmpbuf, uv);
2295 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2297 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2298 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2302 s = (U8*)SvPV_force(sv, slen);
2303 Copy(tmpbuf, s, ulen, U8);
2308 if (!SvPADTMP(sv)) {
2314 s = (U8*)SvPV_force(sv, slen);
2316 if (PL_op->op_private & OPpLOCALE) {
2319 *s = toUPPER_LC(*s);
2335 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2339 UV uv = utf8_to_uv(s, &ulen);
2341 if (PL_op->op_private & OPpLOCALE) {
2344 uv = toLOWER_LC_uni(uv);
2347 uv = toLOWER_utf8(s);
2349 tend = uv_to_utf8(tmpbuf, uv);
2351 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2353 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2354 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2358 s = (U8*)SvPV_force(sv, slen);
2359 Copy(tmpbuf, s, ulen, U8);
2364 if (!SvPADTMP(sv)) {
2370 s = (U8*)SvPV_force(sv, slen);
2372 if (PL_op->op_private & OPpLOCALE) {
2375 *s = toLOWER_LC(*s);
2398 s = (U8*)SvPV(sv,len);
2400 sv_setpvn(TARG, "", 0);
2405 (void)SvUPGRADE(TARG, SVt_PV);
2406 SvGROW(TARG, (len * 2) + 1);
2407 (void)SvPOK_only(TARG);
2408 d = (U8*)SvPVX(TARG);
2410 if (PL_op->op_private & OPpLOCALE) {
2414 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2420 d = uv_to_utf8(d, toUPPER_utf8( s ));
2425 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2430 if (!SvPADTMP(sv)) {
2437 s = (U8*)SvPV_force(sv, len);
2439 register U8 *send = s + len;
2441 if (PL_op->op_private & OPpLOCALE) {
2444 for (; s < send; s++)
2445 *s = toUPPER_LC(*s);
2448 for (; s < send; s++)
2468 s = (U8*)SvPV(sv,len);
2470 sv_setpvn(TARG, "", 0);
2475 (void)SvUPGRADE(TARG, SVt_PV);
2476 SvGROW(TARG, (len * 2) + 1);
2477 (void)SvPOK_only(TARG);
2478 d = (U8*)SvPVX(TARG);
2480 if (PL_op->op_private & OPpLOCALE) {
2484 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2490 d = uv_to_utf8(d, toLOWER_utf8(s));
2495 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2500 if (!SvPADTMP(sv)) {
2507 s = (U8*)SvPV_force(sv, len);
2509 register U8 *send = s + len;
2511 if (PL_op->op_private & OPpLOCALE) {
2514 for (; s < send; s++)
2515 *s = toLOWER_LC(*s);
2518 for (; s < send; s++)
2530 register char *s = SvPV(sv,len);
2534 (void)SvUPGRADE(TARG, SVt_PV);
2535 SvGROW(TARG, (len * 2) + 1);
2540 STRLEN ulen = UTF8SKIP(s);
2563 SvCUR_set(TARG, d - SvPVX(TARG));
2564 (void)SvPOK_only(TARG);
2567 sv_setpvn(TARG, s, len);
2576 djSP; dMARK; dORIGMARK;
2578 register AV* av = (AV*)POPs;
2579 register I32 lval = PL_op->op_flags & OPf_MOD;
2580 I32 arybase = PL_curcop->cop_arybase;
2583 if (SvTYPE(av) == SVt_PVAV) {
2584 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2586 for (svp = MARK + 1; svp <= SP; svp++) {
2591 if (max > AvMAX(av))
2594 while (++MARK <= SP) {
2595 elem = SvIVx(*MARK);
2599 svp = av_fetch(av, elem, lval);
2601 if (!svp || *svp == &PL_sv_undef)
2602 DIE(PL_no_aelem, elem);
2603 if (PL_op->op_private & OPpLVAL_INTRO)
2604 save_aelem(av, elem, svp);
2606 *MARK = svp ? *svp : &PL_sv_undef;
2609 if (GIMME != G_ARRAY) {
2617 /* Associative arrays. */
2622 HV *hash = (HV*)POPs;
2624 I32 gimme = GIMME_V;
2625 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2628 /* might clobber stack_sp */
2629 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2634 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2635 if (gimme == G_ARRAY) {
2637 /* might clobber stack_sp */
2638 sv_setsv(TARG, realhv ?
2639 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2644 else if (gimme == G_SCALAR)
2663 I32 gimme = GIMME_V;
2664 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2668 if (PL_op->op_private & OPpSLICE) {
2672 hvtype = SvTYPE(hv);
2673 while (++MARK <= SP) {
2674 if (hvtype == SVt_PVHV)
2675 sv = hv_delete_ent(hv, *MARK, discard, 0);
2677 DIE("Not a HASH reference");
2678 *MARK = sv ? sv : &PL_sv_undef;
2682 else if (gimme == G_SCALAR) {
2691 if (SvTYPE(hv) == SVt_PVHV)
2692 sv = hv_delete_ent(hv, keysv, discard, 0);
2694 DIE("Not a HASH reference");
2708 if (SvTYPE(hv) == SVt_PVHV) {
2709 if (hv_exists_ent(hv, tmpsv, 0))
2712 else if (SvTYPE(hv) == SVt_PVAV) {
2713 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2717 DIE("Not a HASH reference");
2724 djSP; dMARK; dORIGMARK;
2725 register HV *hv = (HV*)POPs;
2726 register I32 lval = PL_op->op_flags & OPf_MOD;
2727 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2729 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2730 DIE("Can't localize pseudo-hash element");
2732 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2733 while (++MARK <= SP) {
2737 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2738 svp = he ? &HeVAL(he) : 0;
2741 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2744 if (!svp || *svp == &PL_sv_undef) {
2746 DIE(PL_no_helem, SvPV(keysv, n_a));
2748 if (PL_op->op_private & OPpLVAL_INTRO)
2749 save_helem(hv, keysv, svp);
2751 *MARK = svp ? *svp : &PL_sv_undef;
2754 if (GIMME != G_ARRAY) {
2762 /* List operators. */
2767 if (GIMME != G_ARRAY) {
2769 *MARK = *SP; /* unwanted list, return last item */
2771 *MARK = &PL_sv_undef;
2780 SV **lastrelem = PL_stack_sp;
2781 SV **lastlelem = PL_stack_base + POPMARK;
2782 SV **firstlelem = PL_stack_base + POPMARK + 1;
2783 register SV **firstrelem = lastlelem + 1;
2784 I32 arybase = PL_curcop->cop_arybase;
2785 I32 lval = PL_op->op_flags & OPf_MOD;
2786 I32 is_something_there = lval;
2788 register I32 max = lastrelem - lastlelem;
2789 register SV **lelem;
2792 if (GIMME != G_ARRAY) {
2793 ix = SvIVx(*lastlelem);
2798 if (ix < 0 || ix >= max)
2799 *firstlelem = &PL_sv_undef;
2801 *firstlelem = firstrelem[ix];
2807 SP = firstlelem - 1;
2811 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2816 *lelem = &PL_sv_undef;
2817 else if (!(*lelem = firstrelem[ix]))
2818 *lelem = &PL_sv_undef;
2822 if (ix >= max || !(*lelem = firstrelem[ix]))
2823 *lelem = &PL_sv_undef;
2825 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2826 is_something_there = TRUE;
2828 if (is_something_there)
2831 SP = firstlelem - 1;
2837 djSP; dMARK; dORIGMARK;
2838 I32 items = SP - MARK;
2839 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2840 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2847 djSP; dMARK; dORIGMARK;
2848 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2852 SV *val = NEWSV(46, 0);
2854 sv_setsv(val, *++MARK);
2855 else if (ckWARN(WARN_UNSAFE))
2856 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2857 (void)hv_store_ent(hv,key,val,0);
2866 djSP; dMARK; dORIGMARK;
2867 register AV *ary = (AV*)*++MARK;
2871 register I32 offset;
2872 register I32 length;
2879 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2880 *MARK-- = SvTIED_obj((SV*)ary, mg);
2884 perl_call_method("SPLICE",GIMME_V);
2893 offset = i = SvIVx(*MARK);
2895 offset += AvFILLp(ary) + 1;
2897 offset -= PL_curcop->cop_arybase;
2899 DIE(PL_no_aelem, i);
2901 length = SvIVx(*MARK++);
2903 length += AvFILLp(ary) - offset + 1;
2909 length = AvMAX(ary) + 1; /* close enough to infinity */
2913 length = AvMAX(ary) + 1;
2915 if (offset > AvFILLp(ary) + 1)
2916 offset = AvFILLp(ary) + 1;
2917 after = AvFILLp(ary) + 1 - (offset + length);
2918 if (after < 0) { /* not that much array */
2919 length += after; /* offset+length now in array */
2925 /* At this point, MARK .. SP-1 is our new LIST */
2928 diff = newlen - length;
2929 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2932 if (diff < 0) { /* shrinking the area */
2934 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2935 Copy(MARK, tmparyval, newlen, SV*);
2938 MARK = ORIGMARK + 1;
2939 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2940 MEXTEND(MARK, length);
2941 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2943 EXTEND_MORTAL(length);
2944 for (i = length, dst = MARK; i; i--) {
2945 sv_2mortal(*dst); /* free them eventualy */
2952 *MARK = AvARRAY(ary)[offset+length-1];
2955 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2956 SvREFCNT_dec(*dst++); /* free them now */
2959 AvFILLp(ary) += diff;
2961 /* pull up or down? */
2963 if (offset < after) { /* easier to pull up */
2964 if (offset) { /* esp. if nothing to pull */
2965 src = &AvARRAY(ary)[offset-1];
2966 dst = src - diff; /* diff is negative */
2967 for (i = offset; i > 0; i--) /* can't trust Copy */
2971 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2975 if (after) { /* anything to pull down? */
2976 src = AvARRAY(ary) + offset + length;
2977 dst = src + diff; /* diff is negative */
2978 Move(src, dst, after, SV*);
2980 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2981 /* avoid later double free */
2985 dst[--i] = &PL_sv_undef;
2988 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2990 *dst = NEWSV(46, 0);
2991 sv_setsv(*dst++, *src++);
2993 Safefree(tmparyval);
2996 else { /* no, expanding (or same) */
2998 New(452, tmparyval, length, SV*); /* so remember deletion */
2999 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3002 if (diff > 0) { /* expanding */
3004 /* push up or down? */
3006 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3010 Move(src, dst, offset, SV*);
3012 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3014 AvFILLp(ary) += diff;
3017 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3018 av_extend(ary, AvFILLp(ary) + diff);
3019 AvFILLp(ary) += diff;
3022 dst = AvARRAY(ary) + AvFILLp(ary);
3024 for (i = after; i; i--) {
3031 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3032 *dst = NEWSV(46, 0);
3033 sv_setsv(*dst++, *src++);
3035 MARK = ORIGMARK + 1;
3036 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3038 Copy(tmparyval, MARK, length, SV*);
3040 EXTEND_MORTAL(length);
3041 for (i = length, dst = MARK; i; i--) {
3042 sv_2mortal(*dst); /* free them eventualy */
3046 Safefree(tmparyval);
3050 else if (length--) {
3051 *MARK = tmparyval[length];
3054 while (length-- > 0)
3055 SvREFCNT_dec(tmparyval[length]);
3057 Safefree(tmparyval);
3060 *MARK = &PL_sv_undef;
3068 djSP; dMARK; dORIGMARK; dTARGET;
3069 register AV *ary = (AV*)*++MARK;
3070 register SV *sv = &PL_sv_undef;
3073 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3074 *MARK-- = SvTIED_obj((SV*)ary, mg);
3078 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3083 /* Why no pre-extend of ary here ? */
3084 for (++MARK; MARK <= SP; MARK++) {
3087 sv_setsv(sv, *MARK);
3092 PUSHi( AvFILL(ary) + 1 );
3100 SV *sv = av_pop(av);
3102 (void)sv_2mortal(sv);
3111 SV *sv = av_shift(av);
3116 (void)sv_2mortal(sv);
3123 djSP; dMARK; dORIGMARK; dTARGET;
3124 register AV *ary = (AV*)*++MARK;
3129 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3130 *MARK-- = SvTIED_obj((SV*)ary, mg);
3134 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3139 av_unshift(ary, SP - MARK);
3142 sv_setsv(sv, *++MARK);
3143 (void)av_store(ary, i++, sv);
3147 PUSHi( AvFILL(ary) + 1 );
3157 if (GIMME == G_ARRAY) {
3168 register char *down;
3174 do_join(TARG, &PL_sv_no, MARK, SP);
3176 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3177 up = SvPV_force(TARG, len);
3179 if (IN_UTF8) { /* first reverse each character */
3180 U8* s = (U8*)SvPVX(TARG);
3181 U8* send = (U8*)(s + len);
3190 down = (char*)(s - 1);
3191 if (s > send || !((*down & 0xc0) == 0x80)) {
3192 warn("Malformed UTF-8 character");
3204 down = SvPVX(TARG) + len - 1;
3210 (void)SvPOK_only(TARG);
3219 mul128(SV *sv, U8 m)
3222 char *s = SvPV(sv, len);
3226 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3227 SV *tmpNew = newSVpvn("0000000000", 10);
3229 sv_catsv(tmpNew, sv);
3230 SvREFCNT_dec(sv); /* free old sv */
3235 while (!*t) /* trailing '\0'? */
3238 i = ((*t - '0') << 7) + m;
3239 *(t--) = '0' + (i % 10);
3245 /* Explosives and implosives. */
3247 #if 'I' == 73 && 'J' == 74
3248 /* On an ASCII/ISO kind of system */
3249 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3252 Some other sort of character set - use memchr() so we don't match
3255 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3263 I32 gimme = GIMME_V;
3267 register char *pat = SvPV(left, llen);
3268 register char *s = SvPV(right, rlen);
3269 char *strend = s + rlen;
3271 register char *patend = pat + llen;
3276 /* These must not be in registers: */
3293 register U32 culong;
3296 #ifdef PERL_NATINT_PACK
3297 int natint; /* native integer */
3298 int unatint; /* unsigned native integer */
3301 if (gimme != G_ARRAY) { /* arrange to do first one only */
3303 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3304 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3306 while (isDIGIT(*patend) || *patend == '*')
3312 while (pat < patend) {
3314 datumtype = *pat++ & 0xFF;
3315 #ifdef PERL_NATINT_PACK
3318 if (isSPACE(datumtype))
3321 char *natstr = "sSiIlL";
3323 if (strchr(natstr, datumtype)) {
3324 #ifdef PERL_NATINT_PACK
3330 croak("'!' allowed only after types %s", natstr);
3334 else if (*pat == '*') {
3335 len = strend - strbeg; /* long enough */
3338 else if (isDIGIT(*pat)) {
3340 while (isDIGIT(*pat))
3341 len = (len * 10) + (*pat++ - '0');
3344 len = (datumtype != '@');
3347 croak("Invalid type in unpack: '%c'", (int)datumtype);
3348 case ',': /* grandfather in commas but with a warning */
3349 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3350 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3353 if (len == 1 && pat[-1] != '1')
3362 if (len > strend - strbeg)
3363 DIE("@ outside of string");
3367 if (len > s - strbeg)
3368 DIE("X outside of string");
3372 if (len > strend - s)
3373 DIE("x outside of string");
3379 if (len > strend - s)
3382 goto uchar_checksum;
3383 sv = NEWSV(35, len);
3384 sv_setpvn(sv, s, len);
3386 if (datumtype == 'A' || datumtype == 'Z') {
3387 aptr = s; /* borrow register */
3388 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3393 else { /* 'A' strips both nulls and spaces */
3394 s = SvPVX(sv) + len - 1;
3395 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3399 SvCUR_set(sv, s - SvPVX(sv));
3400 s = aptr; /* unborrow register */
3402 XPUSHs(sv_2mortal(sv));
3406 if (pat[-1] == '*' || len > (strend - s) * 8)
3407 len = (strend - s) * 8;
3410 Newz(601, PL_bitcount, 256, char);
3411 for (bits = 1; bits < 256; bits++) {
3412 if (bits & 1) PL_bitcount[bits]++;
3413 if (bits & 2) PL_bitcount[bits]++;
3414 if (bits & 4) PL_bitcount[bits]++;
3415 if (bits & 8) PL_bitcount[bits]++;
3416 if (bits & 16) PL_bitcount[bits]++;
3417 if (bits & 32) PL_bitcount[bits]++;
3418 if (bits & 64) PL_bitcount[bits]++;
3419 if (bits & 128) PL_bitcount[bits]++;
3423 culong += PL_bitcount[*(unsigned char*)s++];
3428 if (datumtype == 'b') {
3430 if (bits & 1) culong++;
3436 if (bits & 128) culong++;
3443 sv = NEWSV(35, len + 1);
3446 aptr = pat; /* borrow register */
3448 if (datumtype == 'b') {
3450 for (len = 0; len < aint; len++) {
3451 if (len & 7) /*SUPPRESS 595*/
3455 *pat++ = '0' + (bits & 1);
3460 for (len = 0; len < aint; len++) {
3465 *pat++ = '0' + ((bits & 128) != 0);
3469 pat = aptr; /* unborrow register */
3470 XPUSHs(sv_2mortal(sv));
3474 if (pat[-1] == '*' || len > (strend - s) * 2)
3475 len = (strend - s) * 2;
3476 sv = NEWSV(35, len + 1);
3479 aptr = pat; /* borrow register */
3481 if (datumtype == 'h') {
3483 for (len = 0; len < aint; len++) {
3488 *pat++ = PL_hexdigit[bits & 15];
3493 for (len = 0; len < aint; len++) {
3498 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3502 pat = aptr; /* unborrow register */
3503 XPUSHs(sv_2mortal(sv));
3506 if (len > strend - s)
3511 if (aint >= 128) /* fake up signed chars */
3521 if (aint >= 128) /* fake up signed chars */
3524 sv_setiv(sv, (IV)aint);
3525 PUSHs(sv_2mortal(sv));
3530 if (len > strend - s)
3545 sv_setiv(sv, (IV)auint);
3546 PUSHs(sv_2mortal(sv));
3551 if (len > strend - s)
3554 while (len-- > 0 && s < strend) {
3555 auint = utf8_to_uv((U8*)s, &along);
3558 cdouble += (double)auint;
3566 while (len-- > 0 && s < strend) {
3567 auint = utf8_to_uv((U8*)s, &along);
3570 sv_setuv(sv, (UV)auint);
3571 PUSHs(sv_2mortal(sv));
3576 #if SHORTSIZE == SIZE16
3577 along = (strend - s) / SIZE16;
3579 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3584 #if SHORTSIZE != SIZE16
3587 COPYNN(s, &ashort, sizeof(short));
3598 #if SHORTSIZE > SIZE16
3610 #if SHORTSIZE != SIZE16
3613 COPYNN(s, &ashort, sizeof(short));
3616 sv_setiv(sv, (IV)ashort);
3617 PUSHs(sv_2mortal(sv));
3625 #if SHORTSIZE > SIZE16
3631 sv_setiv(sv, (IV)ashort);
3632 PUSHs(sv_2mortal(sv));
3640 #if SHORTSIZE == SIZE16
3641 along = (strend - s) / SIZE16;
3643 unatint = natint && datumtype == 'S';
3644 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3649 #if SHORTSIZE != SIZE16
3652 COPYNN(s, &aushort, sizeof(unsigned short));
3653 s += sizeof(unsigned short);
3661 COPY16(s, &aushort);
3664 if (datumtype == 'n')
3665 aushort = PerlSock_ntohs(aushort);
3668 if (datumtype == 'v')
3669 aushort = vtohs(aushort);
3678 #if SHORTSIZE != SIZE16
3681 COPYNN(s, &aushort, sizeof(unsigned short));
3682 s += sizeof(unsigned short);
3684 sv_setiv(sv, (UV)aushort);
3685 PUSHs(sv_2mortal(sv));
3692 COPY16(s, &aushort);
3696 if (datumtype == 'n')
3697 aushort = PerlSock_ntohs(aushort);
3700 if (datumtype == 'v')
3701 aushort = vtohs(aushort);
3703 sv_setiv(sv, (UV)aushort);
3704 PUSHs(sv_2mortal(sv));
3710 along = (strend - s) / sizeof(int);
3715 Copy(s, &aint, 1, int);
3718 cdouble += (double)aint;
3727 Copy(s, &aint, 1, int);
3731 /* Without the dummy below unpack("i", pack("i",-1))
3732 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3733 * cc with optimization turned on.
3735 * The bug was detected in
3736 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3737 * with optimization (-O4) turned on.
3738 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3739 * does not have this problem even with -O4.
3741 * This bug was reported as DECC_BUGS 1431
3742 * and tracked internally as GEM_BUGS 7775.
3744 * The bug is fixed in
3745 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3746 * UNIX V4.0F support: DEC C V5.9-006 or later
3747 * UNIX V4.0E support: DEC C V5.8-011 or later
3750 * See also few lines later for the same bug.
3753 sv_setiv(sv, (IV)aint) :
3755 sv_setiv(sv, (IV)aint);
3756 PUSHs(sv_2mortal(sv));
3761 along = (strend - s) / sizeof(unsigned int);
3766 Copy(s, &auint, 1, unsigned int);
3767 s += sizeof(unsigned int);
3769 cdouble += (double)auint;
3778 Copy(s, &auint, 1, unsigned int);
3779 s += sizeof(unsigned int);
3782 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3783 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3784 * See details few lines earlier. */
3786 sv_setuv(sv, (UV)auint) :
3788 sv_setuv(sv, (UV)auint);
3789 PUSHs(sv_2mortal(sv));
3794 #if LONGSIZE == SIZE32
3795 along = (strend - s) / SIZE32;
3797 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3802 #if LONGSIZE != SIZE32
3805 COPYNN(s, &along, sizeof(long));
3808 cdouble += (double)along;
3818 #if LONGSIZE > SIZE32
3819 if (along > 2147483647)
3820 along -= 4294967296;
3824 cdouble += (double)along;
3833 #if LONGSIZE != SIZE32
3836 COPYNN(s, &along, sizeof(long));
3839 sv_setiv(sv, (IV)along);
3840 PUSHs(sv_2mortal(sv));
3848 #if LONGSIZE > SIZE32
3849 if (along > 2147483647)
3850 along -= 4294967296;
3854 sv_setiv(sv, (IV)along);
3855 PUSHs(sv_2mortal(sv));
3863 #if LONGSIZE == SIZE32
3864 along = (strend - s) / SIZE32;
3866 unatint = natint && datumtype == 'L';
3867 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3872 #if LONGSIZE != SIZE32
3875 COPYNN(s, &aulong, sizeof(unsigned long));
3876 s += sizeof(unsigned long);
3878 cdouble += (double)aulong;
3890 if (datumtype == 'N')
3891 aulong = PerlSock_ntohl(aulong);
3894 if (datumtype == 'V')
3895 aulong = vtohl(aulong);
3898 cdouble += (double)aulong;
3907 #if LONGSIZE != SIZE32
3910 COPYNN(s, &aulong, sizeof(unsigned long));
3911 s += sizeof(unsigned long);
3913 sv_setuv(sv, (UV)aulong);
3914 PUSHs(sv_2mortal(sv));
3924 if (datumtype == 'N')
3925 aulong = PerlSock_ntohl(aulong);
3928 if (datumtype == 'V')
3929 aulong = vtohl(aulong);
3932 sv_setuv(sv, (UV)aulong);
3933 PUSHs(sv_2mortal(sv));
3939 along = (strend - s) / sizeof(char*);
3945 if (sizeof(char*) > strend - s)
3948 Copy(s, &aptr, 1, char*);
3954 PUSHs(sv_2mortal(sv));
3964 while ((len > 0) && (s < strend)) {
3965 auv = (auv << 7) | (*s & 0x7f);
3966 if (!(*s++ & 0x80)) {
3970 PUSHs(sv_2mortal(sv));
3974 else if (++bytes >= sizeof(UV)) { /* promote to string */
3978 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3979 while (s < strend) {
3980 sv = mul128(sv, *s & 0x7f);
3981 if (!(*s++ & 0x80)) {
3990 PUSHs(sv_2mortal(sv));
3995 if ((s >= strend) && bytes)
3996 croak("Unterminated compressed integer");
4001 if (sizeof(char*) > strend - s)
4004 Copy(s, &aptr, 1, char*);
4009 sv_setpvn(sv, aptr, len);
4010 PUSHs(sv_2mortal(sv));
4014 along = (strend - s) / sizeof(Quad_t);
4020 if (s + sizeof(Quad_t) > strend)
4023 Copy(s, &aquad, 1, Quad_t);
4024 s += sizeof(Quad_t);
4027 if (aquad >= IV_MIN && aquad <= IV_MAX)
4028 sv_setiv(sv, (IV)aquad);
4030 sv_setnv(sv, (double)aquad);
4031 PUSHs(sv_2mortal(sv));
4035 along = (strend - s) / sizeof(Quad_t);
4041 if (s + sizeof(Uquad_t) > strend)
4044 Copy(s, &auquad, 1, Uquad_t);
4045 s += sizeof(Uquad_t);
4048 if (auquad <= UV_MAX)
4049 sv_setuv(sv, (UV)auquad);
4051 sv_setnv(sv, (double)auquad);
4052 PUSHs(sv_2mortal(sv));
4056 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4059 along = (strend - s) / sizeof(float);
4064 Copy(s, &afloat, 1, float);
4073 Copy(s, &afloat, 1, float);
4076 sv_setnv(sv, (double)afloat);
4077 PUSHs(sv_2mortal(sv));
4083 along = (strend - s) / sizeof(double);
4088 Copy(s, &adouble, 1, double);
4089 s += sizeof(double);
4097 Copy(s, &adouble, 1, double);
4098 s += sizeof(double);
4100 sv_setnv(sv, (double)adouble);
4101 PUSHs(sv_2mortal(sv));
4107 * Initialise the decode mapping. By using a table driven
4108 * algorithm, the code will be character-set independent
4109 * (and just as fast as doing character arithmetic)
4111 if (PL_uudmap['M'] == 0) {
4114 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4115 PL_uudmap[PL_uuemap[i]] = i;
4117 * Because ' ' and '`' map to the same value,
4118 * we need to decode them both the same.
4123 along = (strend - s) * 3 / 4;
4124 sv = NEWSV(42, along);
4127 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4132 len = PL_uudmap[*s++] & 077;
4134 if (s < strend && ISUUCHAR(*s))
4135 a = PL_uudmap[*s++] & 077;
4138 if (s < strend && ISUUCHAR(*s))
4139 b = PL_uudmap[*s++] & 077;
4142 if (s < strend && ISUUCHAR(*s))
4143 c = PL_uudmap[*s++] & 077;
4146 if (s < strend && ISUUCHAR(*s))
4147 d = PL_uudmap[*s++] & 077;
4150 hunk[0] = (a << 2) | (b >> 4);
4151 hunk[1] = (b << 4) | (c >> 2);
4152 hunk[2] = (c << 6) | d;
4153 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4158 else if (s[1] == '\n') /* possible checksum byte */
4161 XPUSHs(sv_2mortal(sv));
4166 if (strchr("fFdD", datumtype) ||
4167 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4171 while (checksum >= 16) {
4175 while (checksum >= 4) {
4181 along = (1 << checksum) - 1;
4182 while (cdouble < 0.0)
4184 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4185 sv_setnv(sv, cdouble);
4188 if (checksum < 32) {
4189 aulong = (1 << checksum) - 1;
4192 sv_setuv(sv, (UV)culong);
4194 XPUSHs(sv_2mortal(sv));
4198 if (SP == oldsp && gimme == G_SCALAR)
4199 PUSHs(&PL_sv_undef);
4204 doencodes(register SV *sv, register char *s, register I32 len)
4208 *hunk = PL_uuemap[len];
4209 sv_catpvn(sv, hunk, 1);
4212 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4213 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4214 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4215 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4216 sv_catpvn(sv, hunk, 4);
4221 char r = (len > 1 ? s[1] : '\0');
4222 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4223 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4224 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4225 hunk[3] = PL_uuemap[0];
4226 sv_catpvn(sv, hunk, 4);
4228 sv_catpvn(sv, "\n", 1);
4232 is_an_int(char *s, STRLEN l)
4235 SV *result = newSVpvn(s, l);
4236 char *result_c = SvPV(result, n_a); /* convenience */
4237 char *out = result_c;
4247 SvREFCNT_dec(result);
4270 SvREFCNT_dec(result);
4276 SvCUR_set(result, out - result_c);
4281 div128(SV *pnum, bool *done)
4282 /* must be '\0' terminated */
4286 char *s = SvPV(pnum, len);
4295 i = m * 10 + (*t - '0');
4297 r = (i >> 7); /* r < 10 */
4304 SvCUR_set(pnum, (STRLEN) (t - s));
4311 djSP; dMARK; dORIGMARK; dTARGET;
4312 register SV *cat = TARG;
4315 register char *pat = SvPVx(*++MARK, fromlen);
4316 register char *patend = pat + fromlen;
4321 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4322 static char *space10 = " ";
4324 /* These must not be in registers: */
4339 #ifdef PERL_NATINT_PACK
4340 int natint; /* native integer */
4345 sv_setpvn(cat, "", 0);
4346 while (pat < patend) {
4347 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4348 datumtype = *pat++ & 0xFF;
4349 #ifdef PERL_NATINT_PACK
4352 if (isSPACE(datumtype))
4355 char *natstr = "sSiIlL";
4357 if (strchr(natstr, datumtype)) {
4358 #ifdef PERL_NATINT_PACK
4364 croak("'!' allowed only after types %s", natstr);
4367 len = strchr("@Xxu", datumtype) ? 0 : items;
4370 else if (isDIGIT(*pat)) {
4372 while (isDIGIT(*pat))
4373 len = (len * 10) + (*pat++ - '0');
4379 croak("Invalid type in pack: '%c'", (int)datumtype);
4380 case ',': /* grandfather in commas but with a warning */
4381 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4382 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4385 DIE("%% may only be used in unpack");
4396 if (SvCUR(cat) < len)
4397 DIE("X outside of string");
4404 sv_catpvn(cat, null10, 10);
4407 sv_catpvn(cat, null10, len);
4413 aptr = SvPV(fromstr, fromlen);
4417 sv_catpvn(cat, aptr, len);
4419 sv_catpvn(cat, aptr, fromlen);
4421 if (datumtype == 'A') {
4423 sv_catpvn(cat, space10, 10);
4426 sv_catpvn(cat, space10, len);
4430 sv_catpvn(cat, null10, 10);
4433 sv_catpvn(cat, null10, len);
4440 char *savepat = pat;
4445 aptr = SvPV(fromstr, fromlen);
4450 SvCUR(cat) += (len+7)/8;
4451 SvGROW(cat, SvCUR(cat) + 1);
4452 aptr = SvPVX(cat) + aint;
4457 if (datumtype == 'B') {
4458 for (len = 0; len++ < aint;) {
4459 items |= *pat++ & 1;
4463 *aptr++ = items & 0xff;
4469 for (len = 0; len++ < aint;) {
4475 *aptr++ = items & 0xff;
4481 if (datumtype == 'B')
4482 items <<= 7 - (aint & 7);
4484 items >>= 7 - (aint & 7);
4485 *aptr++ = items & 0xff;
4487 pat = SvPVX(cat) + SvCUR(cat);
4498 char *savepat = pat;
4503 aptr = SvPV(fromstr, fromlen);
4508 SvCUR(cat) += (len+1)/2;
4509 SvGROW(cat, SvCUR(cat) + 1);
4510 aptr = SvPVX(cat) + aint;
4515 if (datumtype == 'H') {
4516 for (len = 0; len++ < aint;) {
4518 items |= ((*pat++ & 15) + 9) & 15;
4520 items |= *pat++ & 15;
4524 *aptr++ = items & 0xff;
4530 for (len = 0; len++ < aint;) {
4532 items |= (((*pat++ & 15) + 9) & 15) << 4;
4534 items |= (*pat++ & 15) << 4;
4538 *aptr++ = items & 0xff;
4544 *aptr++ = items & 0xff;
4545 pat = SvPVX(cat) + SvCUR(cat);
4557 aint = SvIV(fromstr);
4559 sv_catpvn(cat, &achar, sizeof(char));
4565 auint = SvUV(fromstr);
4566 SvGROW(cat, SvCUR(cat) + 10);
4567 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4572 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4577 afloat = (float)SvNV(fromstr);
4578 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4585 adouble = (double)SvNV(fromstr);
4586 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4592 ashort = (I16)SvIV(fromstr);
4594 ashort = PerlSock_htons(ashort);
4596 CAT16(cat, &ashort);
4602 ashort = (I16)SvIV(fromstr);
4604 ashort = htovs(ashort);
4606 CAT16(cat, &ashort);
4610 #if SHORTSIZE != SIZE16
4612 unsigned short aushort;
4616 aushort = SvUV(fromstr);
4617 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4627 aushort = (U16)SvUV(fromstr);
4628 CAT16(cat, &aushort);
4634 #if SHORTSIZE != SIZE16
4638 ashort = SvIV(fromstr);
4639 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4647 ashort = (I16)SvIV(fromstr);
4648 CAT16(cat, &ashort);
4655 auint = SvUV(fromstr);
4656 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4662 adouble = floor(SvNV(fromstr));
4665 croak("Cannot compress negative numbers");
4671 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4672 adouble <= UV_MAX_cxux
4679 char buf[1 + sizeof(UV)];
4680 char *in = buf + sizeof(buf);
4681 UV auv = U_V(adouble);;
4684 *--in = (auv & 0x7f) | 0x80;
4687 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4688 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4690 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4691 char *from, *result, *in;
4696 /* Copy string and check for compliance */
4697 from = SvPV(fromstr, len);
4698 if ((norm = is_an_int(from, len)) == NULL)
4699 croak("can compress only unsigned integer");
4701 New('w', result, len, char);
4705 *--in = div128(norm, &done) | 0x80;
4706 result[len - 1] &= 0x7F; /* clear continue bit */
4707 sv_catpvn(cat, in, (result + len) - in);
4709 SvREFCNT_dec(norm); /* free norm */
4711 else if (SvNOKp(fromstr)) {
4712 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4713 char *in = buf + sizeof(buf);
4716 double next = floor(adouble / 128);
4717 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4718 if (--in < buf) /* this cannot happen ;-) */
4719 croak ("Cannot compress integer");
4721 } while (adouble > 0);
4722 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4723 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4726 croak("Cannot compress non integer");
4732 aint = SvIV(fromstr);
4733 sv_catpvn(cat, (char*)&aint, sizeof(int));
4739 aulong = SvUV(fromstr);
4741 aulong = PerlSock_htonl(aulong);
4743 CAT32(cat, &aulong);
4749 aulong = SvUV(fromstr);
4751 aulong = htovl(aulong);
4753 CAT32(cat, &aulong);
4757 #if LONGSIZE != SIZE32
4761 aulong = SvUV(fromstr);
4762 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4770 aulong = SvUV(fromstr);
4771 CAT32(cat, &aulong);
4776 #if LONGSIZE != SIZE32
4780 along = SvIV(fromstr);
4781 sv_catpvn(cat, (char *)&along, sizeof(long));
4789 along = SvIV(fromstr);
4798 auquad = (Uquad_t)SvIV(fromstr);
4799 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4805 aquad = (Quad_t)SvIV(fromstr);
4806 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4809 #endif /* HAS_QUAD */
4811 len = 1; /* assume SV is correct length */
4816 if (fromstr == &PL_sv_undef)
4820 /* XXX better yet, could spirit away the string to
4821 * a safe spot and hang on to it until the result
4822 * of pack() (and all copies of the result) are
4825 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4827 "Attempt to pack pointer to temporary value");
4828 if (SvPOK(fromstr) || SvNIOK(fromstr))
4829 aptr = SvPV(fromstr,n_a);
4831 aptr = SvPV_force(fromstr,n_a);
4833 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4838 aptr = SvPV(fromstr, fromlen);
4839 SvGROW(cat, fromlen * 4 / 3);
4844 while (fromlen > 0) {
4851 doencodes(cat, aptr, todo);
4870 register I32 limit = POPi; /* note, negative is forever */
4873 register char *s = SvPV(sv, len);
4874 char *strend = s + len;
4876 register REGEXP *rx;
4880 I32 maxiters = (strend - s) + 10;
4883 I32 origlimit = limit;
4886 AV *oldstack = PL_curstack;
4887 I32 gimme = GIMME_V;
4888 I32 oldsave = PL_savestack_ix;
4889 I32 make_mortal = 1;
4890 MAGIC *mg = (MAGIC *) NULL;
4893 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4898 DIE("panic: do_split");
4899 rx = pm->op_pmregexp;
4901 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4902 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4904 if (pm->op_pmreplroot)
4905 ary = GvAVn((GV*)pm->op_pmreplroot);
4906 else if (gimme != G_ARRAY)
4908 ary = (AV*)PL_curpad[0];
4910 ary = GvAVn(PL_defgv);
4911 #endif /* USE_THREADS */
4914 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4920 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4922 XPUSHs(SvTIED_obj((SV*)ary, mg));
4927 for (i = AvFILLp(ary); i >= 0; i--)
4928 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4930 /* temporarily switch stacks */
4931 SWITCHSTACK(PL_curstack, ary);
4935 base = SP - PL_stack_base;
4937 if (pm->op_pmflags & PMf_SKIPWHITE) {
4938 if (pm->op_pmflags & PMf_LOCALE) {
4939 while (isSPACE_LC(*s))
4947 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4948 SAVEINT(PL_multiline);
4949 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4953 limit = maxiters + 2;
4954 if (pm->op_pmflags & PMf_WHITE) {
4957 while (m < strend &&
4958 !((pm->op_pmflags & PMf_LOCALE)
4959 ? isSPACE_LC(*m) : isSPACE(*m)))
4964 dstr = NEWSV(30, m-s);
4965 sv_setpvn(dstr, s, m-s);
4971 while (s < strend &&
4972 ((pm->op_pmflags & PMf_LOCALE)
4973 ? isSPACE_LC(*s) : isSPACE(*s)))
4977 else if (strEQ("^", rx->precomp)) {
4980 for (m = s; m < strend && *m != '\n'; m++) ;
4984 dstr = NEWSV(30, m-s);
4985 sv_setpvn(dstr, s, m-s);
4992 else if (rx->check_substr && !rx->nparens
4993 && (rx->reganch & ROPT_CHECK_ALL)
4994 && !(rx->reganch & ROPT_ANCH)) {
4995 i = SvCUR(rx->check_substr);
4996 if (i == 1 && !SvTAIL(rx->check_substr)) {
4997 i = *SvPVX(rx->check_substr);
5000 for (m = s; m < strend && *m != i; m++) ;
5003 dstr = NEWSV(30, m-s);
5004 sv_setpvn(dstr, s, m-s);
5013 while (s < strend && --limit &&
5014 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
5015 rx->check_substr, 0)) )
5018 dstr = NEWSV(31, m-s);
5019 sv_setpvn(dstr, s, m-s);
5028 maxiters += (strend - s) * rx->nparens;
5029 while (s < strend && --limit &&
5030 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
5032 TAINT_IF(RX_MATCH_TAINTED(rx));
5034 && rx->subbase != orig) {
5039 strend = s + (strend - m);
5042 dstr = NEWSV(32, m-s);
5043 sv_setpvn(dstr, s, m-s);
5048 for (i = 1; i <= rx->nparens; i++) {
5052 dstr = NEWSV(33, m-s);
5053 sv_setpvn(dstr, s, m-s);
5056 dstr = NEWSV(33, 0);
5066 LEAVE_SCOPE(oldsave);
5067 iters = (SP - PL_stack_base) - base;
5068 if (iters > maxiters)
5071 /* keep field after final delim? */
5072 if (s < strend || (iters && origlimit)) {
5073 dstr = NEWSV(34, strend-s);
5074 sv_setpvn(dstr, s, strend-s);
5080 else if (!origlimit) {
5081 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5087 SWITCHSTACK(ary, oldstack);
5088 if (SvSMAGICAL(ary)) {
5093 if (gimme == G_ARRAY) {
5095 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5103 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5106 if (gimme == G_ARRAY) {
5107 /* EXTEND should not be needed - we just popped them */
5109 for (i=0; i < iters; i++) {
5110 SV **svp = av_fetch(ary, i, FALSE);
5111 PUSHs((svp) ? *svp : &PL_sv_undef);
5118 if (gimme == G_ARRAY)
5121 if (iters || !pm->op_pmreplroot) {
5131 unlock_condpair(void *svv)
5134 MAGIC *mg = mg_find((SV*)svv, 'm');
5137 croak("panic: unlock_condpair unlocking non-mutex");
5138 MUTEX_LOCK(MgMUTEXP(mg));
5139 if (MgOWNER(mg) != thr)
5140 croak("panic: unlock_condpair unlocking mutex that we don't own");
5142 COND_SIGNAL(MgOWNERCONDP(mg));
5143 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5144 (unsigned long)thr, (unsigned long)svv);)
5145 MUTEX_UNLOCK(MgMUTEXP(mg));
5147 #endif /* USE_THREADS */
5160 mg = condpair_magic(sv);
5161 MUTEX_LOCK(MgMUTEXP(mg));
5162 if (MgOWNER(mg) == thr)
5163 MUTEX_UNLOCK(MgMUTEXP(mg));
5166 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5168 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5169 (unsigned long)thr, (unsigned long)sv);)
5170 MUTEX_UNLOCK(MgMUTEXP(mg));
5171 save_destructor(unlock_condpair, sv);
5173 #endif /* USE_THREADS */
5174 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5175 || SvTYPE(retsv) == SVt_PVCV) {
5176 retsv = refto(retsv);
5187 if (PL_op->op_private & OPpLVAL_INTRO)
5188 PUSHs(*save_threadsv(PL_op->op_targ));
5190 PUSHs(THREADSV(PL_op->op_targ));
5193 DIE("tried to access per-thread data in non-threaded perl");
5194 #endif /* USE_THREADS */