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 this is a 'my' scalar and flag is set then vivify
248 if (PL_op->op_private & OPpDEREF) {
249 GV *gv = (GV *) newSV(0);
252 if (cUNOP->op_first->op_type == OP_PADSV) {
253 SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
254 name = SvPV(padname,len);
256 gv_init(gv, PL_curcop->cop_stash, name, len, 0);
257 sv_upgrade(sv, SVt_RV);
258 SvRV(sv) = (SV *) gv;
263 if (PL_op->op_flags & OPf_REF ||
264 PL_op->op_private & HINT_STRICT_REFS)
265 DIE(PL_no_usym, "a symbol");
266 if (ckWARN(WARN_UNINITIALIZED))
267 warner(WARN_UNINITIALIZED, PL_warn_uninit);
271 if ((PL_op->op_flags & OPf_SPECIAL) &&
272 !(PL_op->op_flags & OPf_MOD))
274 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
279 if (PL_op->op_private & HINT_STRICT_REFS)
280 DIE(PL_no_symref, sym, "a symbol");
281 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
285 if (PL_op->op_private & OPpLVAL_INTRO)
286 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
297 tryAMAGICunDEREF(to_sv);
300 switch (SvTYPE(sv)) {
304 DIE("Not a SCALAR reference");
312 if (SvTYPE(gv) != SVt_PVGV) {
313 if (SvGMAGICAL(sv)) {
319 if (PL_op->op_flags & OPf_REF ||
320 PL_op->op_private & HINT_STRICT_REFS)
321 DIE(PL_no_usym, "a SCALAR");
322 if (ckWARN(WARN_UNINITIALIZED))
323 warner(WARN_UNINITIALIZED, PL_warn_uninit);
327 if ((PL_op->op_flags & OPf_SPECIAL) &&
328 !(PL_op->op_flags & OPf_MOD))
330 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
335 if (PL_op->op_private & HINT_STRICT_REFS)
336 DIE(PL_no_symref, sym, "a SCALAR");
337 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
342 if (PL_op->op_flags & OPf_MOD) {
343 if (PL_op->op_private & OPpLVAL_INTRO)
344 sv = save_scalar((GV*)TOPs);
345 else if (PL_op->op_private & OPpDEREF)
346 vivify_ref(sv, PL_op->op_private & OPpDEREF);
356 SV *sv = AvARYLEN(av);
358 AvARYLEN(av) = sv = NEWSV(0,0);
359 sv_upgrade(sv, SVt_IV);
360 sv_magic(sv, (SV*)av, '#', Nullch, 0);
368 djSP; dTARGET; dPOPss;
370 if (PL_op->op_flags & OPf_MOD) {
371 if (SvTYPE(TARG) < SVt_PVLV) {
372 sv_upgrade(TARG, SVt_PVLV);
373 sv_magic(TARG, Nullsv, '.', Nullch, 0);
377 if (LvTARG(TARG) != sv) {
379 SvREFCNT_dec(LvTARG(TARG));
380 LvTARG(TARG) = SvREFCNT_inc(sv);
382 PUSHs(TARG); /* no SvSETMAGIC */
388 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
389 mg = mg_find(sv, 'g');
390 if (mg && mg->mg_len >= 0) {
394 PUSHi(i + PL_curcop->cop_arybase);
408 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
409 /* (But not in defined().) */
410 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
413 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
416 cv = (CV*)&PL_sv_undef;
430 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
431 char *s = SvPVX(TOPs);
432 if (strnEQ(s, "CORE::", 6)) {
435 code = keyword(s + 6, SvCUR(TOPs) - 6);
436 if (code < 0) { /* Overridable. */
437 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
438 int i = 0, n = 0, seen_question = 0;
440 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
442 while (i < MAXO) { /* The slow way. */
443 if (strEQ(s + 6, PL_op_name[i])
444 || strEQ(s + 6, PL_op_desc[i]))
450 goto nonesuch; /* Should not happen... */
452 oa = PL_opargs[i] >> OASHIFT;
454 if (oa & OA_OPTIONAL) {
458 else if (seen_question)
459 goto set; /* XXXX system, exec */
460 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
461 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
464 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
465 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
469 ret = sv_2mortal(newSVpvn(str, n - 1));
471 else if (code) /* Non-Overridable */
473 else { /* None such */
475 croak("Cannot find an opnumber for \"%s\"", s+6);
479 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
481 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
490 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
492 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
508 if (GIMME != G_ARRAY) {
512 *MARK = &PL_sv_undef;
513 *MARK = refto(*MARK);
517 EXTEND_MORTAL(SP - MARK);
519 *MARK = refto(*MARK);
528 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
531 if (!(sv = LvTARG(sv)))
536 else if (SvPADTMP(sv))
540 (void)SvREFCNT_inc(sv);
543 sv_upgrade(rv, SVt_RV);
557 if (sv && SvGMAGICAL(sv))
560 if (!sv || !SvROK(sv))
564 pv = sv_reftype(sv,TRUE);
565 PUSHp(pv, strlen(pv));
575 stash = PL_curcop->cop_stash;
579 char *ptr = SvPV(ssv,len);
580 if (ckWARN(WARN_UNSAFE) && len == 0)
582 "Explicit blessing to '' (assuming package main)");
583 stash = gv_stashpvn(ptr, len, TRUE);
586 (void)sv_bless(TOPs, stash);
600 elem = SvPV(sv, n_a);
604 switch (elem ? *elem : '\0')
607 if (strEQ(elem, "ARRAY"))
608 tmpRef = (SV*)GvAV(gv);
611 if (strEQ(elem, "CODE"))
612 tmpRef = (SV*)GvCVu(gv);
615 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
616 tmpRef = (SV*)GvIOp(gv);
619 if (strEQ(elem, "GLOB"))
623 if (strEQ(elem, "HASH"))
624 tmpRef = (SV*)GvHV(gv);
627 if (strEQ(elem, "IO"))
628 tmpRef = (SV*)GvIOp(gv);
631 if (strEQ(elem, "NAME"))
632 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
635 if (strEQ(elem, "PACKAGE"))
636 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
639 if (strEQ(elem, "SCALAR"))
653 /* Pattern matching */
658 register unsigned char *s;
661 register I32 *sfirst;
665 if (sv == PL_lastscream) {
671 SvSCREAM_off(PL_lastscream);
672 SvREFCNT_dec(PL_lastscream);
674 PL_lastscream = SvREFCNT_inc(sv);
677 s = (unsigned char*)(SvPV(sv, len));
681 if (pos > PL_maxscream) {
682 if (PL_maxscream < 0) {
683 PL_maxscream = pos + 80;
684 New(301, PL_screamfirst, 256, I32);
685 New(302, PL_screamnext, PL_maxscream, I32);
688 PL_maxscream = pos + pos / 4;
689 Renew(PL_screamnext, PL_maxscream, I32);
693 sfirst = PL_screamfirst;
694 snext = PL_screamnext;
696 if (!sfirst || !snext)
697 DIE("do_study: out of memory");
699 for (ch = 256; ch; --ch)
706 snext[pos] = sfirst[ch] - pos;
713 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
722 if (PL_op->op_flags & OPf_STACKED)
728 TARG = sv_newmortal();
733 /* Lvalue operators. */
745 djSP; dMARK; dTARGET;
755 SETi(do_chomp(TOPs));
761 djSP; dMARK; dTARGET;
762 register I32 count = 0;
765 count += do_chomp(POPs);
776 if (!sv || !SvANY(sv))
778 switch (SvTYPE(sv)) {
780 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
784 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
788 if (CvROOT(sv) || CvXSUB(sv))
805 if (!PL_op->op_private) {
814 if (SvTHINKFIRST(sv))
817 switch (SvTYPE(sv)) {
827 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
828 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
829 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
833 /* let user-undef'd sub keep its identity */
834 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
841 SvSetMagicSV(sv, &PL_sv_undef);
845 Newz(602, gp, 1, GP);
846 GvGP(sv) = gp_ref(gp);
847 GvSV(sv) = NEWSV(72,0);
848 GvLINE(sv) = PL_curcop->cop_line;
854 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
857 SvPV_set(sv, Nullch);
870 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
872 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
873 SvIVX(TOPs) != IV_MIN)
876 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
887 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
889 sv_setsv(TARG, TOPs);
890 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
891 SvIVX(TOPs) != IV_MAX)
894 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
908 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
910 sv_setsv(TARG, TOPs);
911 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
912 SvIVX(TOPs) != IV_MIN)
915 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
924 /* Ordinary operators. */
928 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
931 SETn( pow( left, right) );
938 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
941 SETn( left * right );
948 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
953 DIE("Illegal division by zero");
955 /* insure that 20./5. == 4. */
958 if ((double)I_V(left) == left &&
959 (double)I_V(right) == right &&
960 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
964 value = left / right;
968 value = left / right;
977 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
987 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
989 right = (right_neg = (i < 0)) ? -i : i;
994 right_neg = dright < 0;
999 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1001 left = (left_neg = (i < 0)) ? -i : i;
1009 left_neg = dleft < 0;
1018 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1020 # define CAST_D2UV(d) U_V(d)
1022 # define CAST_D2UV(d) ((UV)(d))
1024 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1025 * or, in other words, precision of UV more than of NV.
1026 * But in fact the approach below turned out to be an
1027 * optimization - floor() may be slow */
1028 if (dright <= UV_MAX && dleft <= UV_MAX) {
1029 right = CAST_D2UV(dright);
1030 left = CAST_D2UV(dleft);
1035 /* Backward-compatibility clause: */
1036 dright = floor(dright + 0.5);
1037 dleft = floor(dleft + 0.5);
1040 DIE("Illegal modulus zero");
1042 dans = fmod(dleft, dright);
1043 if ((left_neg != right_neg) && dans)
1044 dans = dright - dans;
1047 sv_setnv(TARG, dans);
1054 DIE("Illegal modulus zero");
1057 if ((left_neg != right_neg) && ans)
1060 /* XXX may warn: unary minus operator applied to unsigned type */
1061 /* could change -foo to be (~foo)+1 instead */
1062 if (ans <= ~((UV)IV_MAX)+1)
1063 sv_setiv(TARG, ~ans+1);
1065 sv_setnv(TARG, -(double)ans);
1068 sv_setuv(TARG, ans);
1077 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1079 register I32 count = POPi;
1080 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1082 I32 items = SP - MARK;
1085 max = items * count;
1094 repeatcpy((char*)(MARK + items), (char*)MARK,
1095 items * sizeof(SV*), count - 1);
1098 else if (count <= 0)
1101 else { /* Note: mark already snarfed by pp_list */
1106 SvSetSV(TARG, tmpstr);
1107 SvPV_force(TARG, len);
1112 SvGROW(TARG, (count * len) + 1);
1113 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1114 SvCUR(TARG) *= count;
1116 *SvEND(TARG) = '\0';
1118 (void)SvPOK_only(TARG);
1127 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1130 SETn( left - right );
1137 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1140 if (PL_op->op_private & HINT_INTEGER) {
1142 i = BWi(i) << shift;
1156 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1159 if (PL_op->op_private & HINT_INTEGER) {
1161 i = BWi(i) >> shift;
1175 djSP; tryAMAGICbinSET(lt,0);
1178 SETs(boolSV(TOPn < value));
1185 djSP; tryAMAGICbinSET(gt,0);
1188 SETs(boolSV(TOPn > value));
1195 djSP; tryAMAGICbinSET(le,0);
1198 SETs(boolSV(TOPn <= value));
1205 djSP; tryAMAGICbinSET(ge,0);
1208 SETs(boolSV(TOPn >= value));
1215 djSP; tryAMAGICbinSET(ne,0);
1218 SETs(boolSV(TOPn != value));
1225 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1232 else if (left < right)
1234 else if (left > right)
1247 djSP; tryAMAGICbinSET(slt,0);
1250 int cmp = ((PL_op->op_private & OPpLOCALE)
1251 ? sv_cmp_locale(left, right)
1252 : sv_cmp(left, right));
1253 SETs(boolSV(cmp < 0));
1260 djSP; tryAMAGICbinSET(sgt,0);
1263 int cmp = ((PL_op->op_private & OPpLOCALE)
1264 ? sv_cmp_locale(left, right)
1265 : sv_cmp(left, right));
1266 SETs(boolSV(cmp > 0));
1273 djSP; tryAMAGICbinSET(sle,0);
1276 int cmp = ((PL_op->op_private & OPpLOCALE)
1277 ? sv_cmp_locale(left, right)
1278 : sv_cmp(left, right));
1279 SETs(boolSV(cmp <= 0));
1286 djSP; tryAMAGICbinSET(sge,0);
1289 int cmp = ((PL_op->op_private & OPpLOCALE)
1290 ? sv_cmp_locale(left, right)
1291 : sv_cmp(left, right));
1292 SETs(boolSV(cmp >= 0));
1299 djSP; tryAMAGICbinSET(seq,0);
1302 SETs(boolSV(sv_eq(left, right)));
1309 djSP; tryAMAGICbinSET(sne,0);
1312 SETs(boolSV(!sv_eq(left, right)));
1319 djSP; dTARGET; tryAMAGICbin(scmp,0);
1322 int cmp = ((PL_op->op_private & OPpLOCALE)
1323 ? sv_cmp_locale(left, right)
1324 : sv_cmp(left, right));
1332 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1335 if (SvNIOKp(left) || SvNIOKp(right)) {
1336 if (PL_op->op_private & HINT_INTEGER) {
1337 IBW value = SvIV(left) & SvIV(right);
1341 UBW value = SvUV(left) & SvUV(right);
1346 do_vop(PL_op->op_type, TARG, left, right);
1355 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1358 if (SvNIOKp(left) || SvNIOKp(right)) {
1359 if (PL_op->op_private & HINT_INTEGER) {
1360 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1364 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1369 do_vop(PL_op->op_type, TARG, left, right);
1378 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1381 if (SvNIOKp(left) || SvNIOKp(right)) {
1382 if (PL_op->op_private & HINT_INTEGER) {
1383 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1387 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1392 do_vop(PL_op->op_type, TARG, left, right);
1401 djSP; dTARGET; tryAMAGICun(neg);
1406 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1408 else if (SvNIOKp(sv))
1410 else if (SvPOKp(sv)) {
1412 char *s = SvPV(sv, len);
1413 if (isIDFIRST(*s)) {
1414 sv_setpvn(TARG, "-", 1);
1417 else if (*s == '+' || *s == '-') {
1419 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1421 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1422 sv_setpvn(TARG, "-", 1);
1426 sv_setnv(TARG, -SvNV(sv));
1437 djSP; tryAMAGICunSET(not);
1438 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1444 djSP; dTARGET; tryAMAGICun(compl);
1448 if (PL_op->op_private & HINT_INTEGER) {
1449 IBW value = ~SvIV(sv);
1453 UBW value = ~SvUV(sv);
1458 register char *tmps;
1459 register long *tmpl;
1464 tmps = SvPV_force(TARG, len);
1467 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1470 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1474 for ( ; anum > 0; anum--, tmps++)
1483 /* integer versions of some of the above */
1487 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1490 SETi( left * right );
1497 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1501 DIE("Illegal division by zero");
1502 value = POPi / value;
1510 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1514 DIE("Illegal modulus zero");
1515 SETi( left % right );
1522 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1525 SETi( left + right );
1532 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1535 SETi( left - right );
1542 djSP; tryAMAGICbinSET(lt,0);
1545 SETs(boolSV(left < right));
1552 djSP; tryAMAGICbinSET(gt,0);
1555 SETs(boolSV(left > right));
1562 djSP; tryAMAGICbinSET(le,0);
1565 SETs(boolSV(left <= right));
1572 djSP; tryAMAGICbinSET(ge,0);
1575 SETs(boolSV(left >= right));
1582 djSP; tryAMAGICbinSET(eq,0);
1585 SETs(boolSV(left == right));
1592 djSP; tryAMAGICbinSET(ne,0);
1595 SETs(boolSV(left != right));
1602 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1609 else if (left < right)
1620 djSP; dTARGET; tryAMAGICun(neg);
1625 /* High falutin' math. */
1629 djSP; dTARGET; tryAMAGICbin(atan2,0);
1632 SETn(atan2(left, right));
1639 djSP; dTARGET; tryAMAGICun(sin);
1651 djSP; dTARGET; tryAMAGICun(cos);
1661 /* Support Configure command-line overrides for rand() functions.
1662 After 5.005, perhaps we should replace this by Configure support
1663 for drand48(), random(), or rand(). For 5.005, though, maintain
1664 compatibility by calling rand() but allow the user to override it.
1665 See INSTALL for details. --Andy Dougherty 15 July 1998
1667 /* Now it's after 5.005, and Configure supports drand48() and random(),
1668 in addition to rand(). So the overrides should not be needed any more.
1669 --Jarkko Hietaniemi 27 September 1998
1672 #ifndef HAS_DRAND48_PROTO
1673 extern double drand48 _((void));
1686 if (!PL_srand_called) {
1687 (void)seedDrand01((Rand_seed_t)seed());
1688 PL_srand_called = TRUE;
1703 (void)seedDrand01((Rand_seed_t)anum);
1704 PL_srand_called = TRUE;
1713 * This is really just a quick hack which grabs various garbage
1714 * values. It really should be a real hash algorithm which
1715 * spreads the effect of every input bit onto every output bit,
1716 * if someone who knows about such things would bother to write it.
1717 * Might be a good idea to add that function to CORE as well.
1718 * No numbers below come from careful analysis or anything here,
1719 * except they are primes and SEED_C1 > 1E6 to get a full-width
1720 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1721 * probably be bigger too.
1724 # define SEED_C1 1000003
1725 #define SEED_C4 73819
1727 # define SEED_C1 25747
1728 #define SEED_C4 20639
1732 #define SEED_C5 26107
1735 #ifndef PERL_NO_DEV_RANDOM
1740 # include <starlet.h>
1741 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1742 * in 100-ns units, typically incremented ever 10 ms. */
1743 unsigned int when[2];
1745 # ifdef HAS_GETTIMEOFDAY
1746 struct timeval when;
1752 /* This test is an escape hatch, this symbol isn't set by Configure. */
1753 #ifndef PERL_NO_DEV_RANDOM
1754 #ifndef PERL_RANDOM_DEVICE
1755 /* /dev/random isn't used by default because reads from it will block
1756 * if there isn't enough entropy available. You can compile with
1757 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1758 * is enough real entropy to fill the seed. */
1759 # define PERL_RANDOM_DEVICE "/dev/urandom"
1761 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1763 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1772 _ckvmssts(sys$gettim(when));
1773 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1775 # ifdef HAS_GETTIMEOFDAY
1776 gettimeofday(&when,(struct timezone *) 0);
1777 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1780 u = (U32)SEED_C1 * when;
1783 u += SEED_C3 * (U32)getpid();
1784 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1785 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1786 u += SEED_C5 * (U32)(UV)&when;
1793 djSP; dTARGET; tryAMAGICun(exp);
1805 djSP; dTARGET; tryAMAGICun(log);
1810 SET_NUMERIC_STANDARD();
1811 DIE("Can't take log of %g", value);
1821 djSP; dTARGET; tryAMAGICun(sqrt);
1826 SET_NUMERIC_STANDARD();
1827 DIE("Can't take sqrt of %g", value);
1829 value = sqrt(value);
1839 double value = TOPn;
1842 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1848 (void)modf(value, &value);
1850 (void)modf(-value, &value);
1865 djSP; dTARGET; tryAMAGICun(abs);
1867 double value = TOPn;
1870 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1871 (iv = SvIVX(TOPs)) != IV_MIN) {
1893 XPUSHu(scan_hex(tmps, 99, &argtype));
1906 while (*tmps && isSPACE(*tmps))
1911 value = scan_hex(++tmps, 99, &argtype);
1912 else if (*tmps == 'b')
1913 value = scan_bin(++tmps, 99, &argtype);
1915 value = scan_oct(tmps, 99, &argtype);
1927 SETi( sv_len_utf8(TOPs) );
1931 SETi( sv_len(TOPs) );
1945 I32 lvalue = PL_op->op_flags & OPf_MOD;
1947 I32 arybase = PL_curcop->cop_arybase;
1951 SvTAINTED_off(TARG); /* decontaminate */
1955 repl = SvPV(sv, repl_len);
1962 tmps = SvPV(sv, curlen);
1964 utfcurlen = sv_len_utf8(sv);
1965 if (utfcurlen == curlen)
1973 if (pos >= arybase) {
1991 else if (len >= 0) {
1993 if (rem > (I32)curlen)
2007 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2008 warner(WARN_SUBSTR, "substr outside of string");
2013 sv_pos_u2b(sv, &pos, &rem);
2015 sv_setpvn(TARG, tmps, rem);
2016 if (lvalue) { /* it's an lvalue! */
2017 if (!SvGMAGICAL(sv)) {
2021 if (ckWARN(WARN_SUBSTR))
2023 "Attempt to use reference as lvalue in substr");
2025 if (SvOK(sv)) /* is it defined ? */
2026 (void)SvPOK_only(sv);
2028 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2031 if (SvTYPE(TARG) < SVt_PVLV) {
2032 sv_upgrade(TARG, SVt_PVLV);
2033 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2037 if (LvTARG(TARG) != sv) {
2039 SvREFCNT_dec(LvTARG(TARG));
2040 LvTARG(TARG) = SvREFCNT_inc(sv);
2042 LvTARGOFF(TARG) = pos;
2043 LvTARGLEN(TARG) = rem;
2046 sv_insert(sv, pos, rem, repl, repl_len);
2049 PUSHs(TARG); /* avoid SvSETMAGIC here */
2056 register I32 size = POPi;
2057 register I32 offset = POPi;
2058 register SV *src = POPs;
2059 I32 lvalue = PL_op->op_flags & OPf_MOD;
2061 unsigned char *s = (unsigned char*)SvPV(src, srclen);
2062 unsigned long retnum;
2065 SvTAINTED_off(TARG); /* decontaminate */
2066 offset *= size; /* turn into bit offset */
2067 len = (offset + size + 7) / 8;
2068 if (offset < 0 || size < 1)
2071 if (lvalue) { /* it's an lvalue! */
2072 if (SvTYPE(TARG) < SVt_PVLV) {
2073 sv_upgrade(TARG, SVt_PVLV);
2074 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2078 if (LvTARG(TARG) != src) {
2080 SvREFCNT_dec(LvTARG(TARG));
2081 LvTARG(TARG) = SvREFCNT_inc(src);
2083 LvTARGOFF(TARG) = offset;
2084 LvTARGLEN(TARG) = size;
2092 if (offset >= srclen)
2095 retnum = (unsigned long) s[offset] << 8;
2097 else if (size == 32) {
2098 if (offset >= srclen)
2100 else if (offset + 1 >= srclen)
2101 retnum = (unsigned long) s[offset] << 24;
2102 else if (offset + 2 >= srclen)
2103 retnum = ((unsigned long) s[offset] << 24) +
2104 ((unsigned long) s[offset + 1] << 16);
2106 retnum = ((unsigned long) s[offset] << 24) +
2107 ((unsigned long) s[offset + 1] << 16) +
2108 (s[offset + 2] << 8);
2113 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2118 else if (size == 16)
2119 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2120 else if (size == 32)
2121 retnum = ((unsigned long) s[offset] << 24) +
2122 ((unsigned long) s[offset + 1] << 16) +
2123 (s[offset + 2] << 8) + s[offset+3];
2127 sv_setuv(TARG, (UV)retnum);
2142 I32 arybase = PL_curcop->cop_arybase;
2147 offset = POPi - arybase;
2150 tmps = SvPV(big, biglen);
2151 if (IN_UTF8 && offset > 0)
2152 sv_pos_u2b(big, &offset, 0);
2155 else if (offset > biglen)
2157 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2158 (unsigned char*)tmps + biglen, little, 0)))
2161 retval = tmps2 - tmps;
2162 if (IN_UTF8 && retval > 0)
2163 sv_pos_b2u(big, &retval);
2164 PUSHi(retval + arybase);
2179 I32 arybase = PL_curcop->cop_arybase;
2185 tmps2 = SvPV(little, llen);
2186 tmps = SvPV(big, blen);
2190 if (IN_UTF8 && offset > 0)
2191 sv_pos_u2b(big, &offset, 0);
2192 offset = offset - arybase + llen;
2196 else if (offset > blen)
2198 if (!(tmps2 = rninstr(tmps, tmps + offset,
2199 tmps2, tmps2 + llen)))
2202 retval = tmps2 - tmps;
2203 if (IN_UTF8 && retval > 0)
2204 sv_pos_b2u(big, &retval);
2205 PUSHi(retval + arybase);
2211 djSP; dMARK; dORIGMARK; dTARGET;
2212 #ifdef USE_LOCALE_NUMERIC
2213 if (PL_op->op_private & OPpLOCALE)
2214 SET_NUMERIC_LOCAL();
2216 SET_NUMERIC_STANDARD();
2218 do_sprintf(TARG, SP-MARK, MARK+1);
2219 TAINT_IF(SvTAINTED(TARG));
2230 U8 *tmps = (U8*)POPpx;
2233 if (IN_UTF8 && (*tmps & 0x80))
2234 value = utf8_to_uv(tmps, &retlen);
2236 value = (UV)(*tmps & 255);
2247 (void)SvUPGRADE(TARG,SVt_PV);
2249 if (IN_UTF8 && value >= 128) {
2252 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2253 SvCUR_set(TARG, tmps - SvPVX(TARG));
2255 (void)SvPOK_only(TARG);
2265 (void)SvPOK_only(TARG);
2272 djSP; dTARGET; dPOPTOPssrl;
2275 char *tmps = SvPV(left, n_a);
2277 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2279 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2283 "The crypt() function is unimplemented due to excessive paranoia.");
2296 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2300 UV uv = utf8_to_uv(s, &ulen);
2302 if (PL_op->op_private & OPpLOCALE) {
2305 uv = toTITLE_LC_uni(uv);
2308 uv = toTITLE_utf8(s);
2310 tend = uv_to_utf8(tmpbuf, uv);
2312 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2314 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2315 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2319 s = (U8*)SvPV_force(sv, slen);
2320 Copy(tmpbuf, s, ulen, U8);
2325 if (!SvPADTMP(sv)) {
2331 s = (U8*)SvPV_force(sv, slen);
2333 if (PL_op->op_private & OPpLOCALE) {
2336 *s = toUPPER_LC(*s);
2352 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2356 UV uv = utf8_to_uv(s, &ulen);
2358 if (PL_op->op_private & OPpLOCALE) {
2361 uv = toLOWER_LC_uni(uv);
2364 uv = toLOWER_utf8(s);
2366 tend = uv_to_utf8(tmpbuf, uv);
2368 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2370 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2371 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2375 s = (U8*)SvPV_force(sv, slen);
2376 Copy(tmpbuf, s, ulen, U8);
2381 if (!SvPADTMP(sv)) {
2387 s = (U8*)SvPV_force(sv, slen);
2389 if (PL_op->op_private & OPpLOCALE) {
2392 *s = toLOWER_LC(*s);
2415 s = (U8*)SvPV(sv,len);
2417 sv_setpvn(TARG, "", 0);
2422 (void)SvUPGRADE(TARG, SVt_PV);
2423 SvGROW(TARG, (len * 2) + 1);
2424 (void)SvPOK_only(TARG);
2425 d = (U8*)SvPVX(TARG);
2427 if (PL_op->op_private & OPpLOCALE) {
2431 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2437 d = uv_to_utf8(d, toUPPER_utf8( s ));
2442 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2447 if (!SvPADTMP(sv)) {
2454 s = (U8*)SvPV_force(sv, len);
2456 register U8 *send = s + len;
2458 if (PL_op->op_private & OPpLOCALE) {
2461 for (; s < send; s++)
2462 *s = toUPPER_LC(*s);
2465 for (; s < send; s++)
2485 s = (U8*)SvPV(sv,len);
2487 sv_setpvn(TARG, "", 0);
2492 (void)SvUPGRADE(TARG, SVt_PV);
2493 SvGROW(TARG, (len * 2) + 1);
2494 (void)SvPOK_only(TARG);
2495 d = (U8*)SvPVX(TARG);
2497 if (PL_op->op_private & OPpLOCALE) {
2501 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2507 d = uv_to_utf8(d, toLOWER_utf8(s));
2512 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2517 if (!SvPADTMP(sv)) {
2524 s = (U8*)SvPV_force(sv, len);
2526 register U8 *send = s + len;
2528 if (PL_op->op_private & OPpLOCALE) {
2531 for (; s < send; s++)
2532 *s = toLOWER_LC(*s);
2535 for (; s < send; s++)
2547 register char *s = SvPV(sv,len);
2551 (void)SvUPGRADE(TARG, SVt_PV);
2552 SvGROW(TARG, (len * 2) + 1);
2557 STRLEN ulen = UTF8SKIP(s);
2580 SvCUR_set(TARG, d - SvPVX(TARG));
2581 (void)SvPOK_only(TARG);
2584 sv_setpvn(TARG, s, len);
2593 djSP; dMARK; dORIGMARK;
2595 register AV* av = (AV*)POPs;
2596 register I32 lval = PL_op->op_flags & OPf_MOD;
2597 I32 arybase = PL_curcop->cop_arybase;
2600 if (SvTYPE(av) == SVt_PVAV) {
2601 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2603 for (svp = MARK + 1; svp <= SP; svp++) {
2608 if (max > AvMAX(av))
2611 while (++MARK <= SP) {
2612 elem = SvIVx(*MARK);
2616 svp = av_fetch(av, elem, lval);
2618 if (!svp || *svp == &PL_sv_undef)
2619 DIE(PL_no_aelem, elem);
2620 if (PL_op->op_private & OPpLVAL_INTRO)
2621 save_aelem(av, elem, svp);
2623 *MARK = svp ? *svp : &PL_sv_undef;
2626 if (GIMME != G_ARRAY) {
2634 /* Associative arrays. */
2639 HV *hash = (HV*)POPs;
2641 I32 gimme = GIMME_V;
2642 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2645 /* might clobber stack_sp */
2646 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2651 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2652 if (gimme == G_ARRAY) {
2654 /* might clobber stack_sp */
2655 sv_setsv(TARG, realhv ?
2656 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2661 else if (gimme == G_SCALAR)
2680 I32 gimme = GIMME_V;
2681 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2685 if (PL_op->op_private & OPpSLICE) {
2689 hvtype = SvTYPE(hv);
2690 while (++MARK <= SP) {
2691 if (hvtype == SVt_PVHV)
2692 sv = hv_delete_ent(hv, *MARK, discard, 0);
2694 DIE("Not a HASH reference");
2695 *MARK = sv ? sv : &PL_sv_undef;
2699 else if (gimme == G_SCALAR) {
2708 if (SvTYPE(hv) == SVt_PVHV)
2709 sv = hv_delete_ent(hv, keysv, discard, 0);
2711 DIE("Not a HASH reference");
2725 if (SvTYPE(hv) == SVt_PVHV) {
2726 if (hv_exists_ent(hv, tmpsv, 0))
2729 else if (SvTYPE(hv) == SVt_PVAV) {
2730 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2734 DIE("Not a HASH reference");
2741 djSP; dMARK; dORIGMARK;
2742 register HV *hv = (HV*)POPs;
2743 register I32 lval = PL_op->op_flags & OPf_MOD;
2744 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2746 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2747 DIE("Can't localize pseudo-hash element");
2749 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2750 while (++MARK <= SP) {
2754 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2755 svp = he ? &HeVAL(he) : 0;
2758 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2761 if (!svp || *svp == &PL_sv_undef) {
2763 DIE(PL_no_helem, SvPV(keysv, n_a));
2765 if (PL_op->op_private & OPpLVAL_INTRO)
2766 save_helem(hv, keysv, svp);
2768 *MARK = svp ? *svp : &PL_sv_undef;
2771 if (GIMME != G_ARRAY) {
2779 /* List operators. */
2784 if (GIMME != G_ARRAY) {
2786 *MARK = *SP; /* unwanted list, return last item */
2788 *MARK = &PL_sv_undef;
2797 SV **lastrelem = PL_stack_sp;
2798 SV **lastlelem = PL_stack_base + POPMARK;
2799 SV **firstlelem = PL_stack_base + POPMARK + 1;
2800 register SV **firstrelem = lastlelem + 1;
2801 I32 arybase = PL_curcop->cop_arybase;
2802 I32 lval = PL_op->op_flags & OPf_MOD;
2803 I32 is_something_there = lval;
2805 register I32 max = lastrelem - lastlelem;
2806 register SV **lelem;
2809 if (GIMME != G_ARRAY) {
2810 ix = SvIVx(*lastlelem);
2815 if (ix < 0 || ix >= max)
2816 *firstlelem = &PL_sv_undef;
2818 *firstlelem = firstrelem[ix];
2824 SP = firstlelem - 1;
2828 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2833 *lelem = &PL_sv_undef;
2834 else if (!(*lelem = firstrelem[ix]))
2835 *lelem = &PL_sv_undef;
2839 if (ix >= max || !(*lelem = firstrelem[ix]))
2840 *lelem = &PL_sv_undef;
2842 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2843 is_something_there = TRUE;
2845 if (is_something_there)
2848 SP = firstlelem - 1;
2854 djSP; dMARK; dORIGMARK;
2855 I32 items = SP - MARK;
2856 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2857 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2864 djSP; dMARK; dORIGMARK;
2865 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2869 SV *val = NEWSV(46, 0);
2871 sv_setsv(val, *++MARK);
2872 else if (ckWARN(WARN_UNSAFE))
2873 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2874 (void)hv_store_ent(hv,key,val,0);
2883 djSP; dMARK; dORIGMARK;
2884 register AV *ary = (AV*)*++MARK;
2888 register I32 offset;
2889 register I32 length;
2896 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2897 *MARK-- = SvTIED_obj((SV*)ary, mg);
2901 perl_call_method("SPLICE",GIMME_V);
2910 offset = i = SvIVx(*MARK);
2912 offset += AvFILLp(ary) + 1;
2914 offset -= PL_curcop->cop_arybase;
2916 DIE(PL_no_aelem, i);
2918 length = SvIVx(*MARK++);
2920 length += AvFILLp(ary) - offset + 1;
2926 length = AvMAX(ary) + 1; /* close enough to infinity */
2930 length = AvMAX(ary) + 1;
2932 if (offset > AvFILLp(ary) + 1)
2933 offset = AvFILLp(ary) + 1;
2934 after = AvFILLp(ary) + 1 - (offset + length);
2935 if (after < 0) { /* not that much array */
2936 length += after; /* offset+length now in array */
2942 /* At this point, MARK .. SP-1 is our new LIST */
2945 diff = newlen - length;
2946 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2949 if (diff < 0) { /* shrinking the area */
2951 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2952 Copy(MARK, tmparyval, newlen, SV*);
2955 MARK = ORIGMARK + 1;
2956 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2957 MEXTEND(MARK, length);
2958 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2960 EXTEND_MORTAL(length);
2961 for (i = length, dst = MARK; i; i--) {
2962 sv_2mortal(*dst); /* free them eventualy */
2969 *MARK = AvARRAY(ary)[offset+length-1];
2972 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2973 SvREFCNT_dec(*dst++); /* free them now */
2976 AvFILLp(ary) += diff;
2978 /* pull up or down? */
2980 if (offset < after) { /* easier to pull up */
2981 if (offset) { /* esp. if nothing to pull */
2982 src = &AvARRAY(ary)[offset-1];
2983 dst = src - diff; /* diff is negative */
2984 for (i = offset; i > 0; i--) /* can't trust Copy */
2988 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2992 if (after) { /* anything to pull down? */
2993 src = AvARRAY(ary) + offset + length;
2994 dst = src + diff; /* diff is negative */
2995 Move(src, dst, after, SV*);
2997 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2998 /* avoid later double free */
3002 dst[--i] = &PL_sv_undef;
3005 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3007 *dst = NEWSV(46, 0);
3008 sv_setsv(*dst++, *src++);
3010 Safefree(tmparyval);
3013 else { /* no, expanding (or same) */
3015 New(452, tmparyval, length, SV*); /* so remember deletion */
3016 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3019 if (diff > 0) { /* expanding */
3021 /* push up or down? */
3023 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3027 Move(src, dst, offset, SV*);
3029 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3031 AvFILLp(ary) += diff;
3034 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3035 av_extend(ary, AvFILLp(ary) + diff);
3036 AvFILLp(ary) += diff;
3039 dst = AvARRAY(ary) + AvFILLp(ary);
3041 for (i = after; i; i--) {
3048 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3049 *dst = NEWSV(46, 0);
3050 sv_setsv(*dst++, *src++);
3052 MARK = ORIGMARK + 1;
3053 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3055 Copy(tmparyval, MARK, length, SV*);
3057 EXTEND_MORTAL(length);
3058 for (i = length, dst = MARK; i; i--) {
3059 sv_2mortal(*dst); /* free them eventualy */
3063 Safefree(tmparyval);
3067 else if (length--) {
3068 *MARK = tmparyval[length];
3071 while (length-- > 0)
3072 SvREFCNT_dec(tmparyval[length]);
3074 Safefree(tmparyval);
3077 *MARK = &PL_sv_undef;
3085 djSP; dMARK; dORIGMARK; dTARGET;
3086 register AV *ary = (AV*)*++MARK;
3087 register SV *sv = &PL_sv_undef;
3090 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3091 *MARK-- = SvTIED_obj((SV*)ary, mg);
3095 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3100 /* Why no pre-extend of ary here ? */
3101 for (++MARK; MARK <= SP; MARK++) {
3104 sv_setsv(sv, *MARK);
3109 PUSHi( AvFILL(ary) + 1 );
3117 SV *sv = av_pop(av);
3119 (void)sv_2mortal(sv);
3128 SV *sv = av_shift(av);
3133 (void)sv_2mortal(sv);
3140 djSP; dMARK; dORIGMARK; dTARGET;
3141 register AV *ary = (AV*)*++MARK;
3146 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3147 *MARK-- = SvTIED_obj((SV*)ary, mg);
3151 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3156 av_unshift(ary, SP - MARK);
3159 sv_setsv(sv, *++MARK);
3160 (void)av_store(ary, i++, sv);
3164 PUSHi( AvFILL(ary) + 1 );
3174 if (GIMME == G_ARRAY) {
3185 register char *down;
3191 do_join(TARG, &PL_sv_no, MARK, SP);
3193 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3194 up = SvPV_force(TARG, len);
3196 if (IN_UTF8) { /* first reverse each character */
3197 U8* s = (U8*)SvPVX(TARG);
3198 U8* send = (U8*)(s + len);
3207 down = (char*)(s - 1);
3208 if (s > send || !((*down & 0xc0) == 0x80)) {
3209 warn("Malformed UTF-8 character");
3221 down = SvPVX(TARG) + len - 1;
3227 (void)SvPOK_only(TARG);
3236 mul128(SV *sv, U8 m)
3239 char *s = SvPV(sv, len);
3243 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3244 SV *tmpNew = newSVpvn("0000000000", 10);
3246 sv_catsv(tmpNew, sv);
3247 SvREFCNT_dec(sv); /* free old sv */
3252 while (!*t) /* trailing '\0'? */
3255 i = ((*t - '0') << 7) + m;
3256 *(t--) = '0' + (i % 10);
3262 /* Explosives and implosives. */
3264 #if 'I' == 73 && 'J' == 74
3265 /* On an ASCII/ISO kind of system */
3266 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3269 Some other sort of character set - use memchr() so we don't match
3272 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3280 I32 gimme = GIMME_V;
3284 register char *pat = SvPV(left, llen);
3285 register char *s = SvPV(right, rlen);
3286 char *strend = s + rlen;
3288 register char *patend = pat + llen;
3293 /* These must not be in registers: */
3310 register U32 culong;
3313 #ifdef PERL_NATINT_PACK
3314 int natint; /* native integer */
3315 int unatint; /* unsigned native integer */
3318 if (gimme != G_ARRAY) { /* arrange to do first one only */
3320 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3321 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3323 while (isDIGIT(*patend) || *patend == '*')
3329 while (pat < patend) {
3331 datumtype = *pat++ & 0xFF;
3332 #ifdef PERL_NATINT_PACK
3335 if (isSPACE(datumtype))
3338 char *natstr = "sSiIlL";
3340 if (strchr(natstr, datumtype)) {
3341 #ifdef PERL_NATINT_PACK
3347 croak("'!' allowed only after types %s", natstr);
3351 else if (*pat == '*') {
3352 len = strend - strbeg; /* long enough */
3355 else if (isDIGIT(*pat)) {
3357 while (isDIGIT(*pat))
3358 len = (len * 10) + (*pat++ - '0');
3361 len = (datumtype != '@');
3364 croak("Invalid type in unpack: '%c'", (int)datumtype);
3365 case ',': /* grandfather in commas but with a warning */
3366 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3367 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3370 if (len == 1 && pat[-1] != '1')
3379 if (len > strend - strbeg)
3380 DIE("@ outside of string");
3384 if (len > s - strbeg)
3385 DIE("X outside of string");
3389 if (len > strend - s)
3390 DIE("x outside of string");
3396 if (len > strend - s)
3399 goto uchar_checksum;
3400 sv = NEWSV(35, len);
3401 sv_setpvn(sv, s, len);
3403 if (datumtype == 'A' || datumtype == 'Z') {
3404 aptr = s; /* borrow register */
3405 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3410 else { /* 'A' strips both nulls and spaces */
3411 s = SvPVX(sv) + len - 1;
3412 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3416 SvCUR_set(sv, s - SvPVX(sv));
3417 s = aptr; /* unborrow register */
3419 XPUSHs(sv_2mortal(sv));
3423 if (pat[-1] == '*' || len > (strend - s) * 8)
3424 len = (strend - s) * 8;
3427 Newz(601, PL_bitcount, 256, char);
3428 for (bits = 1; bits < 256; bits++) {
3429 if (bits & 1) PL_bitcount[bits]++;
3430 if (bits & 2) PL_bitcount[bits]++;
3431 if (bits & 4) PL_bitcount[bits]++;
3432 if (bits & 8) PL_bitcount[bits]++;
3433 if (bits & 16) PL_bitcount[bits]++;
3434 if (bits & 32) PL_bitcount[bits]++;
3435 if (bits & 64) PL_bitcount[bits]++;
3436 if (bits & 128) PL_bitcount[bits]++;
3440 culong += PL_bitcount[*(unsigned char*)s++];
3445 if (datumtype == 'b') {
3447 if (bits & 1) culong++;
3453 if (bits & 128) culong++;
3460 sv = NEWSV(35, len + 1);
3463 aptr = pat; /* borrow register */
3465 if (datumtype == 'b') {
3467 for (len = 0; len < aint; len++) {
3468 if (len & 7) /*SUPPRESS 595*/
3472 *pat++ = '0' + (bits & 1);
3477 for (len = 0; len < aint; len++) {
3482 *pat++ = '0' + ((bits & 128) != 0);
3486 pat = aptr; /* unborrow register */
3487 XPUSHs(sv_2mortal(sv));
3491 if (pat[-1] == '*' || len > (strend - s) * 2)
3492 len = (strend - s) * 2;
3493 sv = NEWSV(35, len + 1);
3496 aptr = pat; /* borrow register */
3498 if (datumtype == 'h') {
3500 for (len = 0; len < aint; len++) {
3505 *pat++ = PL_hexdigit[bits & 15];
3510 for (len = 0; len < aint; len++) {
3515 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3519 pat = aptr; /* unborrow register */
3520 XPUSHs(sv_2mortal(sv));
3523 if (len > strend - s)
3528 if (aint >= 128) /* fake up signed chars */
3538 if (aint >= 128) /* fake up signed chars */
3541 sv_setiv(sv, (IV)aint);
3542 PUSHs(sv_2mortal(sv));
3547 if (len > strend - s)
3562 sv_setiv(sv, (IV)auint);
3563 PUSHs(sv_2mortal(sv));
3568 if (len > strend - s)
3571 while (len-- > 0 && s < strend) {
3572 auint = utf8_to_uv((U8*)s, &along);
3575 cdouble += (double)auint;
3583 while (len-- > 0 && s < strend) {
3584 auint = utf8_to_uv((U8*)s, &along);
3587 sv_setuv(sv, (UV)auint);
3588 PUSHs(sv_2mortal(sv));
3593 #if SHORTSIZE == SIZE16
3594 along = (strend - s) / SIZE16;
3596 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3601 #if SHORTSIZE != SIZE16
3604 COPYNN(s, &ashort, sizeof(short));
3615 #if SHORTSIZE > SIZE16
3627 #if SHORTSIZE != SIZE16
3630 COPYNN(s, &ashort, sizeof(short));
3633 sv_setiv(sv, (IV)ashort);
3634 PUSHs(sv_2mortal(sv));
3642 #if SHORTSIZE > SIZE16
3648 sv_setiv(sv, (IV)ashort);
3649 PUSHs(sv_2mortal(sv));
3657 #if SHORTSIZE == SIZE16
3658 along = (strend - s) / SIZE16;
3660 unatint = natint && datumtype == 'S';
3661 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3666 #if SHORTSIZE != SIZE16
3669 COPYNN(s, &aushort, sizeof(unsigned short));
3670 s += sizeof(unsigned short);
3678 COPY16(s, &aushort);
3681 if (datumtype == 'n')
3682 aushort = PerlSock_ntohs(aushort);
3685 if (datumtype == 'v')
3686 aushort = vtohs(aushort);
3695 #if SHORTSIZE != SIZE16
3698 COPYNN(s, &aushort, sizeof(unsigned short));
3699 s += sizeof(unsigned short);
3701 sv_setiv(sv, (UV)aushort);
3702 PUSHs(sv_2mortal(sv));
3709 COPY16(s, &aushort);
3713 if (datumtype == 'n')
3714 aushort = PerlSock_ntohs(aushort);
3717 if (datumtype == 'v')
3718 aushort = vtohs(aushort);
3720 sv_setiv(sv, (UV)aushort);
3721 PUSHs(sv_2mortal(sv));
3727 along = (strend - s) / sizeof(int);
3732 Copy(s, &aint, 1, int);
3735 cdouble += (double)aint;
3744 Copy(s, &aint, 1, int);
3748 /* Without the dummy below unpack("i", pack("i",-1))
3749 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3750 * cc with optimization turned on.
3752 * The bug was detected in
3753 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3754 * with optimization (-O4) turned on.
3755 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3756 * does not have this problem even with -O4.
3758 * This bug was reported as DECC_BUGS 1431
3759 * and tracked internally as GEM_BUGS 7775.
3761 * The bug is fixed in
3762 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3763 * UNIX V4.0F support: DEC C V5.9-006 or later
3764 * UNIX V4.0E support: DEC C V5.8-011 or later
3767 * See also few lines later for the same bug.
3770 sv_setiv(sv, (IV)aint) :
3772 sv_setiv(sv, (IV)aint);
3773 PUSHs(sv_2mortal(sv));
3778 along = (strend - s) / sizeof(unsigned int);
3783 Copy(s, &auint, 1, unsigned int);
3784 s += sizeof(unsigned int);
3786 cdouble += (double)auint;
3795 Copy(s, &auint, 1, unsigned int);
3796 s += sizeof(unsigned int);
3799 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3800 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3801 * See details few lines earlier. */
3803 sv_setuv(sv, (UV)auint) :
3805 sv_setuv(sv, (UV)auint);
3806 PUSHs(sv_2mortal(sv));
3811 #if LONGSIZE == SIZE32
3812 along = (strend - s) / SIZE32;
3814 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3819 #if LONGSIZE != SIZE32
3822 COPYNN(s, &along, sizeof(long));
3825 cdouble += (double)along;
3835 #if LONGSIZE > SIZE32
3836 if (along > 2147483647)
3837 along -= 4294967296;
3841 cdouble += (double)along;
3850 #if LONGSIZE != SIZE32
3853 COPYNN(s, &along, sizeof(long));
3856 sv_setiv(sv, (IV)along);
3857 PUSHs(sv_2mortal(sv));
3865 #if LONGSIZE > SIZE32
3866 if (along > 2147483647)
3867 along -= 4294967296;
3871 sv_setiv(sv, (IV)along);
3872 PUSHs(sv_2mortal(sv));
3880 #if LONGSIZE == SIZE32
3881 along = (strend - s) / SIZE32;
3883 unatint = natint && datumtype == 'L';
3884 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3889 #if LONGSIZE != SIZE32
3892 COPYNN(s, &aulong, sizeof(unsigned long));
3893 s += sizeof(unsigned long);
3895 cdouble += (double)aulong;
3907 if (datumtype == 'N')
3908 aulong = PerlSock_ntohl(aulong);
3911 if (datumtype == 'V')
3912 aulong = vtohl(aulong);
3915 cdouble += (double)aulong;
3924 #if LONGSIZE != SIZE32
3927 COPYNN(s, &aulong, sizeof(unsigned long));
3928 s += sizeof(unsigned long);
3930 sv_setuv(sv, (UV)aulong);
3931 PUSHs(sv_2mortal(sv));
3941 if (datumtype == 'N')
3942 aulong = PerlSock_ntohl(aulong);
3945 if (datumtype == 'V')
3946 aulong = vtohl(aulong);
3949 sv_setuv(sv, (UV)aulong);
3950 PUSHs(sv_2mortal(sv));
3956 along = (strend - s) / sizeof(char*);
3962 if (sizeof(char*) > strend - s)
3965 Copy(s, &aptr, 1, char*);
3971 PUSHs(sv_2mortal(sv));
3981 while ((len > 0) && (s < strend)) {
3982 auv = (auv << 7) | (*s & 0x7f);
3983 if (!(*s++ & 0x80)) {
3987 PUSHs(sv_2mortal(sv));
3991 else if (++bytes >= sizeof(UV)) { /* promote to string */
3995 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3996 while (s < strend) {
3997 sv = mul128(sv, *s & 0x7f);
3998 if (!(*s++ & 0x80)) {
4007 PUSHs(sv_2mortal(sv));
4012 if ((s >= strend) && bytes)
4013 croak("Unterminated compressed integer");
4018 if (sizeof(char*) > strend - s)
4021 Copy(s, &aptr, 1, char*);
4026 sv_setpvn(sv, aptr, len);
4027 PUSHs(sv_2mortal(sv));
4031 along = (strend - s) / sizeof(Quad_t);
4037 if (s + sizeof(Quad_t) > strend)
4040 Copy(s, &aquad, 1, Quad_t);
4041 s += sizeof(Quad_t);
4044 if (aquad >= IV_MIN && aquad <= IV_MAX)
4045 sv_setiv(sv, (IV)aquad);
4047 sv_setnv(sv, (double)aquad);
4048 PUSHs(sv_2mortal(sv));
4052 along = (strend - s) / sizeof(Quad_t);
4058 if (s + sizeof(Uquad_t) > strend)
4061 Copy(s, &auquad, 1, Uquad_t);
4062 s += sizeof(Uquad_t);
4065 if (auquad <= UV_MAX)
4066 sv_setuv(sv, (UV)auquad);
4068 sv_setnv(sv, (double)auquad);
4069 PUSHs(sv_2mortal(sv));
4073 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4076 along = (strend - s) / sizeof(float);
4081 Copy(s, &afloat, 1, float);
4090 Copy(s, &afloat, 1, float);
4093 sv_setnv(sv, (double)afloat);
4094 PUSHs(sv_2mortal(sv));
4100 along = (strend - s) / sizeof(double);
4105 Copy(s, &adouble, 1, double);
4106 s += sizeof(double);
4114 Copy(s, &adouble, 1, double);
4115 s += sizeof(double);
4117 sv_setnv(sv, (double)adouble);
4118 PUSHs(sv_2mortal(sv));
4124 * Initialise the decode mapping. By using a table driven
4125 * algorithm, the code will be character-set independent
4126 * (and just as fast as doing character arithmetic)
4128 if (PL_uudmap['M'] == 0) {
4131 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4132 PL_uudmap[PL_uuemap[i]] = i;
4134 * Because ' ' and '`' map to the same value,
4135 * we need to decode them both the same.
4140 along = (strend - s) * 3 / 4;
4141 sv = NEWSV(42, along);
4144 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4149 len = PL_uudmap[*s++] & 077;
4151 if (s < strend && ISUUCHAR(*s))
4152 a = PL_uudmap[*s++] & 077;
4155 if (s < strend && ISUUCHAR(*s))
4156 b = PL_uudmap[*s++] & 077;
4159 if (s < strend && ISUUCHAR(*s))
4160 c = PL_uudmap[*s++] & 077;
4163 if (s < strend && ISUUCHAR(*s))
4164 d = PL_uudmap[*s++] & 077;
4167 hunk[0] = (a << 2) | (b >> 4);
4168 hunk[1] = (b << 4) | (c >> 2);
4169 hunk[2] = (c << 6) | d;
4170 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4175 else if (s[1] == '\n') /* possible checksum byte */
4178 XPUSHs(sv_2mortal(sv));
4183 if (strchr("fFdD", datumtype) ||
4184 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4188 while (checksum >= 16) {
4192 while (checksum >= 4) {
4198 along = (1 << checksum) - 1;
4199 while (cdouble < 0.0)
4201 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4202 sv_setnv(sv, cdouble);
4205 if (checksum < 32) {
4206 aulong = (1 << checksum) - 1;
4209 sv_setuv(sv, (UV)culong);
4211 XPUSHs(sv_2mortal(sv));
4215 if (SP == oldsp && gimme == G_SCALAR)
4216 PUSHs(&PL_sv_undef);
4221 doencodes(register SV *sv, register char *s, register I32 len)
4225 *hunk = PL_uuemap[len];
4226 sv_catpvn(sv, hunk, 1);
4229 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4230 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4231 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4232 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4233 sv_catpvn(sv, hunk, 4);
4238 char r = (len > 1 ? s[1] : '\0');
4239 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4240 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4241 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4242 hunk[3] = PL_uuemap[0];
4243 sv_catpvn(sv, hunk, 4);
4245 sv_catpvn(sv, "\n", 1);
4249 is_an_int(char *s, STRLEN l)
4252 SV *result = newSVpvn(s, l);
4253 char *result_c = SvPV(result, n_a); /* convenience */
4254 char *out = result_c;
4264 SvREFCNT_dec(result);
4287 SvREFCNT_dec(result);
4293 SvCUR_set(result, out - result_c);
4298 div128(SV *pnum, bool *done)
4299 /* must be '\0' terminated */
4303 char *s = SvPV(pnum, len);
4312 i = m * 10 + (*t - '0');
4314 r = (i >> 7); /* r < 10 */
4321 SvCUR_set(pnum, (STRLEN) (t - s));
4328 djSP; dMARK; dORIGMARK; dTARGET;
4329 register SV *cat = TARG;
4332 register char *pat = SvPVx(*++MARK, fromlen);
4333 register char *patend = pat + fromlen;
4338 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4339 static char *space10 = " ";
4341 /* These must not be in registers: */
4356 #ifdef PERL_NATINT_PACK
4357 int natint; /* native integer */
4362 sv_setpvn(cat, "", 0);
4363 while (pat < patend) {
4364 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4365 datumtype = *pat++ & 0xFF;
4366 #ifdef PERL_NATINT_PACK
4369 if (isSPACE(datumtype))
4372 char *natstr = "sSiIlL";
4374 if (strchr(natstr, datumtype)) {
4375 #ifdef PERL_NATINT_PACK
4381 croak("'!' allowed only after types %s", natstr);
4384 len = strchr("@Xxu", datumtype) ? 0 : items;
4387 else if (isDIGIT(*pat)) {
4389 while (isDIGIT(*pat))
4390 len = (len * 10) + (*pat++ - '0');
4396 croak("Invalid type in pack: '%c'", (int)datumtype);
4397 case ',': /* grandfather in commas but with a warning */
4398 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4399 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4402 DIE("%% may only be used in unpack");
4413 if (SvCUR(cat) < len)
4414 DIE("X outside of string");
4421 sv_catpvn(cat, null10, 10);
4424 sv_catpvn(cat, null10, len);
4430 aptr = SvPV(fromstr, fromlen);
4434 sv_catpvn(cat, aptr, len);
4436 sv_catpvn(cat, aptr, fromlen);
4438 if (datumtype == 'A') {
4440 sv_catpvn(cat, space10, 10);
4443 sv_catpvn(cat, space10, len);
4447 sv_catpvn(cat, null10, 10);
4450 sv_catpvn(cat, null10, len);
4457 char *savepat = pat;
4462 aptr = SvPV(fromstr, fromlen);
4467 SvCUR(cat) += (len+7)/8;
4468 SvGROW(cat, SvCUR(cat) + 1);
4469 aptr = SvPVX(cat) + aint;
4474 if (datumtype == 'B') {
4475 for (len = 0; len++ < aint;) {
4476 items |= *pat++ & 1;
4480 *aptr++ = items & 0xff;
4486 for (len = 0; len++ < aint;) {
4492 *aptr++ = items & 0xff;
4498 if (datumtype == 'B')
4499 items <<= 7 - (aint & 7);
4501 items >>= 7 - (aint & 7);
4502 *aptr++ = items & 0xff;
4504 pat = SvPVX(cat) + SvCUR(cat);
4515 char *savepat = pat;
4520 aptr = SvPV(fromstr, fromlen);
4525 SvCUR(cat) += (len+1)/2;
4526 SvGROW(cat, SvCUR(cat) + 1);
4527 aptr = SvPVX(cat) + aint;
4532 if (datumtype == 'H') {
4533 for (len = 0; len++ < aint;) {
4535 items |= ((*pat++ & 15) + 9) & 15;
4537 items |= *pat++ & 15;
4541 *aptr++ = items & 0xff;
4547 for (len = 0; len++ < aint;) {
4549 items |= (((*pat++ & 15) + 9) & 15) << 4;
4551 items |= (*pat++ & 15) << 4;
4555 *aptr++ = items & 0xff;
4561 *aptr++ = items & 0xff;
4562 pat = SvPVX(cat) + SvCUR(cat);
4574 aint = SvIV(fromstr);
4576 sv_catpvn(cat, &achar, sizeof(char));
4582 auint = SvUV(fromstr);
4583 SvGROW(cat, SvCUR(cat) + 10);
4584 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4589 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4594 afloat = (float)SvNV(fromstr);
4595 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4602 adouble = (double)SvNV(fromstr);
4603 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4609 ashort = (I16)SvIV(fromstr);
4611 ashort = PerlSock_htons(ashort);
4613 CAT16(cat, &ashort);
4619 ashort = (I16)SvIV(fromstr);
4621 ashort = htovs(ashort);
4623 CAT16(cat, &ashort);
4627 #if SHORTSIZE != SIZE16
4629 unsigned short aushort;
4633 aushort = SvUV(fromstr);
4634 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4644 aushort = (U16)SvUV(fromstr);
4645 CAT16(cat, &aushort);
4651 #if SHORTSIZE != SIZE16
4655 ashort = SvIV(fromstr);
4656 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4664 ashort = (I16)SvIV(fromstr);
4665 CAT16(cat, &ashort);
4672 auint = SvUV(fromstr);
4673 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4679 adouble = floor(SvNV(fromstr));
4682 croak("Cannot compress negative numbers");
4688 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4689 adouble <= UV_MAX_cxux
4696 char buf[1 + sizeof(UV)];
4697 char *in = buf + sizeof(buf);
4698 UV auv = U_V(adouble);;
4701 *--in = (auv & 0x7f) | 0x80;
4704 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4705 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4707 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4708 char *from, *result, *in;
4713 /* Copy string and check for compliance */
4714 from = SvPV(fromstr, len);
4715 if ((norm = is_an_int(from, len)) == NULL)
4716 croak("can compress only unsigned integer");
4718 New('w', result, len, char);
4722 *--in = div128(norm, &done) | 0x80;
4723 result[len - 1] &= 0x7F; /* clear continue bit */
4724 sv_catpvn(cat, in, (result + len) - in);
4726 SvREFCNT_dec(norm); /* free norm */
4728 else if (SvNOKp(fromstr)) {
4729 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4730 char *in = buf + sizeof(buf);
4733 double next = floor(adouble / 128);
4734 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4735 if (--in < buf) /* this cannot happen ;-) */
4736 croak ("Cannot compress integer");
4738 } while (adouble > 0);
4739 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4740 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4743 croak("Cannot compress non integer");
4749 aint = SvIV(fromstr);
4750 sv_catpvn(cat, (char*)&aint, sizeof(int));
4756 aulong = SvUV(fromstr);
4758 aulong = PerlSock_htonl(aulong);
4760 CAT32(cat, &aulong);
4766 aulong = SvUV(fromstr);
4768 aulong = htovl(aulong);
4770 CAT32(cat, &aulong);
4774 #if LONGSIZE != SIZE32
4778 aulong = SvUV(fromstr);
4779 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4787 aulong = SvUV(fromstr);
4788 CAT32(cat, &aulong);
4793 #if LONGSIZE != SIZE32
4797 along = SvIV(fromstr);
4798 sv_catpvn(cat, (char *)&along, sizeof(long));
4806 along = SvIV(fromstr);
4815 auquad = (Uquad_t)SvIV(fromstr);
4816 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4822 aquad = (Quad_t)SvIV(fromstr);
4823 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4826 #endif /* HAS_QUAD */
4828 len = 1; /* assume SV is correct length */
4833 if (fromstr == &PL_sv_undef)
4837 /* XXX better yet, could spirit away the string to
4838 * a safe spot and hang on to it until the result
4839 * of pack() (and all copies of the result) are
4842 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4844 "Attempt to pack pointer to temporary value");
4845 if (SvPOK(fromstr) || SvNIOK(fromstr))
4846 aptr = SvPV(fromstr,n_a);
4848 aptr = SvPV_force(fromstr,n_a);
4850 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4855 aptr = SvPV(fromstr, fromlen);
4856 SvGROW(cat, fromlen * 4 / 3);
4861 while (fromlen > 0) {
4868 doencodes(cat, aptr, todo);
4887 register I32 limit = POPi; /* note, negative is forever */
4890 register char *s = SvPV(sv, len);
4891 char *strend = s + len;
4893 register REGEXP *rx;
4897 I32 maxiters = (strend - s) + 10;
4900 I32 origlimit = limit;
4903 AV *oldstack = PL_curstack;
4904 I32 gimme = GIMME_V;
4905 I32 oldsave = PL_savestack_ix;
4906 I32 make_mortal = 1;
4907 MAGIC *mg = (MAGIC *) NULL;
4910 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4915 DIE("panic: do_split");
4916 rx = pm->op_pmregexp;
4918 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4919 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4921 if (pm->op_pmreplroot)
4922 ary = GvAVn((GV*)pm->op_pmreplroot);
4923 else if (gimme != G_ARRAY)
4925 ary = (AV*)PL_curpad[0];
4927 ary = GvAVn(PL_defgv);
4928 #endif /* USE_THREADS */
4931 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4937 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4939 XPUSHs(SvTIED_obj((SV*)ary, mg));
4944 for (i = AvFILLp(ary); i >= 0; i--)
4945 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4947 /* temporarily switch stacks */
4948 SWITCHSTACK(PL_curstack, ary);
4952 base = SP - PL_stack_base;
4954 if (pm->op_pmflags & PMf_SKIPWHITE) {
4955 if (pm->op_pmflags & PMf_LOCALE) {
4956 while (isSPACE_LC(*s))
4964 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4965 SAVEINT(PL_multiline);
4966 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4970 limit = maxiters + 2;
4971 if (pm->op_pmflags & PMf_WHITE) {
4974 while (m < strend &&
4975 !((pm->op_pmflags & PMf_LOCALE)
4976 ? isSPACE_LC(*m) : isSPACE(*m)))
4981 dstr = NEWSV(30, m-s);
4982 sv_setpvn(dstr, s, m-s);
4988 while (s < strend &&
4989 ((pm->op_pmflags & PMf_LOCALE)
4990 ? isSPACE_LC(*s) : isSPACE(*s)))
4994 else if (strEQ("^", rx->precomp)) {
4997 for (m = s; m < strend && *m != '\n'; m++) ;
5001 dstr = NEWSV(30, m-s);
5002 sv_setpvn(dstr, s, m-s);
5009 else if (rx->check_substr && !rx->nparens
5010 && (rx->reganch & ROPT_CHECK_ALL)
5011 && !(rx->reganch & ROPT_ANCH)) {
5012 i = SvCUR(rx->check_substr);
5013 if (i == 1 && !SvTAIL(rx->check_substr)) {
5014 i = *SvPVX(rx->check_substr);
5017 for (m = s; m < strend && *m != i; m++) ;
5020 dstr = NEWSV(30, m-s);
5021 sv_setpvn(dstr, s, m-s);
5030 while (s < strend && --limit &&
5031 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
5032 rx->check_substr, 0)) )
5035 dstr = NEWSV(31, m-s);
5036 sv_setpvn(dstr, s, m-s);
5045 maxiters += (strend - s) * rx->nparens;
5046 while (s < strend && --limit &&
5047 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
5049 TAINT_IF(RX_MATCH_TAINTED(rx));
5051 && rx->subbase != orig) {
5056 strend = s + (strend - m);
5059 dstr = NEWSV(32, m-s);
5060 sv_setpvn(dstr, s, m-s);
5065 for (i = 1; i <= rx->nparens; i++) {
5069 dstr = NEWSV(33, m-s);
5070 sv_setpvn(dstr, s, m-s);
5073 dstr = NEWSV(33, 0);
5083 LEAVE_SCOPE(oldsave);
5084 iters = (SP - PL_stack_base) - base;
5085 if (iters > maxiters)
5088 /* keep field after final delim? */
5089 if (s < strend || (iters && origlimit)) {
5090 dstr = NEWSV(34, strend-s);
5091 sv_setpvn(dstr, s, strend-s);
5097 else if (!origlimit) {
5098 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5104 SWITCHSTACK(ary, oldstack);
5105 if (SvSMAGICAL(ary)) {
5110 if (gimme == G_ARRAY) {
5112 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5120 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5123 if (gimme == G_ARRAY) {
5124 /* EXTEND should not be needed - we just popped them */
5126 for (i=0; i < iters; i++) {
5127 SV **svp = av_fetch(ary, i, FALSE);
5128 PUSHs((svp) ? *svp : &PL_sv_undef);
5135 if (gimme == G_ARRAY)
5138 if (iters || !pm->op_pmreplroot) {
5148 unlock_condpair(void *svv)
5151 MAGIC *mg = mg_find((SV*)svv, 'm');
5154 croak("panic: unlock_condpair unlocking non-mutex");
5155 MUTEX_LOCK(MgMUTEXP(mg));
5156 if (MgOWNER(mg) != thr)
5157 croak("panic: unlock_condpair unlocking mutex that we don't own");
5159 COND_SIGNAL(MgOWNERCONDP(mg));
5160 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5161 (unsigned long)thr, (unsigned long)svv);)
5162 MUTEX_UNLOCK(MgMUTEXP(mg));
5164 #endif /* USE_THREADS */
5177 mg = condpair_magic(sv);
5178 MUTEX_LOCK(MgMUTEXP(mg));
5179 if (MgOWNER(mg) == thr)
5180 MUTEX_UNLOCK(MgMUTEXP(mg));
5183 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5185 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5186 (unsigned long)thr, (unsigned long)sv);)
5187 MUTEX_UNLOCK(MgMUTEXP(mg));
5188 save_destructor(unlock_condpair, sv);
5190 #endif /* USE_THREADS */
5191 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5192 || SvTYPE(retsv) == SVt_PVCV) {
5193 retsv = refto(retsv);
5204 if (PL_op->op_private & OPpLVAL_INTRO)
5205 PUSHs(*save_threadsv(PL_op->op_targ));
5207 PUSHs(THREADSV(PL_op->op_targ));
5210 DIE("tried to access per-thread data in non-threaded perl");
5211 #endif /* USE_THREADS */