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(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(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(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 /* Tried: DOUBLESIZE <= UV_SIZE = Precision of UV more than of NV.
1019 * But in fact this is an optimization - trunc may be slow */
1021 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1023 # define CAST_D2UV(d) U_V(d)
1025 # define CAST_D2UV(d) ((UV)(d))
1028 if (dright <= UV_MAX && dleft <= UV_MAX) {
1029 right = CAST_D2UV(dright);
1030 left = CAST_D2UV(dleft);
1035 /* Backward-compatibility clause: */
1037 dright = trunc(dright + 0.5);
1038 dleft = trunc(dleft + 0.5);
1040 dright = floor(dright + 0.5);
1041 dleft = floor(dleft + 0.5);
1045 DIE("Illegal modulus zero");
1047 dans = fmod(dleft, dright);
1048 if ((left_neg != right_neg) && dans)
1049 dans = dright - dans;
1052 sv_setnv(TARG, dans);
1059 DIE("Illegal modulus zero");
1062 if ((left_neg != right_neg) && ans)
1065 /* XXX may warn: unary minus operator applied to unsigned type */
1066 /* could change -foo to be (~foo)+1 instead */
1067 if (ans <= ~((UV)IV_MAX)+1)
1068 sv_setiv(TARG, ~ans+1);
1070 sv_setnv(TARG, -(double)ans);
1073 sv_setuv(TARG, ans);
1082 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1084 register I32 count = POPi;
1085 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1087 I32 items = SP - MARK;
1090 max = items * count;
1099 repeatcpy((char*)(MARK + items), (char*)MARK,
1100 items * sizeof(SV*), count - 1);
1103 else if (count <= 0)
1106 else { /* Note: mark already snarfed by pp_list */
1111 SvSetSV(TARG, tmpstr);
1112 SvPV_force(TARG, len);
1117 SvGROW(TARG, (count * len) + 1);
1118 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1119 SvCUR(TARG) *= count;
1121 *SvEND(TARG) = '\0';
1123 (void)SvPOK_only(TARG);
1132 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1135 SETn( left - right );
1142 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1145 if (PL_op->op_private & HINT_INTEGER) {
1147 i = BWi(i) << shift;
1161 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1164 if (PL_op->op_private & HINT_INTEGER) {
1166 i = BWi(i) >> shift;
1180 djSP; tryAMAGICbinSET(lt,0);
1183 SETs(boolSV(TOPn < value));
1190 djSP; tryAMAGICbinSET(gt,0);
1193 SETs(boolSV(TOPn > value));
1200 djSP; tryAMAGICbinSET(le,0);
1203 SETs(boolSV(TOPn <= value));
1210 djSP; tryAMAGICbinSET(ge,0);
1213 SETs(boolSV(TOPn >= value));
1220 djSP; tryAMAGICbinSET(ne,0);
1223 SETs(boolSV(TOPn != value));
1230 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1237 else if (left < right)
1239 else if (left > right)
1252 djSP; tryAMAGICbinSET(slt,0);
1255 int cmp = ((PL_op->op_private & OPpLOCALE)
1256 ? sv_cmp_locale(left, right)
1257 : sv_cmp(left, right));
1258 SETs(boolSV(cmp < 0));
1265 djSP; tryAMAGICbinSET(sgt,0);
1268 int cmp = ((PL_op->op_private & OPpLOCALE)
1269 ? sv_cmp_locale(left, right)
1270 : sv_cmp(left, right));
1271 SETs(boolSV(cmp > 0));
1278 djSP; tryAMAGICbinSET(sle,0);
1281 int cmp = ((PL_op->op_private & OPpLOCALE)
1282 ? sv_cmp_locale(left, right)
1283 : sv_cmp(left, right));
1284 SETs(boolSV(cmp <= 0));
1291 djSP; tryAMAGICbinSET(sge,0);
1294 int cmp = ((PL_op->op_private & OPpLOCALE)
1295 ? sv_cmp_locale(left, right)
1296 : sv_cmp(left, right));
1297 SETs(boolSV(cmp >= 0));
1304 djSP; tryAMAGICbinSET(seq,0);
1307 SETs(boolSV(sv_eq(left, right)));
1314 djSP; tryAMAGICbinSET(sne,0);
1317 SETs(boolSV(!sv_eq(left, right)));
1324 djSP; dTARGET; tryAMAGICbin(scmp,0);
1327 int cmp = ((PL_op->op_private & OPpLOCALE)
1328 ? sv_cmp_locale(left, right)
1329 : sv_cmp(left, right));
1337 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1340 if (SvNIOKp(left) || SvNIOKp(right)) {
1341 if (PL_op->op_private & HINT_INTEGER) {
1342 IBW value = SvIV(left) & SvIV(right);
1346 UBW value = SvUV(left) & SvUV(right);
1351 do_vop(PL_op->op_type, TARG, left, right);
1360 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1363 if (SvNIOKp(left) || SvNIOKp(right)) {
1364 if (PL_op->op_private & HINT_INTEGER) {
1365 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1369 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1374 do_vop(PL_op->op_type, TARG, left, right);
1383 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1386 if (SvNIOKp(left) || SvNIOKp(right)) {
1387 if (PL_op->op_private & HINT_INTEGER) {
1388 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1392 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1397 do_vop(PL_op->op_type, TARG, left, right);
1406 djSP; dTARGET; tryAMAGICun(neg);
1411 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1413 else if (SvNIOKp(sv))
1415 else if (SvPOKp(sv)) {
1417 char *s = SvPV(sv, len);
1418 if (isIDFIRST(*s)) {
1419 sv_setpvn(TARG, "-", 1);
1422 else if (*s == '+' || *s == '-') {
1424 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1426 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1427 sv_setpvn(TARG, "-", 1);
1431 sv_setnv(TARG, -SvNV(sv));
1442 djSP; tryAMAGICunSET(not);
1443 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1449 djSP; dTARGET; tryAMAGICun(compl);
1453 if (PL_op->op_private & HINT_INTEGER) {
1454 IBW value = ~SvIV(sv);
1458 UBW value = ~SvUV(sv);
1463 register char *tmps;
1464 register long *tmpl;
1469 tmps = SvPV_force(TARG, len);
1472 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1475 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1479 for ( ; anum > 0; anum--, tmps++)
1488 /* integer versions of some of the above */
1492 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1495 SETi( left * right );
1502 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1506 DIE("Illegal division by zero");
1507 value = POPi / value;
1515 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1519 DIE("Illegal modulus zero");
1520 SETi( left % right );
1527 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1530 SETi( left + right );
1537 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1540 SETi( left - right );
1547 djSP; tryAMAGICbinSET(lt,0);
1550 SETs(boolSV(left < right));
1557 djSP; tryAMAGICbinSET(gt,0);
1560 SETs(boolSV(left > right));
1567 djSP; tryAMAGICbinSET(le,0);
1570 SETs(boolSV(left <= right));
1577 djSP; tryAMAGICbinSET(ge,0);
1580 SETs(boolSV(left >= right));
1587 djSP; tryAMAGICbinSET(eq,0);
1590 SETs(boolSV(left == right));
1597 djSP; tryAMAGICbinSET(ne,0);
1600 SETs(boolSV(left != right));
1607 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1614 else if (left < right)
1625 djSP; dTARGET; tryAMAGICun(neg);
1630 /* High falutin' math. */
1634 djSP; dTARGET; tryAMAGICbin(atan2,0);
1637 SETn(atan2(left, right));
1644 djSP; dTARGET; tryAMAGICun(sin);
1656 djSP; dTARGET; tryAMAGICun(cos);
1666 /* Support Configure command-line overrides for rand() functions.
1667 After 5.005, perhaps we should replace this by Configure support
1668 for drand48(), random(), or rand(). For 5.005, though, maintain
1669 compatibility by calling rand() but allow the user to override it.
1670 See INSTALL for details. --Andy Dougherty 15 July 1998
1672 /* Now it's after 5.005, and Configure supports drand48() and random(),
1673 in addition to rand(). So the overrides should not be needed any more.
1674 --Jarkko Hietaniemi 27 September 1998
1677 #ifndef HAS_DRAND48_PROTO
1678 extern double drand48 _((void));
1691 if (!PL_srand_called) {
1692 (void)seedDrand01((Rand_seed_t)seed());
1693 PL_srand_called = TRUE;
1708 (void)seedDrand01((Rand_seed_t)anum);
1709 PL_srand_called = TRUE;
1718 * This is really just a quick hack which grabs various garbage
1719 * values. It really should be a real hash algorithm which
1720 * spreads the effect of every input bit onto every output bit,
1721 * if someone who knows about such things would bother to write it.
1722 * Might be a good idea to add that function to CORE as well.
1723 * No numbers below come from careful analysis or anything here,
1724 * except they are primes and SEED_C1 > 1E6 to get a full-width
1725 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1726 * probably be bigger too.
1729 # define SEED_C1 1000003
1730 #define SEED_C4 73819
1732 # define SEED_C1 25747
1733 #define SEED_C4 20639
1737 #define SEED_C5 26107
1740 #ifndef PERL_NO_DEV_RANDOM
1745 # include <starlet.h>
1746 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1747 * in 100-ns units, typically incremented ever 10 ms. */
1748 unsigned int when[2];
1750 # ifdef HAS_GETTIMEOFDAY
1751 struct timeval when;
1757 /* This test is an escape hatch, this symbol isn't set by Configure. */
1758 #ifndef PERL_NO_DEV_RANDOM
1759 #ifndef PERL_RANDOM_DEVICE
1760 /* /dev/random isn't used by default because reads from it will block
1761 * if there isn't enough entropy available. You can compile with
1762 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1763 * is enough real entropy to fill the seed. */
1764 # define PERL_RANDOM_DEVICE "/dev/urandom"
1766 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1768 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1777 _ckvmssts(sys$gettim(when));
1778 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1780 # ifdef HAS_GETTIMEOFDAY
1781 gettimeofday(&when,(struct timezone *) 0);
1782 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1785 u = (U32)SEED_C1 * when;
1788 u += SEED_C3 * (U32)getpid();
1789 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1790 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1791 u += SEED_C5 * (U32)(UV)&when;
1798 djSP; dTARGET; tryAMAGICun(exp);
1810 djSP; dTARGET; tryAMAGICun(log);
1815 SET_NUMERIC_STANDARD();
1816 DIE("Can't take log of %g", value);
1826 djSP; dTARGET; tryAMAGICun(sqrt);
1831 SET_NUMERIC_STANDARD();
1832 DIE("Can't take sqrt of %g", value);
1834 value = sqrt(value);
1844 double value = TOPn;
1847 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1853 (void)modf(value, &value);
1855 (void)modf(-value, &value);
1870 djSP; dTARGET; tryAMAGICun(abs);
1872 double value = TOPn;
1875 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1876 (iv = SvIVX(TOPs)) != IV_MIN) {
1898 XPUSHu(scan_hex(tmps, 99, &argtype));
1911 while (*tmps && isSPACE(*tmps))
1916 value = scan_hex(++tmps, 99, &argtype);
1917 else if (*tmps == 'b')
1918 value = scan_bin(++tmps, 99, &argtype);
1920 value = scan_oct(tmps, 99, &argtype);
1932 SETi( sv_len_utf8(TOPs) );
1936 SETi( sv_len(TOPs) );
1950 I32 lvalue = PL_op->op_flags & OPf_MOD;
1952 I32 arybase = PL_curcop->cop_arybase;
1956 SvTAINTED_off(TARG); /* decontaminate */
1960 repl = SvPV(sv, repl_len);
1967 tmps = SvPV(sv, curlen);
1969 utfcurlen = sv_len_utf8(sv);
1970 if (utfcurlen == curlen)
1978 if (pos >= arybase) {
1996 else if (len >= 0) {
1998 if (rem > (I32)curlen)
2012 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2013 warner(WARN_SUBSTR, "substr outside of string");
2018 sv_pos_u2b(sv, &pos, &rem);
2020 sv_setpvn(TARG, tmps, rem);
2021 if (lvalue) { /* it's an lvalue! */
2022 if (!SvGMAGICAL(sv)) {
2026 if (ckWARN(WARN_SUBSTR))
2028 "Attempt to use reference as lvalue in substr");
2030 if (SvOK(sv)) /* is it defined ? */
2031 (void)SvPOK_only(sv);
2033 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2036 if (SvTYPE(TARG) < SVt_PVLV) {
2037 sv_upgrade(TARG, SVt_PVLV);
2038 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2042 if (LvTARG(TARG) != sv) {
2044 SvREFCNT_dec(LvTARG(TARG));
2045 LvTARG(TARG) = SvREFCNT_inc(sv);
2047 LvTARGOFF(TARG) = pos;
2048 LvTARGLEN(TARG) = rem;
2051 sv_insert(sv, pos, rem, repl, repl_len);
2054 PUSHs(TARG); /* avoid SvSETMAGIC here */
2061 register I32 size = POPi;
2062 register I32 offset = POPi;
2063 register SV *src = POPs;
2064 I32 lvalue = PL_op->op_flags & OPf_MOD;
2066 unsigned char *s = (unsigned char*)SvPV(src, srclen);
2067 unsigned long retnum;
2070 SvTAINTED_off(TARG); /* decontaminate */
2071 offset *= size; /* turn into bit offset */
2072 len = (offset + size + 7) / 8;
2073 if (offset < 0 || size < 1)
2076 if (lvalue) { /* it's an lvalue! */
2077 if (SvTYPE(TARG) < SVt_PVLV) {
2078 sv_upgrade(TARG, SVt_PVLV);
2079 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2083 if (LvTARG(TARG) != src) {
2085 SvREFCNT_dec(LvTARG(TARG));
2086 LvTARG(TARG) = SvREFCNT_inc(src);
2088 LvTARGOFF(TARG) = offset;
2089 LvTARGLEN(TARG) = size;
2097 if (offset >= srclen)
2100 retnum = (unsigned long) s[offset] << 8;
2102 else if (size == 32) {
2103 if (offset >= srclen)
2105 else if (offset + 1 >= srclen)
2106 retnum = (unsigned long) s[offset] << 24;
2107 else if (offset + 2 >= srclen)
2108 retnum = ((unsigned long) s[offset] << 24) +
2109 ((unsigned long) s[offset + 1] << 16);
2111 retnum = ((unsigned long) s[offset] << 24) +
2112 ((unsigned long) s[offset + 1] << 16) +
2113 (s[offset + 2] << 8);
2118 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2123 else if (size == 16)
2124 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2125 else if (size == 32)
2126 retnum = ((unsigned long) s[offset] << 24) +
2127 ((unsigned long) s[offset + 1] << 16) +
2128 (s[offset + 2] << 8) + s[offset+3];
2132 sv_setuv(TARG, (UV)retnum);
2147 I32 arybase = PL_curcop->cop_arybase;
2152 offset = POPi - arybase;
2155 tmps = SvPV(big, biglen);
2156 if (IN_UTF8 && offset > 0)
2157 sv_pos_u2b(big, &offset, 0);
2160 else if (offset > biglen)
2162 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2163 (unsigned char*)tmps + biglen, little, 0)))
2166 retval = tmps2 - tmps;
2167 if (IN_UTF8 && retval > 0)
2168 sv_pos_b2u(big, &retval);
2169 PUSHi(retval + arybase);
2184 I32 arybase = PL_curcop->cop_arybase;
2190 tmps2 = SvPV(little, llen);
2191 tmps = SvPV(big, blen);
2195 if (IN_UTF8 && offset > 0)
2196 sv_pos_u2b(big, &offset, 0);
2197 offset = offset - arybase + llen;
2201 else if (offset > blen)
2203 if (!(tmps2 = rninstr(tmps, tmps + offset,
2204 tmps2, tmps2 + llen)))
2207 retval = tmps2 - tmps;
2208 if (IN_UTF8 && retval > 0)
2209 sv_pos_b2u(big, &retval);
2210 PUSHi(retval + arybase);
2216 djSP; dMARK; dORIGMARK; dTARGET;
2217 #ifdef USE_LOCALE_NUMERIC
2218 if (PL_op->op_private & OPpLOCALE)
2219 SET_NUMERIC_LOCAL();
2221 SET_NUMERIC_STANDARD();
2223 do_sprintf(TARG, SP-MARK, MARK+1);
2224 TAINT_IF(SvTAINTED(TARG));
2235 U8 *tmps = (U8*)POPpx;
2238 if (IN_UTF8 && (*tmps & 0x80))
2239 value = utf8_to_uv(tmps, &retlen);
2241 value = (UV)(*tmps & 255);
2252 (void)SvUPGRADE(TARG,SVt_PV);
2254 if (IN_UTF8 && value >= 128) {
2257 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2258 SvCUR_set(TARG, tmps - SvPVX(TARG));
2260 (void)SvPOK_only(TARG);
2270 (void)SvPOK_only(TARG);
2277 djSP; dTARGET; dPOPTOPssrl;
2280 char *tmps = SvPV(left, n_a);
2282 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2284 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2288 "The crypt() function is unimplemented due to excessive paranoia.");
2301 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2305 UV uv = utf8_to_uv(s, &ulen);
2307 if (PL_op->op_private & OPpLOCALE) {
2310 uv = toTITLE_LC_uni(uv);
2313 uv = toTITLE_utf8(s);
2315 tend = uv_to_utf8(tmpbuf, uv);
2317 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2319 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2320 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2324 s = (U8*)SvPV_force(sv, slen);
2325 Copy(tmpbuf, s, ulen, U8);
2330 if (!SvPADTMP(sv)) {
2336 s = (U8*)SvPV_force(sv, slen);
2338 if (PL_op->op_private & OPpLOCALE) {
2341 *s = toUPPER_LC(*s);
2357 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2361 UV uv = utf8_to_uv(s, &ulen);
2363 if (PL_op->op_private & OPpLOCALE) {
2366 uv = toLOWER_LC_uni(uv);
2369 uv = toLOWER_utf8(s);
2371 tend = uv_to_utf8(tmpbuf, uv);
2373 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2375 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2376 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2380 s = (U8*)SvPV_force(sv, slen);
2381 Copy(tmpbuf, s, ulen, U8);
2386 if (!SvPADTMP(sv)) {
2392 s = (U8*)SvPV_force(sv, slen);
2394 if (PL_op->op_private & OPpLOCALE) {
2397 *s = toLOWER_LC(*s);
2420 s = (U8*)SvPV(sv,len);
2422 sv_setpvn(TARG, "", 0);
2427 (void)SvUPGRADE(TARG, SVt_PV);
2428 SvGROW(TARG, (len * 2) + 1);
2429 (void)SvPOK_only(TARG);
2430 d = (U8*)SvPVX(TARG);
2432 if (PL_op->op_private & OPpLOCALE) {
2436 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2442 d = uv_to_utf8(d, toUPPER_utf8( s ));
2447 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2452 if (!SvPADTMP(sv)) {
2459 s = (U8*)SvPV_force(sv, len);
2461 register U8 *send = s + len;
2463 if (PL_op->op_private & OPpLOCALE) {
2466 for (; s < send; s++)
2467 *s = toUPPER_LC(*s);
2470 for (; s < send; s++)
2490 s = (U8*)SvPV(sv,len);
2492 sv_setpvn(TARG, "", 0);
2497 (void)SvUPGRADE(TARG, SVt_PV);
2498 SvGROW(TARG, (len * 2) + 1);
2499 (void)SvPOK_only(TARG);
2500 d = (U8*)SvPVX(TARG);
2502 if (PL_op->op_private & OPpLOCALE) {
2506 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2512 d = uv_to_utf8(d, toLOWER_utf8(s));
2517 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2522 if (!SvPADTMP(sv)) {
2529 s = (U8*)SvPV_force(sv, len);
2531 register U8 *send = s + len;
2533 if (PL_op->op_private & OPpLOCALE) {
2536 for (; s < send; s++)
2537 *s = toLOWER_LC(*s);
2540 for (; s < send; s++)
2552 register char *s = SvPV(sv,len);
2556 (void)SvUPGRADE(TARG, SVt_PV);
2557 SvGROW(TARG, (len * 2) + 1);
2562 STRLEN ulen = UTF8SKIP(s);
2585 SvCUR_set(TARG, d - SvPVX(TARG));
2586 (void)SvPOK_only(TARG);
2589 sv_setpvn(TARG, s, len);
2598 djSP; dMARK; dORIGMARK;
2600 register AV* av = (AV*)POPs;
2601 register I32 lval = PL_op->op_flags & OPf_MOD;
2602 I32 arybase = PL_curcop->cop_arybase;
2605 if (SvTYPE(av) == SVt_PVAV) {
2606 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2608 for (svp = MARK + 1; svp <= SP; svp++) {
2613 if (max > AvMAX(av))
2616 while (++MARK <= SP) {
2617 elem = SvIVx(*MARK);
2621 svp = av_fetch(av, elem, lval);
2623 if (!svp || *svp == &PL_sv_undef)
2624 DIE(PL_no_aelem, elem);
2625 if (PL_op->op_private & OPpLVAL_INTRO)
2626 save_aelem(av, elem, svp);
2628 *MARK = svp ? *svp : &PL_sv_undef;
2631 if (GIMME != G_ARRAY) {
2639 /* Associative arrays. */
2644 HV *hash = (HV*)POPs;
2646 I32 gimme = GIMME_V;
2647 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2650 /* might clobber stack_sp */
2651 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2656 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2657 if (gimme == G_ARRAY) {
2659 /* might clobber stack_sp */
2660 sv_setsv(TARG, realhv ?
2661 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2666 else if (gimme == G_SCALAR)
2685 I32 gimme = GIMME_V;
2686 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2690 if (PL_op->op_private & OPpSLICE) {
2694 hvtype = SvTYPE(hv);
2695 while (++MARK <= SP) {
2696 if (hvtype == SVt_PVHV)
2697 sv = hv_delete_ent(hv, *MARK, discard, 0);
2699 DIE("Not a HASH reference");
2700 *MARK = sv ? sv : &PL_sv_undef;
2704 else if (gimme == G_SCALAR) {
2713 if (SvTYPE(hv) == SVt_PVHV)
2714 sv = hv_delete_ent(hv, keysv, discard, 0);
2716 DIE("Not a HASH reference");
2730 if (SvTYPE(hv) == SVt_PVHV) {
2731 if (hv_exists_ent(hv, tmpsv, 0))
2734 else if (SvTYPE(hv) == SVt_PVAV) {
2735 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2739 DIE("Not a HASH reference");
2746 djSP; dMARK; dORIGMARK;
2747 register HV *hv = (HV*)POPs;
2748 register I32 lval = PL_op->op_flags & OPf_MOD;
2749 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2751 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2752 DIE("Can't localize pseudo-hash element");
2754 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2755 while (++MARK <= SP) {
2759 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2760 svp = he ? &HeVAL(he) : 0;
2763 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2766 if (!svp || *svp == &PL_sv_undef) {
2768 DIE(PL_no_helem, SvPV(keysv, n_a));
2770 if (PL_op->op_private & OPpLVAL_INTRO)
2771 save_helem(hv, keysv, svp);
2773 *MARK = svp ? *svp : &PL_sv_undef;
2776 if (GIMME != G_ARRAY) {
2784 /* List operators. */
2789 if (GIMME != G_ARRAY) {
2791 *MARK = *SP; /* unwanted list, return last item */
2793 *MARK = &PL_sv_undef;
2802 SV **lastrelem = PL_stack_sp;
2803 SV **lastlelem = PL_stack_base + POPMARK;
2804 SV **firstlelem = PL_stack_base + POPMARK + 1;
2805 register SV **firstrelem = lastlelem + 1;
2806 I32 arybase = PL_curcop->cop_arybase;
2807 I32 lval = PL_op->op_flags & OPf_MOD;
2808 I32 is_something_there = lval;
2810 register I32 max = lastrelem - lastlelem;
2811 register SV **lelem;
2814 if (GIMME != G_ARRAY) {
2815 ix = SvIVx(*lastlelem);
2820 if (ix < 0 || ix >= max)
2821 *firstlelem = &PL_sv_undef;
2823 *firstlelem = firstrelem[ix];
2829 SP = firstlelem - 1;
2833 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2838 *lelem = &PL_sv_undef;
2839 else if (!(*lelem = firstrelem[ix]))
2840 *lelem = &PL_sv_undef;
2844 if (ix >= max || !(*lelem = firstrelem[ix]))
2845 *lelem = &PL_sv_undef;
2847 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2848 is_something_there = TRUE;
2850 if (is_something_there)
2853 SP = firstlelem - 1;
2859 djSP; dMARK; dORIGMARK;
2860 I32 items = SP - MARK;
2861 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2862 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2869 djSP; dMARK; dORIGMARK;
2870 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2874 SV *val = NEWSV(46, 0);
2876 sv_setsv(val, *++MARK);
2877 else if (ckWARN(WARN_UNSAFE))
2878 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2879 (void)hv_store_ent(hv,key,val,0);
2888 djSP; dMARK; dORIGMARK;
2889 register AV *ary = (AV*)*++MARK;
2893 register I32 offset;
2894 register I32 length;
2901 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2902 *MARK-- = SvTIED_obj((SV*)ary, mg);
2906 perl_call_method("SPLICE",GIMME_V);
2915 offset = i = SvIVx(*MARK);
2917 offset += AvFILLp(ary) + 1;
2919 offset -= PL_curcop->cop_arybase;
2921 DIE(PL_no_aelem, i);
2923 length = SvIVx(*MARK++);
2925 length += AvFILLp(ary) - offset + 1;
2931 length = AvMAX(ary) + 1; /* close enough to infinity */
2935 length = AvMAX(ary) + 1;
2937 if (offset > AvFILLp(ary) + 1)
2938 offset = AvFILLp(ary) + 1;
2939 after = AvFILLp(ary) + 1 - (offset + length);
2940 if (after < 0) { /* not that much array */
2941 length += after; /* offset+length now in array */
2947 /* At this point, MARK .. SP-1 is our new LIST */
2950 diff = newlen - length;
2951 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2954 if (diff < 0) { /* shrinking the area */
2956 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2957 Copy(MARK, tmparyval, newlen, SV*);
2960 MARK = ORIGMARK + 1;
2961 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2962 MEXTEND(MARK, length);
2963 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2965 EXTEND_MORTAL(length);
2966 for (i = length, dst = MARK; i; i--) {
2967 sv_2mortal(*dst); /* free them eventualy */
2974 *MARK = AvARRAY(ary)[offset+length-1];
2977 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2978 SvREFCNT_dec(*dst++); /* free them now */
2981 AvFILLp(ary) += diff;
2983 /* pull up or down? */
2985 if (offset < after) { /* easier to pull up */
2986 if (offset) { /* esp. if nothing to pull */
2987 src = &AvARRAY(ary)[offset-1];
2988 dst = src - diff; /* diff is negative */
2989 for (i = offset; i > 0; i--) /* can't trust Copy */
2993 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2997 if (after) { /* anything to pull down? */
2998 src = AvARRAY(ary) + offset + length;
2999 dst = src + diff; /* diff is negative */
3000 Move(src, dst, after, SV*);
3002 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3003 /* avoid later double free */
3007 dst[--i] = &PL_sv_undef;
3010 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3012 *dst = NEWSV(46, 0);
3013 sv_setsv(*dst++, *src++);
3015 Safefree(tmparyval);
3018 else { /* no, expanding (or same) */
3020 New(452, tmparyval, length, SV*); /* so remember deletion */
3021 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3024 if (diff > 0) { /* expanding */
3026 /* push up or down? */
3028 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3032 Move(src, dst, offset, SV*);
3034 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3036 AvFILLp(ary) += diff;
3039 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3040 av_extend(ary, AvFILLp(ary) + diff);
3041 AvFILLp(ary) += diff;
3044 dst = AvARRAY(ary) + AvFILLp(ary);
3046 for (i = after; i; i--) {
3053 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3054 *dst = NEWSV(46, 0);
3055 sv_setsv(*dst++, *src++);
3057 MARK = ORIGMARK + 1;
3058 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3060 Copy(tmparyval, MARK, length, SV*);
3062 EXTEND_MORTAL(length);
3063 for (i = length, dst = MARK; i; i--) {
3064 sv_2mortal(*dst); /* free them eventualy */
3068 Safefree(tmparyval);
3072 else if (length--) {
3073 *MARK = tmparyval[length];
3076 while (length-- > 0)
3077 SvREFCNT_dec(tmparyval[length]);
3079 Safefree(tmparyval);
3082 *MARK = &PL_sv_undef;
3090 djSP; dMARK; dORIGMARK; dTARGET;
3091 register AV *ary = (AV*)*++MARK;
3092 register SV *sv = &PL_sv_undef;
3095 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3096 *MARK-- = SvTIED_obj((SV*)ary, mg);
3100 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3105 /* Why no pre-extend of ary here ? */
3106 for (++MARK; MARK <= SP; MARK++) {
3109 sv_setsv(sv, *MARK);
3114 PUSHi( AvFILL(ary) + 1 );
3122 SV *sv = av_pop(av);
3124 (void)sv_2mortal(sv);
3133 SV *sv = av_shift(av);
3138 (void)sv_2mortal(sv);
3145 djSP; dMARK; dORIGMARK; dTARGET;
3146 register AV *ary = (AV*)*++MARK;
3151 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3152 *MARK-- = SvTIED_obj((SV*)ary, mg);
3156 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3161 av_unshift(ary, SP - MARK);
3164 sv_setsv(sv, *++MARK);
3165 (void)av_store(ary, i++, sv);
3169 PUSHi( AvFILL(ary) + 1 );
3179 if (GIMME == G_ARRAY) {
3190 register char *down;
3196 do_join(TARG, &PL_sv_no, MARK, SP);
3198 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3199 up = SvPV_force(TARG, len);
3201 if (IN_UTF8) { /* first reverse each character */
3202 U8* s = (U8*)SvPVX(TARG);
3203 U8* send = (U8*)(s + len);
3212 down = (char*)(s - 1);
3213 if (s > send || !((*down & 0xc0) == 0x80)) {
3214 warn("Malformed UTF-8 character");
3226 down = SvPVX(TARG) + len - 1;
3232 (void)SvPOK_only(TARG);
3241 mul128(SV *sv, U8 m)
3244 char *s = SvPV(sv, len);
3248 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3249 SV *tmpNew = newSVpvn("0000000000", 10);
3251 sv_catsv(tmpNew, sv);
3252 SvREFCNT_dec(sv); /* free old sv */
3257 while (!*t) /* trailing '\0'? */
3260 i = ((*t - '0') << 7) + m;
3261 *(t--) = '0' + (i % 10);
3267 /* Explosives and implosives. */
3269 #if 'I' == 73 && 'J' == 74
3270 /* On an ASCII/ISO kind of system */
3271 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3274 Some other sort of character set - use memchr() so we don't match
3277 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3285 I32 gimme = GIMME_V;
3289 register char *pat = SvPV(left, llen);
3290 register char *s = SvPV(right, rlen);
3291 char *strend = s + rlen;
3293 register char *patend = pat + llen;
3298 /* These must not be in registers: */
3315 register U32 culong;
3318 #ifdef PERL_NATINT_PACK
3319 int natint; /* native integer */
3320 int unatint; /* unsigned native integer */
3323 if (gimme != G_ARRAY) { /* arrange to do first one only */
3325 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3326 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3328 while (isDIGIT(*patend) || *patend == '*')
3334 while (pat < patend) {
3336 datumtype = *pat++ & 0xFF;
3337 #ifdef PERL_NATINT_PACK
3340 if (isSPACE(datumtype))
3343 char *natstr = "sSiIlL";
3345 if (strchr(natstr, datumtype)) {
3346 #ifdef PERL_NATINT_PACK
3352 croak("'!' allowed only after types %s", natstr);
3356 else if (*pat == '*') {
3357 len = strend - strbeg; /* long enough */
3360 else if (isDIGIT(*pat)) {
3362 while (isDIGIT(*pat))
3363 len = (len * 10) + (*pat++ - '0');
3366 len = (datumtype != '@');
3369 croak("Invalid type in unpack: '%c'", (int)datumtype);
3370 case ',': /* grandfather in commas but with a warning */
3371 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3372 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3375 if (len == 1 && pat[-1] != '1')
3384 if (len > strend - strbeg)
3385 DIE("@ outside of string");
3389 if (len > s - strbeg)
3390 DIE("X outside of string");
3394 if (len > strend - s)
3395 DIE("x outside of string");
3401 if (len > strend - s)
3404 goto uchar_checksum;
3405 sv = NEWSV(35, len);
3406 sv_setpvn(sv, s, len);
3408 if (datumtype == 'A' || datumtype == 'Z') {
3409 aptr = s; /* borrow register */
3410 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3415 else { /* 'A' strips both nulls and spaces */
3416 s = SvPVX(sv) + len - 1;
3417 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3421 SvCUR_set(sv, s - SvPVX(sv));
3422 s = aptr; /* unborrow register */
3424 XPUSHs(sv_2mortal(sv));
3428 if (pat[-1] == '*' || len > (strend - s) * 8)
3429 len = (strend - s) * 8;
3432 Newz(601, PL_bitcount, 256, char);
3433 for (bits = 1; bits < 256; bits++) {
3434 if (bits & 1) PL_bitcount[bits]++;
3435 if (bits & 2) PL_bitcount[bits]++;
3436 if (bits & 4) PL_bitcount[bits]++;
3437 if (bits & 8) PL_bitcount[bits]++;
3438 if (bits & 16) PL_bitcount[bits]++;
3439 if (bits & 32) PL_bitcount[bits]++;
3440 if (bits & 64) PL_bitcount[bits]++;
3441 if (bits & 128) PL_bitcount[bits]++;
3445 culong += PL_bitcount[*(unsigned char*)s++];
3450 if (datumtype == 'b') {
3452 if (bits & 1) culong++;
3458 if (bits & 128) culong++;
3465 sv = NEWSV(35, len + 1);
3468 aptr = pat; /* borrow register */
3470 if (datumtype == 'b') {
3472 for (len = 0; len < aint; len++) {
3473 if (len & 7) /*SUPPRESS 595*/
3477 *pat++ = '0' + (bits & 1);
3482 for (len = 0; len < aint; len++) {
3487 *pat++ = '0' + ((bits & 128) != 0);
3491 pat = aptr; /* unborrow register */
3492 XPUSHs(sv_2mortal(sv));
3496 if (pat[-1] == '*' || len > (strend - s) * 2)
3497 len = (strend - s) * 2;
3498 sv = NEWSV(35, len + 1);
3501 aptr = pat; /* borrow register */
3503 if (datumtype == 'h') {
3505 for (len = 0; len < aint; len++) {
3510 *pat++ = PL_hexdigit[bits & 15];
3515 for (len = 0; len < aint; len++) {
3520 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3524 pat = aptr; /* unborrow register */
3525 XPUSHs(sv_2mortal(sv));
3528 if (len > strend - s)
3533 if (aint >= 128) /* fake up signed chars */
3543 if (aint >= 128) /* fake up signed chars */
3546 sv_setiv(sv, (IV)aint);
3547 PUSHs(sv_2mortal(sv));
3552 if (len > strend - s)
3567 sv_setiv(sv, (IV)auint);
3568 PUSHs(sv_2mortal(sv));
3573 if (len > strend - s)
3576 while (len-- > 0 && s < strend) {
3577 auint = utf8_to_uv((U8*)s, &along);
3580 cdouble += (double)auint;
3588 while (len-- > 0 && s < strend) {
3589 auint = utf8_to_uv((U8*)s, &along);
3592 sv_setuv(sv, (UV)auint);
3593 PUSHs(sv_2mortal(sv));
3598 #if SHORTSIZE == SIZE16
3599 along = (strend - s) / SIZE16;
3601 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3606 #if SHORTSIZE != SIZE16
3609 COPYNN(s, &ashort, sizeof(short));
3620 #if SHORTSIZE > SIZE16
3632 #if SHORTSIZE != SIZE16
3635 COPYNN(s, &ashort, sizeof(short));
3638 sv_setiv(sv, (IV)ashort);
3639 PUSHs(sv_2mortal(sv));
3647 #if SHORTSIZE > SIZE16
3653 sv_setiv(sv, (IV)ashort);
3654 PUSHs(sv_2mortal(sv));
3662 #if SHORTSIZE == SIZE16
3663 along = (strend - s) / SIZE16;
3665 unatint = natint && datumtype == 'S';
3666 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3671 #if SHORTSIZE != SIZE16
3674 COPYNN(s, &aushort, sizeof(unsigned short));
3675 s += sizeof(unsigned short);
3683 COPY16(s, &aushort);
3686 if (datumtype == 'n')
3687 aushort = PerlSock_ntohs(aushort);
3690 if (datumtype == 'v')
3691 aushort = vtohs(aushort);
3700 #if SHORTSIZE != SIZE16
3703 COPYNN(s, &aushort, sizeof(unsigned short));
3704 s += sizeof(unsigned short);
3706 sv_setiv(sv, (UV)aushort);
3707 PUSHs(sv_2mortal(sv));
3714 COPY16(s, &aushort);
3718 if (datumtype == 'n')
3719 aushort = PerlSock_ntohs(aushort);
3722 if (datumtype == 'v')
3723 aushort = vtohs(aushort);
3725 sv_setiv(sv, (UV)aushort);
3726 PUSHs(sv_2mortal(sv));
3732 along = (strend - s) / sizeof(int);
3737 Copy(s, &aint, 1, int);
3740 cdouble += (double)aint;
3749 Copy(s, &aint, 1, int);
3753 /* Without the dummy below unpack("i", pack("i",-1))
3754 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3755 * cc with optimization turned on.
3757 * The bug was detected in
3758 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3759 * with optimization (-O4) turned on.
3760 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3761 * does not have this problem even with -O4.
3763 * This bug was reported as DECC_BUGS 1431
3764 * and tracked internally as GEM_BUGS 7775.
3766 * The bug is fixed in
3767 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3768 * UNIX V4.0F support: DEC C V5.9-006 or later
3769 * UNIX V4.0E support: DEC C V5.8-011 or later
3772 * See also few lines later for the same bug.
3775 sv_setiv(sv, (IV)aint) :
3777 sv_setiv(sv, (IV)aint);
3778 PUSHs(sv_2mortal(sv));
3783 along = (strend - s) / sizeof(unsigned int);
3788 Copy(s, &auint, 1, unsigned int);
3789 s += sizeof(unsigned int);
3791 cdouble += (double)auint;
3800 Copy(s, &auint, 1, unsigned int);
3801 s += sizeof(unsigned int);
3804 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3805 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3806 * See details few lines earlier. */
3808 sv_setuv(sv, (UV)auint) :
3810 sv_setuv(sv, (UV)auint);
3811 PUSHs(sv_2mortal(sv));
3816 #if LONGSIZE == SIZE32
3817 along = (strend - s) / SIZE32;
3819 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3824 #if LONGSIZE != SIZE32
3827 COPYNN(s, &along, sizeof(long));
3830 cdouble += (double)along;
3840 #if LONGSIZE > SIZE32
3841 if (along > 2147483647)
3842 along -= 4294967296;
3846 cdouble += (double)along;
3855 #if LONGSIZE != SIZE32
3858 COPYNN(s, &along, sizeof(long));
3861 sv_setiv(sv, (IV)along);
3862 PUSHs(sv_2mortal(sv));
3870 #if LONGSIZE > SIZE32
3871 if (along > 2147483647)
3872 along -= 4294967296;
3876 sv_setiv(sv, (IV)along);
3877 PUSHs(sv_2mortal(sv));
3885 #if LONGSIZE == SIZE32
3886 along = (strend - s) / SIZE32;
3888 unatint = natint && datumtype == 'L';
3889 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3894 #if LONGSIZE != SIZE32
3897 COPYNN(s, &aulong, sizeof(unsigned long));
3898 s += sizeof(unsigned long);
3900 cdouble += (double)aulong;
3912 if (datumtype == 'N')
3913 aulong = PerlSock_ntohl(aulong);
3916 if (datumtype == 'V')
3917 aulong = vtohl(aulong);
3920 cdouble += (double)aulong;
3929 #if LONGSIZE != SIZE32
3932 COPYNN(s, &aulong, sizeof(unsigned long));
3933 s += sizeof(unsigned long);
3935 sv_setuv(sv, (UV)aulong);
3936 PUSHs(sv_2mortal(sv));
3946 if (datumtype == 'N')
3947 aulong = PerlSock_ntohl(aulong);
3950 if (datumtype == 'V')
3951 aulong = vtohl(aulong);
3954 sv_setuv(sv, (UV)aulong);
3955 PUSHs(sv_2mortal(sv));
3961 along = (strend - s) / sizeof(char*);
3967 if (sizeof(char*) > strend - s)
3970 Copy(s, &aptr, 1, char*);
3976 PUSHs(sv_2mortal(sv));
3986 while ((len > 0) && (s < strend)) {
3987 auv = (auv << 7) | (*s & 0x7f);
3988 if (!(*s++ & 0x80)) {
3992 PUSHs(sv_2mortal(sv));
3996 else if (++bytes >= sizeof(UV)) { /* promote to string */
4000 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
4001 while (s < strend) {
4002 sv = mul128(sv, *s & 0x7f);
4003 if (!(*s++ & 0x80)) {
4012 PUSHs(sv_2mortal(sv));
4017 if ((s >= strend) && bytes)
4018 croak("Unterminated compressed integer");
4023 if (sizeof(char*) > strend - s)
4026 Copy(s, &aptr, 1, char*);
4031 sv_setpvn(sv, aptr, len);
4032 PUSHs(sv_2mortal(sv));
4036 along = (strend - s) / sizeof(Quad_t);
4042 if (s + sizeof(Quad_t) > strend)
4045 Copy(s, &aquad, 1, Quad_t);
4046 s += sizeof(Quad_t);
4049 if (aquad >= IV_MIN && aquad <= IV_MAX)
4050 sv_setiv(sv, (IV)aquad);
4052 sv_setnv(sv, (double)aquad);
4053 PUSHs(sv_2mortal(sv));
4057 along = (strend - s) / sizeof(Quad_t);
4063 if (s + sizeof(Uquad_t) > strend)
4066 Copy(s, &auquad, 1, Uquad_t);
4067 s += sizeof(Uquad_t);
4070 if (auquad <= UV_MAX)
4071 sv_setuv(sv, (UV)auquad);
4073 sv_setnv(sv, (double)auquad);
4074 PUSHs(sv_2mortal(sv));
4078 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4081 along = (strend - s) / sizeof(float);
4086 Copy(s, &afloat, 1, float);
4095 Copy(s, &afloat, 1, float);
4098 sv_setnv(sv, (double)afloat);
4099 PUSHs(sv_2mortal(sv));
4105 along = (strend - s) / sizeof(double);
4110 Copy(s, &adouble, 1, double);
4111 s += sizeof(double);
4119 Copy(s, &adouble, 1, double);
4120 s += sizeof(double);
4122 sv_setnv(sv, (double)adouble);
4123 PUSHs(sv_2mortal(sv));
4129 * Initialise the decode mapping. By using a table driven
4130 * algorithm, the code will be character-set independent
4131 * (and just as fast as doing character arithmetic)
4133 if (PL_uudmap['M'] == 0) {
4136 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4137 PL_uudmap[PL_uuemap[i]] = i;
4139 * Because ' ' and '`' map to the same value,
4140 * we need to decode them both the same.
4145 along = (strend - s) * 3 / 4;
4146 sv = NEWSV(42, along);
4149 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4154 len = PL_uudmap[*s++] & 077;
4156 if (s < strend && ISUUCHAR(*s))
4157 a = PL_uudmap[*s++] & 077;
4160 if (s < strend && ISUUCHAR(*s))
4161 b = PL_uudmap[*s++] & 077;
4164 if (s < strend && ISUUCHAR(*s))
4165 c = PL_uudmap[*s++] & 077;
4168 if (s < strend && ISUUCHAR(*s))
4169 d = PL_uudmap[*s++] & 077;
4172 hunk[0] = (a << 2) | (b >> 4);
4173 hunk[1] = (b << 4) | (c >> 2);
4174 hunk[2] = (c << 6) | d;
4175 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4180 else if (s[1] == '\n') /* possible checksum byte */
4183 XPUSHs(sv_2mortal(sv));
4188 if (strchr("fFdD", datumtype) ||
4189 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4193 while (checksum >= 16) {
4197 while (checksum >= 4) {
4203 along = (1 << checksum) - 1;
4204 while (cdouble < 0.0)
4206 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4207 sv_setnv(sv, cdouble);
4210 if (checksum < 32) {
4211 aulong = (1 << checksum) - 1;
4214 sv_setuv(sv, (UV)culong);
4216 XPUSHs(sv_2mortal(sv));
4220 if (SP == oldsp && gimme == G_SCALAR)
4221 PUSHs(&PL_sv_undef);
4226 doencodes(register SV *sv, register char *s, register I32 len)
4230 *hunk = PL_uuemap[len];
4231 sv_catpvn(sv, hunk, 1);
4234 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4235 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4236 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4237 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4238 sv_catpvn(sv, hunk, 4);
4243 char r = (len > 1 ? s[1] : '\0');
4244 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4245 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4246 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4247 hunk[3] = PL_uuemap[0];
4248 sv_catpvn(sv, hunk, 4);
4250 sv_catpvn(sv, "\n", 1);
4254 is_an_int(char *s, STRLEN l)
4257 SV *result = newSVpvn(s, l);
4258 char *result_c = SvPV(result, n_a); /* convenience */
4259 char *out = result_c;
4269 SvREFCNT_dec(result);
4292 SvREFCNT_dec(result);
4298 SvCUR_set(result, out - result_c);
4303 div128(SV *pnum, bool *done)
4304 /* must be '\0' terminated */
4308 char *s = SvPV(pnum, len);
4317 i = m * 10 + (*t - '0');
4319 r = (i >> 7); /* r < 10 */
4326 SvCUR_set(pnum, (STRLEN) (t - s));
4333 djSP; dMARK; dORIGMARK; dTARGET;
4334 register SV *cat = TARG;
4337 register char *pat = SvPVx(*++MARK, fromlen);
4338 register char *patend = pat + fromlen;
4343 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4344 static char *space10 = " ";
4346 /* These must not be in registers: */
4361 #ifdef PERL_NATINT_PACK
4362 int natint; /* native integer */
4367 sv_setpvn(cat, "", 0);
4368 while (pat < patend) {
4369 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4370 datumtype = *pat++ & 0xFF;
4371 #ifdef PERL_NATINT_PACK
4374 if (isSPACE(datumtype))
4377 char *natstr = "sSiIlL";
4379 if (strchr(natstr, datumtype)) {
4380 #ifdef PERL_NATINT_PACK
4386 croak("'!' allowed only after types %s", natstr);
4389 len = strchr("@Xxu", datumtype) ? 0 : items;
4392 else if (isDIGIT(*pat)) {
4394 while (isDIGIT(*pat))
4395 len = (len * 10) + (*pat++ - '0');
4401 croak("Invalid type in pack: '%c'", (int)datumtype);
4402 case ',': /* grandfather in commas but with a warning */
4403 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4404 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4407 DIE("%% may only be used in unpack");
4418 if (SvCUR(cat) < len)
4419 DIE("X outside of string");
4426 sv_catpvn(cat, null10, 10);
4429 sv_catpvn(cat, null10, len);
4435 aptr = SvPV(fromstr, fromlen);
4439 sv_catpvn(cat, aptr, len);
4441 sv_catpvn(cat, aptr, fromlen);
4443 if (datumtype == 'A') {
4445 sv_catpvn(cat, space10, 10);
4448 sv_catpvn(cat, space10, len);
4452 sv_catpvn(cat, null10, 10);
4455 sv_catpvn(cat, null10, len);
4462 char *savepat = pat;
4467 aptr = SvPV(fromstr, fromlen);
4472 SvCUR(cat) += (len+7)/8;
4473 SvGROW(cat, SvCUR(cat) + 1);
4474 aptr = SvPVX(cat) + aint;
4479 if (datumtype == 'B') {
4480 for (len = 0; len++ < aint;) {
4481 items |= *pat++ & 1;
4485 *aptr++ = items & 0xff;
4491 for (len = 0; len++ < aint;) {
4497 *aptr++ = items & 0xff;
4503 if (datumtype == 'B')
4504 items <<= 7 - (aint & 7);
4506 items >>= 7 - (aint & 7);
4507 *aptr++ = items & 0xff;
4509 pat = SvPVX(cat) + SvCUR(cat);
4520 char *savepat = pat;
4525 aptr = SvPV(fromstr, fromlen);
4530 SvCUR(cat) += (len+1)/2;
4531 SvGROW(cat, SvCUR(cat) + 1);
4532 aptr = SvPVX(cat) + aint;
4537 if (datumtype == 'H') {
4538 for (len = 0; len++ < aint;) {
4540 items |= ((*pat++ & 15) + 9) & 15;
4542 items |= *pat++ & 15;
4546 *aptr++ = items & 0xff;
4552 for (len = 0; len++ < aint;) {
4554 items |= (((*pat++ & 15) + 9) & 15) << 4;
4556 items |= (*pat++ & 15) << 4;
4560 *aptr++ = items & 0xff;
4566 *aptr++ = items & 0xff;
4567 pat = SvPVX(cat) + SvCUR(cat);
4579 aint = SvIV(fromstr);
4581 sv_catpvn(cat, &achar, sizeof(char));
4587 auint = SvUV(fromstr);
4588 SvGROW(cat, SvCUR(cat) + 10);
4589 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4594 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4599 afloat = (float)SvNV(fromstr);
4600 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4607 adouble = (double)SvNV(fromstr);
4608 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4614 ashort = (I16)SvIV(fromstr);
4616 ashort = PerlSock_htons(ashort);
4618 CAT16(cat, &ashort);
4624 ashort = (I16)SvIV(fromstr);
4626 ashort = htovs(ashort);
4628 CAT16(cat, &ashort);
4632 #if SHORTSIZE != SIZE16
4634 unsigned short aushort;
4638 aushort = SvUV(fromstr);
4639 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4649 aushort = (U16)SvUV(fromstr);
4650 CAT16(cat, &aushort);
4656 #if SHORTSIZE != SIZE16
4660 ashort = SvIV(fromstr);
4661 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4669 ashort = (I16)SvIV(fromstr);
4670 CAT16(cat, &ashort);
4677 auint = SvUV(fromstr);
4678 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4684 adouble = floor(SvNV(fromstr));
4687 croak("Cannot compress negative numbers");
4693 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4694 adouble <= UV_MAX_cxux
4701 char buf[1 + sizeof(UV)];
4702 char *in = buf + sizeof(buf);
4703 UV auv = U_V(adouble);;
4706 *--in = (auv & 0x7f) | 0x80;
4709 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4710 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4712 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4713 char *from, *result, *in;
4718 /* Copy string and check for compliance */
4719 from = SvPV(fromstr, len);
4720 if ((norm = is_an_int(from, len)) == NULL)
4721 croak("can compress only unsigned integer");
4723 New('w', result, len, char);
4727 *--in = div128(norm, &done) | 0x80;
4728 result[len - 1] &= 0x7F; /* clear continue bit */
4729 sv_catpvn(cat, in, (result + len) - in);
4731 SvREFCNT_dec(norm); /* free norm */
4733 else if (SvNOKp(fromstr)) {
4734 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4735 char *in = buf + sizeof(buf);
4738 double next = floor(adouble / 128);
4739 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4740 if (--in < buf) /* this cannot happen ;-) */
4741 croak ("Cannot compress integer");
4743 } while (adouble > 0);
4744 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4745 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4748 croak("Cannot compress non integer");
4754 aint = SvIV(fromstr);
4755 sv_catpvn(cat, (char*)&aint, sizeof(int));
4761 aulong = SvUV(fromstr);
4763 aulong = PerlSock_htonl(aulong);
4765 CAT32(cat, &aulong);
4771 aulong = SvUV(fromstr);
4773 aulong = htovl(aulong);
4775 CAT32(cat, &aulong);
4779 #if LONGSIZE != SIZE32
4783 aulong = SvUV(fromstr);
4784 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4792 aulong = SvUV(fromstr);
4793 CAT32(cat, &aulong);
4798 #if LONGSIZE != SIZE32
4802 along = SvIV(fromstr);
4803 sv_catpvn(cat, (char *)&along, sizeof(long));
4811 along = SvIV(fromstr);
4820 auquad = (Uquad_t)SvIV(fromstr);
4821 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4827 aquad = (Quad_t)SvIV(fromstr);
4828 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4831 #endif /* HAS_QUAD */
4833 len = 1; /* assume SV is correct length */
4838 if (fromstr == &PL_sv_undef)
4842 /* XXX better yet, could spirit away the string to
4843 * a safe spot and hang on to it until the result
4844 * of pack() (and all copies of the result) are
4847 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4849 "Attempt to pack pointer to temporary value");
4850 if (SvPOK(fromstr) || SvNIOK(fromstr))
4851 aptr = SvPV(fromstr,n_a);
4853 aptr = SvPV_force(fromstr,n_a);
4855 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4860 aptr = SvPV(fromstr, fromlen);
4861 SvGROW(cat, fromlen * 4 / 3);
4866 while (fromlen > 0) {
4873 doencodes(cat, aptr, todo);
4892 register I32 limit = POPi; /* note, negative is forever */
4895 register char *s = SvPV(sv, len);
4896 char *strend = s + len;
4898 register REGEXP *rx;
4902 I32 maxiters = (strend - s) + 10;
4905 I32 origlimit = limit;
4908 AV *oldstack = PL_curstack;
4909 I32 gimme = GIMME_V;
4910 I32 oldsave = PL_savestack_ix;
4911 I32 make_mortal = 1;
4912 MAGIC *mg = (MAGIC *) NULL;
4915 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4920 DIE("panic: do_split");
4921 rx = pm->op_pmregexp;
4923 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4924 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4926 if (pm->op_pmreplroot)
4927 ary = GvAVn((GV*)pm->op_pmreplroot);
4928 else if (gimme != G_ARRAY)
4930 ary = (AV*)PL_curpad[0];
4932 ary = GvAVn(PL_defgv);
4933 #endif /* USE_THREADS */
4936 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4942 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4944 XPUSHs(SvTIED_obj((SV*)ary, mg));
4949 for (i = AvFILLp(ary); i >= 0; i--)
4950 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4952 /* temporarily switch stacks */
4953 SWITCHSTACK(PL_curstack, ary);
4957 base = SP - PL_stack_base;
4959 if (pm->op_pmflags & PMf_SKIPWHITE) {
4960 if (pm->op_pmflags & PMf_LOCALE) {
4961 while (isSPACE_LC(*s))
4969 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4970 SAVEINT(PL_multiline);
4971 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4975 limit = maxiters + 2;
4976 if (pm->op_pmflags & PMf_WHITE) {
4979 while (m < strend &&
4980 !((pm->op_pmflags & PMf_LOCALE)
4981 ? isSPACE_LC(*m) : isSPACE(*m)))
4986 dstr = NEWSV(30, m-s);
4987 sv_setpvn(dstr, s, m-s);
4993 while (s < strend &&
4994 ((pm->op_pmflags & PMf_LOCALE)
4995 ? isSPACE_LC(*s) : isSPACE(*s)))
4999 else if (strEQ("^", rx->precomp)) {
5002 for (m = s; m < strend && *m != '\n'; m++) ;
5006 dstr = NEWSV(30, m-s);
5007 sv_setpvn(dstr, s, m-s);
5014 else if (rx->check_substr && !rx->nparens
5015 && (rx->reganch & ROPT_CHECK_ALL)
5016 && !(rx->reganch & ROPT_ANCH)) {
5017 i = SvCUR(rx->check_substr);
5018 if (i == 1 && !SvTAIL(rx->check_substr)) {
5019 i = *SvPVX(rx->check_substr);
5022 for (m = s; m < strend && *m != i; m++) ;
5025 dstr = NEWSV(30, m-s);
5026 sv_setpvn(dstr, s, m-s);
5035 while (s < strend && --limit &&
5036 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
5037 rx->check_substr, 0)) )
5040 dstr = NEWSV(31, m-s);
5041 sv_setpvn(dstr, s, m-s);
5050 maxiters += (strend - s) * rx->nparens;
5051 while (s < strend && --limit &&
5052 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
5054 TAINT_IF(RX_MATCH_TAINTED(rx));
5056 && rx->subbase != orig) {
5061 strend = s + (strend - m);
5064 dstr = NEWSV(32, m-s);
5065 sv_setpvn(dstr, s, m-s);
5070 for (i = 1; i <= rx->nparens; i++) {
5074 dstr = NEWSV(33, m-s);
5075 sv_setpvn(dstr, s, m-s);
5078 dstr = NEWSV(33, 0);
5088 LEAVE_SCOPE(oldsave);
5089 iters = (SP - PL_stack_base) - base;
5090 if (iters > maxiters)
5093 /* keep field after final delim? */
5094 if (s < strend || (iters && origlimit)) {
5095 dstr = NEWSV(34, strend-s);
5096 sv_setpvn(dstr, s, strend-s);
5102 else if (!origlimit) {
5103 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5109 SWITCHSTACK(ary, oldstack);
5110 if (SvSMAGICAL(ary)) {
5115 if (gimme == G_ARRAY) {
5117 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5125 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5128 if (gimme == G_ARRAY) {
5129 /* EXTEND should not be needed - we just popped them */
5131 for (i=0; i < iters; i++) {
5132 SV **svp = av_fetch(ary, i, FALSE);
5133 PUSHs((svp) ? *svp : &PL_sv_undef);
5140 if (gimme == G_ARRAY)
5143 if (iters || !pm->op_pmreplroot) {
5153 unlock_condpair(void *svv)
5156 MAGIC *mg = mg_find((SV*)svv, 'm');
5159 croak("panic: unlock_condpair unlocking non-mutex");
5160 MUTEX_LOCK(MgMUTEXP(mg));
5161 if (MgOWNER(mg) != thr)
5162 croak("panic: unlock_condpair unlocking mutex that we don't own");
5164 COND_SIGNAL(MgOWNERCONDP(mg));
5165 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5166 (unsigned long)thr, (unsigned long)svv);)
5167 MUTEX_UNLOCK(MgMUTEXP(mg));
5169 #endif /* USE_THREADS */
5182 mg = condpair_magic(sv);
5183 MUTEX_LOCK(MgMUTEXP(mg));
5184 if (MgOWNER(mg) == thr)
5185 MUTEX_UNLOCK(MgMUTEXP(mg));
5188 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5190 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5191 (unsigned long)thr, (unsigned long)sv);)
5192 MUTEX_UNLOCK(MgMUTEXP(mg));
5193 save_destructor(unlock_condpair, sv);
5195 #endif /* USE_THREADS */
5196 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5197 || SvTYPE(retsv) == SVt_PVCV) {
5198 retsv = refto(retsv);
5209 if (PL_op->op_private & OPpLVAL_INTRO)
5210 PUSHs(*save_threadsv(PL_op->op_targ));
5212 PUSHs(THREADSV(PL_op->op_targ));
5215 DIE("tried to access per-thread data in non-threaded perl");
5216 #endif /* USE_THREADS */