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 UNOP *unop = cUNOP;
659 register unsigned char *s;
662 register I32 *sfirst;
666 if (sv == PL_lastscream) {
672 SvSCREAM_off(PL_lastscream);
673 SvREFCNT_dec(PL_lastscream);
675 PL_lastscream = SvREFCNT_inc(sv);
678 s = (unsigned char*)(SvPV(sv, len));
682 if (pos > PL_maxscream) {
683 if (PL_maxscream < 0) {
684 PL_maxscream = pos + 80;
685 New(301, PL_screamfirst, 256, I32);
686 New(302, PL_screamnext, PL_maxscream, I32);
689 PL_maxscream = pos + pos / 4;
690 Renew(PL_screamnext, PL_maxscream, I32);
694 sfirst = PL_screamfirst;
695 snext = PL_screamnext;
697 if (!sfirst || !snext)
698 DIE("do_study: out of memory");
700 for (ch = 256; ch; --ch)
707 snext[pos] = sfirst[ch] - pos;
714 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
723 if (PL_op->op_flags & OPf_STACKED)
729 TARG = sv_newmortal();
734 /* Lvalue operators. */
746 djSP; dMARK; dTARGET;
756 SETi(do_chomp(TOPs));
762 djSP; dMARK; dTARGET;
763 register I32 count = 0;
766 count += do_chomp(POPs);
777 if (!sv || !SvANY(sv))
779 switch (SvTYPE(sv)) {
781 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
785 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
789 if (CvROOT(sv) || CvXSUB(sv))
806 if (!PL_op->op_private) {
815 if (SvTHINKFIRST(sv))
818 switch (SvTYPE(sv)) {
828 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
829 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
830 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
834 /* let user-undef'd sub keep its identity */
835 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
842 SvSetMagicSV(sv, &PL_sv_undef);
846 Newz(602, gp, 1, GP);
847 GvGP(sv) = gp_ref(gp);
848 GvSV(sv) = NEWSV(72,0);
849 GvLINE(sv) = PL_curcop->cop_line;
855 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
858 SvPV_set(sv, Nullch);
871 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
873 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
874 SvIVX(TOPs) != IV_MIN)
877 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
888 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
890 sv_setsv(TARG, TOPs);
891 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
892 SvIVX(TOPs) != IV_MAX)
895 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
909 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
911 sv_setsv(TARG, TOPs);
912 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
913 SvIVX(TOPs) != IV_MIN)
916 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
925 /* Ordinary operators. */
929 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
932 SETn( pow( left, right) );
939 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
942 SETn( left * right );
949 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
954 DIE("Illegal division by zero");
956 /* insure that 20./5. == 4. */
959 if ((double)I_V(left) == left &&
960 (double)I_V(right) == right &&
961 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
965 value = left / right;
969 value = left / right;
978 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
988 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
990 right = (right_neg = (i < 0)) ? -i : i;
995 right_neg = dright < 0;
1000 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1002 left = (left_neg = (i < 0)) ? -i : i;
1010 left_neg = dleft < 0;
1019 /* Tried: DOUBLESIZE <= UV_SIZE = Precision of UV more than of NV.
1020 * But in fact this is an optimization - trunc may be slow */
1022 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1024 # define CAST_D2UV(d) U_V(d)
1026 # define CAST_D2UV(d) ((UV)(d))
1029 if (dright <= UV_MAX && dleft <= UV_MAX) {
1030 right = CAST_D2UV(dright);
1031 left = CAST_D2UV(dleft);
1036 /* Backward-compatibility clause: */
1038 dright = trunc(dright + 0.5);
1039 dleft = trunc(dleft + 0.5);
1041 dright = floor(dright + 0.5);
1042 dleft = floor(dleft + 0.5);
1046 DIE("Illegal modulus zero");
1048 dans = fmod(dleft, dright);
1049 if ((left_neg != right_neg) && dans)
1050 dans = dright - dans;
1053 sv_setnv(TARG, dans);
1060 DIE("Illegal modulus zero");
1063 if ((left_neg != right_neg) && ans)
1066 /* XXX may warn: unary minus operator applied to unsigned type */
1067 /* could change -foo to be (~foo)+1 instead */
1068 if (ans <= ~((UV)IV_MAX)+1)
1069 sv_setiv(TARG, ~ans+1);
1071 sv_setnv(TARG, -(double)ans);
1074 sv_setuv(TARG, ans);
1083 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1085 register I32 count = POPi;
1086 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1088 I32 items = SP - MARK;
1091 max = items * count;
1100 repeatcpy((char*)(MARK + items), (char*)MARK,
1101 items * sizeof(SV*), count - 1);
1104 else if (count <= 0)
1107 else { /* Note: mark already snarfed by pp_list */
1112 SvSetSV(TARG, tmpstr);
1113 SvPV_force(TARG, len);
1118 SvGROW(TARG, (count * len) + 1);
1119 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1120 SvCUR(TARG) *= count;
1122 *SvEND(TARG) = '\0';
1124 (void)SvPOK_only(TARG);
1133 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1136 SETn( left - right );
1143 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1146 if (PL_op->op_private & HINT_INTEGER) {
1148 i = BWi(i) << shift;
1162 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1165 if (PL_op->op_private & HINT_INTEGER) {
1167 i = BWi(i) >> shift;
1181 djSP; tryAMAGICbinSET(lt,0);
1184 SETs(boolSV(TOPn < value));
1191 djSP; tryAMAGICbinSET(gt,0);
1194 SETs(boolSV(TOPn > value));
1201 djSP; tryAMAGICbinSET(le,0);
1204 SETs(boolSV(TOPn <= value));
1211 djSP; tryAMAGICbinSET(ge,0);
1214 SETs(boolSV(TOPn >= value));
1221 djSP; tryAMAGICbinSET(ne,0);
1224 SETs(boolSV(TOPn != value));
1231 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1238 else if (left < right)
1240 else if (left > right)
1253 djSP; tryAMAGICbinSET(slt,0);
1256 int cmp = ((PL_op->op_private & OPpLOCALE)
1257 ? sv_cmp_locale(left, right)
1258 : sv_cmp(left, right));
1259 SETs(boolSV(cmp < 0));
1266 djSP; tryAMAGICbinSET(sgt,0);
1269 int cmp = ((PL_op->op_private & OPpLOCALE)
1270 ? sv_cmp_locale(left, right)
1271 : sv_cmp(left, right));
1272 SETs(boolSV(cmp > 0));
1279 djSP; tryAMAGICbinSET(sle,0);
1282 int cmp = ((PL_op->op_private & OPpLOCALE)
1283 ? sv_cmp_locale(left, right)
1284 : sv_cmp(left, right));
1285 SETs(boolSV(cmp <= 0));
1292 djSP; tryAMAGICbinSET(sge,0);
1295 int cmp = ((PL_op->op_private & OPpLOCALE)
1296 ? sv_cmp_locale(left, right)
1297 : sv_cmp(left, right));
1298 SETs(boolSV(cmp >= 0));
1305 djSP; tryAMAGICbinSET(seq,0);
1308 SETs(boolSV(sv_eq(left, right)));
1315 djSP; tryAMAGICbinSET(sne,0);
1318 SETs(boolSV(!sv_eq(left, right)));
1325 djSP; dTARGET; tryAMAGICbin(scmp,0);
1328 int cmp = ((PL_op->op_private & OPpLOCALE)
1329 ? sv_cmp_locale(left, right)
1330 : sv_cmp(left, right));
1338 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1341 if (SvNIOKp(left) || SvNIOKp(right)) {
1342 if (PL_op->op_private & HINT_INTEGER) {
1343 IBW value = SvIV(left) & SvIV(right);
1347 UBW value = SvUV(left) & SvUV(right);
1352 do_vop(PL_op->op_type, TARG, left, right);
1361 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1364 if (SvNIOKp(left) || SvNIOKp(right)) {
1365 if (PL_op->op_private & HINT_INTEGER) {
1366 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1370 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1375 do_vop(PL_op->op_type, TARG, left, right);
1384 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1387 if (SvNIOKp(left) || SvNIOKp(right)) {
1388 if (PL_op->op_private & HINT_INTEGER) {
1389 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1393 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1398 do_vop(PL_op->op_type, TARG, left, right);
1407 djSP; dTARGET; tryAMAGICun(neg);
1412 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1414 else if (SvNIOKp(sv))
1416 else if (SvPOKp(sv)) {
1418 char *s = SvPV(sv, len);
1419 if (isIDFIRST(*s)) {
1420 sv_setpvn(TARG, "-", 1);
1423 else if (*s == '+' || *s == '-') {
1425 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1427 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1428 sv_setpvn(TARG, "-", 1);
1432 sv_setnv(TARG, -SvNV(sv));
1443 djSP; tryAMAGICunSET(not);
1444 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1450 djSP; dTARGET; tryAMAGICun(compl);
1454 if (PL_op->op_private & HINT_INTEGER) {
1455 IBW value = ~SvIV(sv);
1459 UBW value = ~SvUV(sv);
1464 register char *tmps;
1465 register long *tmpl;
1470 tmps = SvPV_force(TARG, len);
1473 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1476 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1480 for ( ; anum > 0; anum--, tmps++)
1489 /* integer versions of some of the above */
1493 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1496 SETi( left * right );
1503 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1507 DIE("Illegal division by zero");
1508 value = POPi / value;
1516 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1520 DIE("Illegal modulus zero");
1521 SETi( left % right );
1528 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1531 SETi( left + right );
1538 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1541 SETi( left - right );
1548 djSP; tryAMAGICbinSET(lt,0);
1551 SETs(boolSV(left < right));
1558 djSP; tryAMAGICbinSET(gt,0);
1561 SETs(boolSV(left > right));
1568 djSP; tryAMAGICbinSET(le,0);
1571 SETs(boolSV(left <= right));
1578 djSP; tryAMAGICbinSET(ge,0);
1581 SETs(boolSV(left >= right));
1588 djSP; tryAMAGICbinSET(eq,0);
1591 SETs(boolSV(left == right));
1598 djSP; tryAMAGICbinSET(ne,0);
1601 SETs(boolSV(left != right));
1608 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1615 else if (left < right)
1626 djSP; dTARGET; tryAMAGICun(neg);
1631 /* High falutin' math. */
1635 djSP; dTARGET; tryAMAGICbin(atan2,0);
1638 SETn(atan2(left, right));
1645 djSP; dTARGET; tryAMAGICun(sin);
1657 djSP; dTARGET; tryAMAGICun(cos);
1667 /* Support Configure command-line overrides for rand() functions.
1668 After 5.005, perhaps we should replace this by Configure support
1669 for drand48(), random(), or rand(). For 5.005, though, maintain
1670 compatibility by calling rand() but allow the user to override it.
1671 See INSTALL for details. --Andy Dougherty 15 July 1998
1673 /* Now it's after 5.005, and Configure supports drand48() and random(),
1674 in addition to rand(). So the overrides should not be needed any more.
1675 --Jarkko Hietaniemi 27 September 1998
1678 #ifndef HAS_DRAND48_PROTO
1679 extern double drand48 _((void));
1692 if (!PL_srand_called) {
1693 (void)seedDrand01((Rand_seed_t)seed());
1694 PL_srand_called = TRUE;
1709 (void)seedDrand01((Rand_seed_t)anum);
1710 PL_srand_called = TRUE;
1719 * This is really just a quick hack which grabs various garbage
1720 * values. It really should be a real hash algorithm which
1721 * spreads the effect of every input bit onto every output bit,
1722 * if someone who knows about such things would bother to write it.
1723 * Might be a good idea to add that function to CORE as well.
1724 * No numbers below come from careful analysis or anything here,
1725 * except they are primes and SEED_C1 > 1E6 to get a full-width
1726 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1727 * probably be bigger too.
1730 # define SEED_C1 1000003
1731 #define SEED_C4 73819
1733 # define SEED_C1 25747
1734 #define SEED_C4 20639
1738 #define SEED_C5 26107
1741 #ifndef PERL_NO_DEV_RANDOM
1746 # include <starlet.h>
1747 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1748 * in 100-ns units, typically incremented ever 10 ms. */
1749 unsigned int when[2];
1751 # ifdef HAS_GETTIMEOFDAY
1752 struct timeval when;
1758 /* This test is an escape hatch, this symbol isn't set by Configure. */
1759 #ifndef PERL_NO_DEV_RANDOM
1760 #ifndef PERL_RANDOM_DEVICE
1761 /* /dev/random isn't used by default because reads from it will block
1762 * if there isn't enough entropy available. You can compile with
1763 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1764 * is enough real entropy to fill the seed. */
1765 # define PERL_RANDOM_DEVICE "/dev/urandom"
1767 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1769 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1778 _ckvmssts(sys$gettim(when));
1779 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1781 # ifdef HAS_GETTIMEOFDAY
1782 gettimeofday(&when,(struct timezone *) 0);
1783 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1786 u = (U32)SEED_C1 * when;
1789 u += SEED_C3 * (U32)getpid();
1790 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1791 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1792 u += SEED_C5 * (U32)(UV)&when;
1799 djSP; dTARGET; tryAMAGICun(exp);
1811 djSP; dTARGET; tryAMAGICun(log);
1816 SET_NUMERIC_STANDARD();
1817 DIE("Can't take log of %g", value);
1827 djSP; dTARGET; tryAMAGICun(sqrt);
1832 SET_NUMERIC_STANDARD();
1833 DIE("Can't take sqrt of %g", value);
1835 value = sqrt(value);
1845 double value = TOPn;
1848 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1854 (void)modf(value, &value);
1856 (void)modf(-value, &value);
1871 djSP; dTARGET; tryAMAGICun(abs);
1873 double value = TOPn;
1876 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1877 (iv = SvIVX(TOPs)) != IV_MIN) {
1899 XPUSHu(scan_hex(tmps, 99, &argtype));
1912 while (*tmps && isSPACE(*tmps))
1917 value = scan_hex(++tmps, 99, &argtype);
1918 else if (*tmps == 'b')
1919 value = scan_bin(++tmps, 99, &argtype);
1921 value = scan_oct(tmps, 99, &argtype);
1933 SETi( sv_len_utf8(TOPs) );
1937 SETi( sv_len(TOPs) );
1951 I32 lvalue = PL_op->op_flags & OPf_MOD;
1953 I32 arybase = PL_curcop->cop_arybase;
1957 SvTAINTED_off(TARG); /* decontaminate */
1961 repl = SvPV(sv, repl_len);
1968 tmps = SvPV(sv, curlen);
1970 utfcurlen = sv_len_utf8(sv);
1971 if (utfcurlen == curlen)
1979 if (pos >= arybase) {
1997 else if (len >= 0) {
1999 if (rem > (I32)curlen)
2013 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2014 warner(WARN_SUBSTR, "substr outside of string");
2019 sv_pos_u2b(sv, &pos, &rem);
2021 sv_setpvn(TARG, tmps, rem);
2022 if (lvalue) { /* it's an lvalue! */
2023 if (!SvGMAGICAL(sv)) {
2027 if (ckWARN(WARN_SUBSTR))
2029 "Attempt to use reference as lvalue in substr");
2031 if (SvOK(sv)) /* is it defined ? */
2032 (void)SvPOK_only(sv);
2034 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2037 if (SvTYPE(TARG) < SVt_PVLV) {
2038 sv_upgrade(TARG, SVt_PVLV);
2039 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2043 if (LvTARG(TARG) != sv) {
2045 SvREFCNT_dec(LvTARG(TARG));
2046 LvTARG(TARG) = SvREFCNT_inc(sv);
2048 LvTARGOFF(TARG) = pos;
2049 LvTARGLEN(TARG) = rem;
2052 sv_insert(sv, pos, rem, repl, repl_len);
2055 PUSHs(TARG); /* avoid SvSETMAGIC here */
2062 register I32 size = POPi;
2063 register I32 offset = POPi;
2064 register SV *src = POPs;
2065 I32 lvalue = PL_op->op_flags & OPf_MOD;
2067 unsigned char *s = (unsigned char*)SvPV(src, srclen);
2068 unsigned long retnum;
2071 SvTAINTED_off(TARG); /* decontaminate */
2072 offset *= size; /* turn into bit offset */
2073 len = (offset + size + 7) / 8;
2074 if (offset < 0 || size < 1)
2077 if (lvalue) { /* it's an lvalue! */
2078 if (SvTYPE(TARG) < SVt_PVLV) {
2079 sv_upgrade(TARG, SVt_PVLV);
2080 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2084 if (LvTARG(TARG) != src) {
2086 SvREFCNT_dec(LvTARG(TARG));
2087 LvTARG(TARG) = SvREFCNT_inc(src);
2089 LvTARGOFF(TARG) = offset;
2090 LvTARGLEN(TARG) = size;
2098 if (offset >= srclen)
2101 retnum = (unsigned long) s[offset] << 8;
2103 else if (size == 32) {
2104 if (offset >= srclen)
2106 else if (offset + 1 >= srclen)
2107 retnum = (unsigned long) s[offset] << 24;
2108 else if (offset + 2 >= srclen)
2109 retnum = ((unsigned long) s[offset] << 24) +
2110 ((unsigned long) s[offset + 1] << 16);
2112 retnum = ((unsigned long) s[offset] << 24) +
2113 ((unsigned long) s[offset + 1] << 16) +
2114 (s[offset + 2] << 8);
2119 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2124 else if (size == 16)
2125 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2126 else if (size == 32)
2127 retnum = ((unsigned long) s[offset] << 24) +
2128 ((unsigned long) s[offset + 1] << 16) +
2129 (s[offset + 2] << 8) + s[offset+3];
2133 sv_setuv(TARG, (UV)retnum);
2148 I32 arybase = PL_curcop->cop_arybase;
2153 offset = POPi - arybase;
2156 tmps = SvPV(big, biglen);
2157 if (IN_UTF8 && offset > 0)
2158 sv_pos_u2b(big, &offset, 0);
2161 else if (offset > biglen)
2163 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2164 (unsigned char*)tmps + biglen, little, 0)))
2167 retval = tmps2 - tmps;
2168 if (IN_UTF8 && retval > 0)
2169 sv_pos_b2u(big, &retval);
2170 PUSHi(retval + arybase);
2185 I32 arybase = PL_curcop->cop_arybase;
2191 tmps2 = SvPV(little, llen);
2192 tmps = SvPV(big, blen);
2196 if (IN_UTF8 && offset > 0)
2197 sv_pos_u2b(big, &offset, 0);
2198 offset = offset - arybase + llen;
2202 else if (offset > blen)
2204 if (!(tmps2 = rninstr(tmps, tmps + offset,
2205 tmps2, tmps2 + llen)))
2208 retval = tmps2 - tmps;
2209 if (IN_UTF8 && retval > 0)
2210 sv_pos_b2u(big, &retval);
2211 PUSHi(retval + arybase);
2217 djSP; dMARK; dORIGMARK; dTARGET;
2218 #ifdef USE_LOCALE_NUMERIC
2219 if (PL_op->op_private & OPpLOCALE)
2220 SET_NUMERIC_LOCAL();
2222 SET_NUMERIC_STANDARD();
2224 do_sprintf(TARG, SP-MARK, MARK+1);
2225 TAINT_IF(SvTAINTED(TARG));
2236 U8 *tmps = (U8*)POPpx;
2239 if (IN_UTF8 && (*tmps & 0x80))
2240 value = utf8_to_uv(tmps, &retlen);
2242 value = (UV)(*tmps & 255);
2253 (void)SvUPGRADE(TARG,SVt_PV);
2255 if (IN_UTF8 && value >= 128) {
2258 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2259 SvCUR_set(TARG, tmps - SvPVX(TARG));
2261 (void)SvPOK_only(TARG);
2271 (void)SvPOK_only(TARG);
2278 djSP; dTARGET; dPOPTOPssrl;
2281 char *tmps = SvPV(left, n_a);
2283 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2285 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2289 "The crypt() function is unimplemented due to excessive paranoia.");
2302 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2306 UV uv = utf8_to_uv(s, &ulen);
2308 if (PL_op->op_private & OPpLOCALE) {
2311 uv = toTITLE_LC_uni(uv);
2314 uv = toTITLE_utf8(s);
2316 tend = uv_to_utf8(tmpbuf, uv);
2318 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2320 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2321 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2325 s = (U8*)SvPV_force(sv, slen);
2326 Copy(tmpbuf, s, ulen, U8);
2331 if (!SvPADTMP(sv)) {
2337 s = (U8*)SvPV_force(sv, slen);
2339 if (PL_op->op_private & OPpLOCALE) {
2342 *s = toUPPER_LC(*s);
2358 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2362 UV uv = utf8_to_uv(s, &ulen);
2364 if (PL_op->op_private & OPpLOCALE) {
2367 uv = toLOWER_LC_uni(uv);
2370 uv = toLOWER_utf8(s);
2372 tend = uv_to_utf8(tmpbuf, uv);
2374 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2376 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2377 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2381 s = (U8*)SvPV_force(sv, slen);
2382 Copy(tmpbuf, s, ulen, U8);
2387 if (!SvPADTMP(sv)) {
2393 s = (U8*)SvPV_force(sv, slen);
2395 if (PL_op->op_private & OPpLOCALE) {
2398 *s = toLOWER_LC(*s);
2421 s = (U8*)SvPV(sv,len);
2423 sv_setpvn(TARG, "", 0);
2428 (void)SvUPGRADE(TARG, SVt_PV);
2429 SvGROW(TARG, (len * 2) + 1);
2430 (void)SvPOK_only(TARG);
2431 d = (U8*)SvPVX(TARG);
2433 if (PL_op->op_private & OPpLOCALE) {
2437 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2443 d = uv_to_utf8(d, toUPPER_utf8( s ));
2448 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2453 if (!SvPADTMP(sv)) {
2460 s = (U8*)SvPV_force(sv, len);
2462 register U8 *send = s + len;
2464 if (PL_op->op_private & OPpLOCALE) {
2467 for (; s < send; s++)
2468 *s = toUPPER_LC(*s);
2471 for (; s < send; s++)
2491 s = (U8*)SvPV(sv,len);
2493 sv_setpvn(TARG, "", 0);
2498 (void)SvUPGRADE(TARG, SVt_PV);
2499 SvGROW(TARG, (len * 2) + 1);
2500 (void)SvPOK_only(TARG);
2501 d = (U8*)SvPVX(TARG);
2503 if (PL_op->op_private & OPpLOCALE) {
2507 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2513 d = uv_to_utf8(d, toLOWER_utf8(s));
2518 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2523 if (!SvPADTMP(sv)) {
2530 s = (U8*)SvPV_force(sv, len);
2532 register U8 *send = s + len;
2534 if (PL_op->op_private & OPpLOCALE) {
2537 for (; s < send; s++)
2538 *s = toLOWER_LC(*s);
2541 for (; s < send; s++)
2553 register char *s = SvPV(sv,len);
2557 (void)SvUPGRADE(TARG, SVt_PV);
2558 SvGROW(TARG, (len * 2) + 1);
2563 STRLEN ulen = UTF8SKIP(s);
2586 SvCUR_set(TARG, d - SvPVX(TARG));
2587 (void)SvPOK_only(TARG);
2590 sv_setpvn(TARG, s, len);
2599 djSP; dMARK; dORIGMARK;
2601 register AV* av = (AV*)POPs;
2602 register I32 lval = PL_op->op_flags & OPf_MOD;
2603 I32 arybase = PL_curcop->cop_arybase;
2606 if (SvTYPE(av) == SVt_PVAV) {
2607 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2609 for (svp = MARK + 1; svp <= SP; svp++) {
2614 if (max > AvMAX(av))
2617 while (++MARK <= SP) {
2618 elem = SvIVx(*MARK);
2622 svp = av_fetch(av, elem, lval);
2624 if (!svp || *svp == &PL_sv_undef)
2625 DIE(PL_no_aelem, elem);
2626 if (PL_op->op_private & OPpLVAL_INTRO)
2627 save_aelem(av, elem, svp);
2629 *MARK = svp ? *svp : &PL_sv_undef;
2632 if (GIMME != G_ARRAY) {
2640 /* Associative arrays. */
2645 HV *hash = (HV*)POPs;
2647 I32 gimme = GIMME_V;
2648 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2651 /* might clobber stack_sp */
2652 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2657 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2658 if (gimme == G_ARRAY) {
2660 /* might clobber stack_sp */
2661 sv_setsv(TARG, realhv ?
2662 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2667 else if (gimme == G_SCALAR)
2686 I32 gimme = GIMME_V;
2687 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2691 if (PL_op->op_private & OPpSLICE) {
2695 hvtype = SvTYPE(hv);
2696 while (++MARK <= SP) {
2697 if (hvtype == SVt_PVHV)
2698 sv = hv_delete_ent(hv, *MARK, discard, 0);
2700 DIE("Not a HASH reference");
2701 *MARK = sv ? sv : &PL_sv_undef;
2705 else if (gimme == G_SCALAR) {
2714 if (SvTYPE(hv) == SVt_PVHV)
2715 sv = hv_delete_ent(hv, keysv, discard, 0);
2717 DIE("Not a HASH reference");
2731 if (SvTYPE(hv) == SVt_PVHV) {
2732 if (hv_exists_ent(hv, tmpsv, 0))
2735 else if (SvTYPE(hv) == SVt_PVAV) {
2736 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2740 DIE("Not a HASH reference");
2747 djSP; dMARK; dORIGMARK;
2748 register HV *hv = (HV*)POPs;
2749 register I32 lval = PL_op->op_flags & OPf_MOD;
2750 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2752 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2753 DIE("Can't localize pseudo-hash element");
2755 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2756 while (++MARK <= SP) {
2760 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2761 svp = he ? &HeVAL(he) : 0;
2764 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2767 if (!svp || *svp == &PL_sv_undef) {
2769 DIE(PL_no_helem, SvPV(keysv, n_a));
2771 if (PL_op->op_private & OPpLVAL_INTRO)
2772 save_helem(hv, keysv, svp);
2774 *MARK = svp ? *svp : &PL_sv_undef;
2777 if (GIMME != G_ARRAY) {
2785 /* List operators. */
2790 if (GIMME != G_ARRAY) {
2792 *MARK = *SP; /* unwanted list, return last item */
2794 *MARK = &PL_sv_undef;
2803 SV **lastrelem = PL_stack_sp;
2804 SV **lastlelem = PL_stack_base + POPMARK;
2805 SV **firstlelem = PL_stack_base + POPMARK + 1;
2806 register SV **firstrelem = lastlelem + 1;
2807 I32 arybase = PL_curcop->cop_arybase;
2808 I32 lval = PL_op->op_flags & OPf_MOD;
2809 I32 is_something_there = lval;
2811 register I32 max = lastrelem - lastlelem;
2812 register SV **lelem;
2815 if (GIMME != G_ARRAY) {
2816 ix = SvIVx(*lastlelem);
2821 if (ix < 0 || ix >= max)
2822 *firstlelem = &PL_sv_undef;
2824 *firstlelem = firstrelem[ix];
2830 SP = firstlelem - 1;
2834 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2839 *lelem = &PL_sv_undef;
2840 else if (!(*lelem = firstrelem[ix]))
2841 *lelem = &PL_sv_undef;
2845 if (ix >= max || !(*lelem = firstrelem[ix]))
2846 *lelem = &PL_sv_undef;
2848 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2849 is_something_there = TRUE;
2851 if (is_something_there)
2854 SP = firstlelem - 1;
2860 djSP; dMARK; dORIGMARK;
2861 I32 items = SP - MARK;
2862 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2863 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2870 djSP; dMARK; dORIGMARK;
2871 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2875 SV *val = NEWSV(46, 0);
2877 sv_setsv(val, *++MARK);
2878 else if (ckWARN(WARN_UNSAFE))
2879 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2880 (void)hv_store_ent(hv,key,val,0);
2889 djSP; dMARK; dORIGMARK;
2890 register AV *ary = (AV*)*++MARK;
2894 register I32 offset;
2895 register I32 length;
2902 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2903 *MARK-- = SvTIED_obj((SV*)ary, mg);
2907 perl_call_method("SPLICE",GIMME_V);
2916 offset = i = SvIVx(*MARK);
2918 offset += AvFILLp(ary) + 1;
2920 offset -= PL_curcop->cop_arybase;
2922 DIE(PL_no_aelem, i);
2924 length = SvIVx(*MARK++);
2926 length += AvFILLp(ary) - offset + 1;
2932 length = AvMAX(ary) + 1; /* close enough to infinity */
2936 length = AvMAX(ary) + 1;
2938 if (offset > AvFILLp(ary) + 1)
2939 offset = AvFILLp(ary) + 1;
2940 after = AvFILLp(ary) + 1 - (offset + length);
2941 if (after < 0) { /* not that much array */
2942 length += after; /* offset+length now in array */
2948 /* At this point, MARK .. SP-1 is our new LIST */
2951 diff = newlen - length;
2952 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2955 if (diff < 0) { /* shrinking the area */
2957 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2958 Copy(MARK, tmparyval, newlen, SV*);
2961 MARK = ORIGMARK + 1;
2962 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2963 MEXTEND(MARK, length);
2964 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2966 EXTEND_MORTAL(length);
2967 for (i = length, dst = MARK; i; i--) {
2968 sv_2mortal(*dst); /* free them eventualy */
2975 *MARK = AvARRAY(ary)[offset+length-1];
2978 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2979 SvREFCNT_dec(*dst++); /* free them now */
2982 AvFILLp(ary) += diff;
2984 /* pull up or down? */
2986 if (offset < after) { /* easier to pull up */
2987 if (offset) { /* esp. if nothing to pull */
2988 src = &AvARRAY(ary)[offset-1];
2989 dst = src - diff; /* diff is negative */
2990 for (i = offset; i > 0; i--) /* can't trust Copy */
2994 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2998 if (after) { /* anything to pull down? */
2999 src = AvARRAY(ary) + offset + length;
3000 dst = src + diff; /* diff is negative */
3001 Move(src, dst, after, SV*);
3003 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3004 /* avoid later double free */
3008 dst[--i] = &PL_sv_undef;
3011 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3013 *dst = NEWSV(46, 0);
3014 sv_setsv(*dst++, *src++);
3016 Safefree(tmparyval);
3019 else { /* no, expanding (or same) */
3021 New(452, tmparyval, length, SV*); /* so remember deletion */
3022 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3025 if (diff > 0) { /* expanding */
3027 /* push up or down? */
3029 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3033 Move(src, dst, offset, SV*);
3035 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3037 AvFILLp(ary) += diff;
3040 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3041 av_extend(ary, AvFILLp(ary) + diff);
3042 AvFILLp(ary) += diff;
3045 dst = AvARRAY(ary) + AvFILLp(ary);
3047 for (i = after; i; i--) {
3054 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3055 *dst = NEWSV(46, 0);
3056 sv_setsv(*dst++, *src++);
3058 MARK = ORIGMARK + 1;
3059 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3061 Copy(tmparyval, MARK, length, SV*);
3063 EXTEND_MORTAL(length);
3064 for (i = length, dst = MARK; i; i--) {
3065 sv_2mortal(*dst); /* free them eventualy */
3069 Safefree(tmparyval);
3073 else if (length--) {
3074 *MARK = tmparyval[length];
3077 while (length-- > 0)
3078 SvREFCNT_dec(tmparyval[length]);
3080 Safefree(tmparyval);
3083 *MARK = &PL_sv_undef;
3091 djSP; dMARK; dORIGMARK; dTARGET;
3092 register AV *ary = (AV*)*++MARK;
3093 register SV *sv = &PL_sv_undef;
3096 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3097 *MARK-- = SvTIED_obj((SV*)ary, mg);
3101 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3106 /* Why no pre-extend of ary here ? */
3107 for (++MARK; MARK <= SP; MARK++) {
3110 sv_setsv(sv, *MARK);
3115 PUSHi( AvFILL(ary) + 1 );
3123 SV *sv = av_pop(av);
3125 (void)sv_2mortal(sv);
3134 SV *sv = av_shift(av);
3139 (void)sv_2mortal(sv);
3146 djSP; dMARK; dORIGMARK; dTARGET;
3147 register AV *ary = (AV*)*++MARK;
3152 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3153 *MARK-- = SvTIED_obj((SV*)ary, mg);
3157 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3162 av_unshift(ary, SP - MARK);
3165 sv_setsv(sv, *++MARK);
3166 (void)av_store(ary, i++, sv);
3170 PUSHi( AvFILL(ary) + 1 );
3180 if (GIMME == G_ARRAY) {
3191 register char *down;
3197 do_join(TARG, &PL_sv_no, MARK, SP);
3199 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3200 up = SvPV_force(TARG, len);
3202 if (IN_UTF8) { /* first reverse each character */
3203 U8* s = (U8*)SvPVX(TARG);
3204 U8* send = (U8*)(s + len);
3213 down = (char*)(s - 1);
3214 if (s > send || !((*down & 0xc0) == 0x80)) {
3215 warn("Malformed UTF-8 character");
3227 down = SvPVX(TARG) + len - 1;
3233 (void)SvPOK_only(TARG);
3242 mul128(SV *sv, U8 m)
3245 char *s = SvPV(sv, len);
3249 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3250 SV *tmpNew = newSVpvn("0000000000", 10);
3252 sv_catsv(tmpNew, sv);
3253 SvREFCNT_dec(sv); /* free old sv */
3258 while (!*t) /* trailing '\0'? */
3261 i = ((*t - '0') << 7) + m;
3262 *(t--) = '0' + (i % 10);
3268 /* Explosives and implosives. */
3270 #if 'I' == 73 && 'J' == 74
3271 /* On an ASCII/ISO kind of system */
3272 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3275 Some other sort of character set - use memchr() so we don't match
3278 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3286 I32 gimme = GIMME_V;
3290 register char *pat = SvPV(left, llen);
3291 register char *s = SvPV(right, rlen);
3292 char *strend = s + rlen;
3294 register char *patend = pat + llen;
3299 /* These must not be in registers: */
3316 register U32 culong;
3319 #ifdef PERL_NATINT_PACK
3320 int natint; /* native integer */
3321 int unatint; /* unsigned native integer */
3324 if (gimme != G_ARRAY) { /* arrange to do first one only */
3326 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3327 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3329 while (isDIGIT(*patend) || *patend == '*')
3335 while (pat < patend) {
3337 datumtype = *pat++ & 0xFF;
3338 #ifdef PERL_NATINT_PACK
3341 if (isSPACE(datumtype))
3344 char *natstr = "sSiIlL";
3346 if (strchr(natstr, datumtype)) {
3347 #ifdef PERL_NATINT_PACK
3353 croak("'!' allowed only after types %s", natstr);
3357 else if (*pat == '*') {
3358 len = strend - strbeg; /* long enough */
3361 else if (isDIGIT(*pat)) {
3363 while (isDIGIT(*pat))
3364 len = (len * 10) + (*pat++ - '0');
3367 len = (datumtype != '@');
3370 croak("Invalid type in unpack: '%c'", (int)datumtype);
3371 case ',': /* grandfather in commas but with a warning */
3372 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3373 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3376 if (len == 1 && pat[-1] != '1')
3385 if (len > strend - strbeg)
3386 DIE("@ outside of string");
3390 if (len > s - strbeg)
3391 DIE("X outside of string");
3395 if (len > strend - s)
3396 DIE("x outside of string");
3402 if (len > strend - s)
3405 goto uchar_checksum;
3406 sv = NEWSV(35, len);
3407 sv_setpvn(sv, s, len);
3409 if (datumtype == 'A' || datumtype == 'Z') {
3410 aptr = s; /* borrow register */
3411 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3416 else { /* 'A' strips both nulls and spaces */
3417 s = SvPVX(sv) + len - 1;
3418 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3422 SvCUR_set(sv, s - SvPVX(sv));
3423 s = aptr; /* unborrow register */
3425 XPUSHs(sv_2mortal(sv));
3429 if (pat[-1] == '*' || len > (strend - s) * 8)
3430 len = (strend - s) * 8;
3433 Newz(601, PL_bitcount, 256, char);
3434 for (bits = 1; bits < 256; bits++) {
3435 if (bits & 1) PL_bitcount[bits]++;
3436 if (bits & 2) PL_bitcount[bits]++;
3437 if (bits & 4) PL_bitcount[bits]++;
3438 if (bits & 8) PL_bitcount[bits]++;
3439 if (bits & 16) PL_bitcount[bits]++;
3440 if (bits & 32) PL_bitcount[bits]++;
3441 if (bits & 64) PL_bitcount[bits]++;
3442 if (bits & 128) PL_bitcount[bits]++;
3446 culong += PL_bitcount[*(unsigned char*)s++];
3451 if (datumtype == 'b') {
3453 if (bits & 1) culong++;
3459 if (bits & 128) culong++;
3466 sv = NEWSV(35, len + 1);
3469 aptr = pat; /* borrow register */
3471 if (datumtype == 'b') {
3473 for (len = 0; len < aint; len++) {
3474 if (len & 7) /*SUPPRESS 595*/
3478 *pat++ = '0' + (bits & 1);
3483 for (len = 0; len < aint; len++) {
3488 *pat++ = '0' + ((bits & 128) != 0);
3492 pat = aptr; /* unborrow register */
3493 XPUSHs(sv_2mortal(sv));
3497 if (pat[-1] == '*' || len > (strend - s) * 2)
3498 len = (strend - s) * 2;
3499 sv = NEWSV(35, len + 1);
3502 aptr = pat; /* borrow register */
3504 if (datumtype == 'h') {
3506 for (len = 0; len < aint; len++) {
3511 *pat++ = PL_hexdigit[bits & 15];
3516 for (len = 0; len < aint; len++) {
3521 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3525 pat = aptr; /* unborrow register */
3526 XPUSHs(sv_2mortal(sv));
3529 if (len > strend - s)
3534 if (aint >= 128) /* fake up signed chars */
3544 if (aint >= 128) /* fake up signed chars */
3547 sv_setiv(sv, (IV)aint);
3548 PUSHs(sv_2mortal(sv));
3553 if (len > strend - s)
3568 sv_setiv(sv, (IV)auint);
3569 PUSHs(sv_2mortal(sv));
3574 if (len > strend - s)
3577 while (len-- > 0 && s < strend) {
3578 auint = utf8_to_uv((U8*)s, &along);
3581 cdouble += (double)auint;
3589 while (len-- > 0 && s < strend) {
3590 auint = utf8_to_uv((U8*)s, &along);
3593 sv_setuv(sv, (UV)auint);
3594 PUSHs(sv_2mortal(sv));
3599 #if SHORTSIZE == SIZE16
3600 along = (strend - s) / SIZE16;
3602 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3607 #if SHORTSIZE != SIZE16
3610 COPYNN(s, &ashort, sizeof(short));
3621 #if SHORTSIZE > SIZE16
3633 #if SHORTSIZE != SIZE16
3636 COPYNN(s, &ashort, sizeof(short));
3639 sv_setiv(sv, (IV)ashort);
3640 PUSHs(sv_2mortal(sv));
3648 #if SHORTSIZE > SIZE16
3654 sv_setiv(sv, (IV)ashort);
3655 PUSHs(sv_2mortal(sv));
3663 #if SHORTSIZE == SIZE16
3664 along = (strend - s) / SIZE16;
3666 unatint = natint && datumtype == 'S';
3667 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3672 #if SHORTSIZE != SIZE16
3675 COPYNN(s, &aushort, sizeof(unsigned short));
3676 s += sizeof(unsigned short);
3684 COPY16(s, &aushort);
3687 if (datumtype == 'n')
3688 aushort = PerlSock_ntohs(aushort);
3691 if (datumtype == 'v')
3692 aushort = vtohs(aushort);
3701 #if SHORTSIZE != SIZE16
3704 COPYNN(s, &aushort, sizeof(unsigned short));
3705 s += sizeof(unsigned short);
3707 sv_setiv(sv, (UV)aushort);
3708 PUSHs(sv_2mortal(sv));
3715 COPY16(s, &aushort);
3719 if (datumtype == 'n')
3720 aushort = PerlSock_ntohs(aushort);
3723 if (datumtype == 'v')
3724 aushort = vtohs(aushort);
3726 sv_setiv(sv, (UV)aushort);
3727 PUSHs(sv_2mortal(sv));
3733 along = (strend - s) / sizeof(int);
3738 Copy(s, &aint, 1, int);
3741 cdouble += (double)aint;
3750 Copy(s, &aint, 1, int);
3754 /* Without the dummy below unpack("i", pack("i",-1))
3755 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3756 * cc with optimization turned on.
3758 * The bug was detected in
3759 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3760 * with optimization (-O4) turned on.
3761 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3762 * does not have this problem even with -O4.
3764 * This bug was reported as DECC_BUGS 1431
3765 * and tracked internally as GEM_BUGS 7775.
3767 * The bug is fixed in
3768 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3769 * UNIX V4.0F support: DEC C V5.9-006 or later
3770 * UNIX V4.0E support: DEC C V5.8-011 or later
3773 * See also few lines later for the same bug.
3776 sv_setiv(sv, (IV)aint) :
3778 sv_setiv(sv, (IV)aint);
3779 PUSHs(sv_2mortal(sv));
3784 along = (strend - s) / sizeof(unsigned int);
3789 Copy(s, &auint, 1, unsigned int);
3790 s += sizeof(unsigned int);
3792 cdouble += (double)auint;
3801 Copy(s, &auint, 1, unsigned int);
3802 s += sizeof(unsigned int);
3805 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3806 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3807 * See details few lines earlier. */
3809 sv_setuv(sv, (UV)auint) :
3811 sv_setuv(sv, (UV)auint);
3812 PUSHs(sv_2mortal(sv));
3817 #if LONGSIZE == SIZE32
3818 along = (strend - s) / SIZE32;
3820 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3825 #if LONGSIZE != SIZE32
3828 COPYNN(s, &along, sizeof(long));
3831 cdouble += (double)along;
3841 #if LONGSIZE > SIZE32
3842 if (along > 2147483647)
3843 along -= 4294967296;
3847 cdouble += (double)along;
3856 #if LONGSIZE != SIZE32
3859 COPYNN(s, &along, sizeof(long));
3862 sv_setiv(sv, (IV)along);
3863 PUSHs(sv_2mortal(sv));
3871 #if LONGSIZE > SIZE32
3872 if (along > 2147483647)
3873 along -= 4294967296;
3877 sv_setiv(sv, (IV)along);
3878 PUSHs(sv_2mortal(sv));
3886 #if LONGSIZE == SIZE32
3887 along = (strend - s) / SIZE32;
3889 unatint = natint && datumtype == 'L';
3890 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3895 #if LONGSIZE != SIZE32
3898 COPYNN(s, &aulong, sizeof(unsigned long));
3899 s += sizeof(unsigned long);
3901 cdouble += (double)aulong;
3913 if (datumtype == 'N')
3914 aulong = PerlSock_ntohl(aulong);
3917 if (datumtype == 'V')
3918 aulong = vtohl(aulong);
3921 cdouble += (double)aulong;
3930 #if LONGSIZE != SIZE32
3933 COPYNN(s, &aulong, sizeof(unsigned long));
3934 s += sizeof(unsigned long);
3936 sv_setuv(sv, (UV)aulong);
3937 PUSHs(sv_2mortal(sv));
3947 if (datumtype == 'N')
3948 aulong = PerlSock_ntohl(aulong);
3951 if (datumtype == 'V')
3952 aulong = vtohl(aulong);
3955 sv_setuv(sv, (UV)aulong);
3956 PUSHs(sv_2mortal(sv));
3962 along = (strend - s) / sizeof(char*);
3968 if (sizeof(char*) > strend - s)
3971 Copy(s, &aptr, 1, char*);
3977 PUSHs(sv_2mortal(sv));
3987 while ((len > 0) && (s < strend)) {
3988 auv = (auv << 7) | (*s & 0x7f);
3989 if (!(*s++ & 0x80)) {
3993 PUSHs(sv_2mortal(sv));
3997 else if (++bytes >= sizeof(UV)) { /* promote to string */
4001 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
4002 while (s < strend) {
4003 sv = mul128(sv, *s & 0x7f);
4004 if (!(*s++ & 0x80)) {
4013 PUSHs(sv_2mortal(sv));
4018 if ((s >= strend) && bytes)
4019 croak("Unterminated compressed integer");
4024 if (sizeof(char*) > strend - s)
4027 Copy(s, &aptr, 1, char*);
4032 sv_setpvn(sv, aptr, len);
4033 PUSHs(sv_2mortal(sv));
4037 along = (strend - s) / sizeof(Quad_t);
4043 if (s + sizeof(Quad_t) > strend)
4046 Copy(s, &aquad, 1, Quad_t);
4047 s += sizeof(Quad_t);
4050 if (aquad >= IV_MIN && aquad <= IV_MAX)
4051 sv_setiv(sv, (IV)aquad);
4053 sv_setnv(sv, (double)aquad);
4054 PUSHs(sv_2mortal(sv));
4058 along = (strend - s) / sizeof(Quad_t);
4064 if (s + sizeof(Uquad_t) > strend)
4067 Copy(s, &auquad, 1, Uquad_t);
4068 s += sizeof(Uquad_t);
4071 if (auquad <= UV_MAX)
4072 sv_setuv(sv, (UV)auquad);
4074 sv_setnv(sv, (double)auquad);
4075 PUSHs(sv_2mortal(sv));
4079 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4082 along = (strend - s) / sizeof(float);
4087 Copy(s, &afloat, 1, float);
4096 Copy(s, &afloat, 1, float);
4099 sv_setnv(sv, (double)afloat);
4100 PUSHs(sv_2mortal(sv));
4106 along = (strend - s) / sizeof(double);
4111 Copy(s, &adouble, 1, double);
4112 s += sizeof(double);
4120 Copy(s, &adouble, 1, double);
4121 s += sizeof(double);
4123 sv_setnv(sv, (double)adouble);
4124 PUSHs(sv_2mortal(sv));
4130 * Initialise the decode mapping. By using a table driven
4131 * algorithm, the code will be character-set independent
4132 * (and just as fast as doing character arithmetic)
4134 if (PL_uudmap['M'] == 0) {
4137 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4138 PL_uudmap[PL_uuemap[i]] = i;
4140 * Because ' ' and '`' map to the same value,
4141 * we need to decode them both the same.
4146 along = (strend - s) * 3 / 4;
4147 sv = NEWSV(42, along);
4150 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4155 len = PL_uudmap[*s++] & 077;
4157 if (s < strend && ISUUCHAR(*s))
4158 a = PL_uudmap[*s++] & 077;
4161 if (s < strend && ISUUCHAR(*s))
4162 b = PL_uudmap[*s++] & 077;
4165 if (s < strend && ISUUCHAR(*s))
4166 c = PL_uudmap[*s++] & 077;
4169 if (s < strend && ISUUCHAR(*s))
4170 d = PL_uudmap[*s++] & 077;
4173 hunk[0] = (a << 2) | (b >> 4);
4174 hunk[1] = (b << 4) | (c >> 2);
4175 hunk[2] = (c << 6) | d;
4176 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4181 else if (s[1] == '\n') /* possible checksum byte */
4184 XPUSHs(sv_2mortal(sv));
4189 if (strchr("fFdD", datumtype) ||
4190 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4194 while (checksum >= 16) {
4198 while (checksum >= 4) {
4204 along = (1 << checksum) - 1;
4205 while (cdouble < 0.0)
4207 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4208 sv_setnv(sv, cdouble);
4211 if (checksum < 32) {
4212 aulong = (1 << checksum) - 1;
4215 sv_setuv(sv, (UV)culong);
4217 XPUSHs(sv_2mortal(sv));
4221 if (SP == oldsp && gimme == G_SCALAR)
4222 PUSHs(&PL_sv_undef);
4227 doencodes(register SV *sv, register char *s, register I32 len)
4231 *hunk = PL_uuemap[len];
4232 sv_catpvn(sv, hunk, 1);
4235 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4236 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4237 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4238 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4239 sv_catpvn(sv, hunk, 4);
4244 char r = (len > 1 ? s[1] : '\0');
4245 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4246 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4247 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4248 hunk[3] = PL_uuemap[0];
4249 sv_catpvn(sv, hunk, 4);
4251 sv_catpvn(sv, "\n", 1);
4255 is_an_int(char *s, STRLEN l)
4258 SV *result = newSVpvn(s, l);
4259 char *result_c = SvPV(result, n_a); /* convenience */
4260 char *out = result_c;
4270 SvREFCNT_dec(result);
4293 SvREFCNT_dec(result);
4299 SvCUR_set(result, out - result_c);
4304 div128(SV *pnum, bool *done)
4305 /* must be '\0' terminated */
4309 char *s = SvPV(pnum, len);
4318 i = m * 10 + (*t - '0');
4320 r = (i >> 7); /* r < 10 */
4327 SvCUR_set(pnum, (STRLEN) (t - s));
4334 djSP; dMARK; dORIGMARK; dTARGET;
4335 register SV *cat = TARG;
4338 register char *pat = SvPVx(*++MARK, fromlen);
4339 register char *patend = pat + fromlen;
4344 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4345 static char *space10 = " ";
4347 /* These must not be in registers: */
4362 #ifdef PERL_NATINT_PACK
4363 int natint; /* native integer */
4368 sv_setpvn(cat, "", 0);
4369 while (pat < patend) {
4370 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4371 datumtype = *pat++ & 0xFF;
4372 #ifdef PERL_NATINT_PACK
4375 if (isSPACE(datumtype))
4378 char *natstr = "sSiIlL";
4380 if (strchr(natstr, datumtype)) {
4381 #ifdef PERL_NATINT_PACK
4387 croak("'!' allowed only after types %s", natstr);
4390 len = strchr("@Xxu", datumtype) ? 0 : items;
4393 else if (isDIGIT(*pat)) {
4395 while (isDIGIT(*pat))
4396 len = (len * 10) + (*pat++ - '0');
4402 croak("Invalid type in pack: '%c'", (int)datumtype);
4403 case ',': /* grandfather in commas but with a warning */
4404 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4405 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4408 DIE("%% may only be used in unpack");
4419 if (SvCUR(cat) < len)
4420 DIE("X outside of string");
4427 sv_catpvn(cat, null10, 10);
4430 sv_catpvn(cat, null10, len);
4436 aptr = SvPV(fromstr, fromlen);
4440 sv_catpvn(cat, aptr, len);
4442 sv_catpvn(cat, aptr, fromlen);
4444 if (datumtype == 'A') {
4446 sv_catpvn(cat, space10, 10);
4449 sv_catpvn(cat, space10, len);
4453 sv_catpvn(cat, null10, 10);
4456 sv_catpvn(cat, null10, len);
4463 char *savepat = pat;
4468 aptr = SvPV(fromstr, fromlen);
4473 SvCUR(cat) += (len+7)/8;
4474 SvGROW(cat, SvCUR(cat) + 1);
4475 aptr = SvPVX(cat) + aint;
4480 if (datumtype == 'B') {
4481 for (len = 0; len++ < aint;) {
4482 items |= *pat++ & 1;
4486 *aptr++ = items & 0xff;
4492 for (len = 0; len++ < aint;) {
4498 *aptr++ = items & 0xff;
4504 if (datumtype == 'B')
4505 items <<= 7 - (aint & 7);
4507 items >>= 7 - (aint & 7);
4508 *aptr++ = items & 0xff;
4510 pat = SvPVX(cat) + SvCUR(cat);
4521 char *savepat = pat;
4526 aptr = SvPV(fromstr, fromlen);
4531 SvCUR(cat) += (len+1)/2;
4532 SvGROW(cat, SvCUR(cat) + 1);
4533 aptr = SvPVX(cat) + aint;
4538 if (datumtype == 'H') {
4539 for (len = 0; len++ < aint;) {
4541 items |= ((*pat++ & 15) + 9) & 15;
4543 items |= *pat++ & 15;
4547 *aptr++ = items & 0xff;
4553 for (len = 0; len++ < aint;) {
4555 items |= (((*pat++ & 15) + 9) & 15) << 4;
4557 items |= (*pat++ & 15) << 4;
4561 *aptr++ = items & 0xff;
4567 *aptr++ = items & 0xff;
4568 pat = SvPVX(cat) + SvCUR(cat);
4580 aint = SvIV(fromstr);
4582 sv_catpvn(cat, &achar, sizeof(char));
4588 auint = SvUV(fromstr);
4589 SvGROW(cat, SvCUR(cat) + 10);
4590 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4595 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4600 afloat = (float)SvNV(fromstr);
4601 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4608 adouble = (double)SvNV(fromstr);
4609 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4615 ashort = (I16)SvIV(fromstr);
4617 ashort = PerlSock_htons(ashort);
4619 CAT16(cat, &ashort);
4625 ashort = (I16)SvIV(fromstr);
4627 ashort = htovs(ashort);
4629 CAT16(cat, &ashort);
4633 #if SHORTSIZE != SIZE16
4635 unsigned short aushort;
4639 aushort = SvUV(fromstr);
4640 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4650 aushort = (U16)SvUV(fromstr);
4651 CAT16(cat, &aushort);
4657 #if SHORTSIZE != SIZE16
4661 ashort = SvIV(fromstr);
4662 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4670 ashort = (I16)SvIV(fromstr);
4671 CAT16(cat, &ashort);
4678 auint = SvUV(fromstr);
4679 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4685 adouble = floor(SvNV(fromstr));
4688 croak("Cannot compress negative numbers");
4694 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4695 adouble <= UV_MAX_cxux
4702 char buf[1 + sizeof(UV)];
4703 char *in = buf + sizeof(buf);
4704 UV auv = U_V(adouble);;
4707 *--in = (auv & 0x7f) | 0x80;
4710 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4711 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4713 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4714 char *from, *result, *in;
4719 /* Copy string and check for compliance */
4720 from = SvPV(fromstr, len);
4721 if ((norm = is_an_int(from, len)) == NULL)
4722 croak("can compress only unsigned integer");
4724 New('w', result, len, char);
4728 *--in = div128(norm, &done) | 0x80;
4729 result[len - 1] &= 0x7F; /* clear continue bit */
4730 sv_catpvn(cat, in, (result + len) - in);
4732 SvREFCNT_dec(norm); /* free norm */
4734 else if (SvNOKp(fromstr)) {
4735 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4736 char *in = buf + sizeof(buf);
4739 double next = floor(adouble / 128);
4740 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4741 if (--in < buf) /* this cannot happen ;-) */
4742 croak ("Cannot compress integer");
4744 } while (adouble > 0);
4745 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4746 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4749 croak("Cannot compress non integer");
4755 aint = SvIV(fromstr);
4756 sv_catpvn(cat, (char*)&aint, sizeof(int));
4762 aulong = SvUV(fromstr);
4764 aulong = PerlSock_htonl(aulong);
4766 CAT32(cat, &aulong);
4772 aulong = SvUV(fromstr);
4774 aulong = htovl(aulong);
4776 CAT32(cat, &aulong);
4780 #if LONGSIZE != SIZE32
4784 aulong = SvUV(fromstr);
4785 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4793 aulong = SvUV(fromstr);
4794 CAT32(cat, &aulong);
4799 #if LONGSIZE != SIZE32
4803 along = SvIV(fromstr);
4804 sv_catpvn(cat, (char *)&along, sizeof(long));
4812 along = SvIV(fromstr);
4821 auquad = (Uquad_t)SvIV(fromstr);
4822 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4828 aquad = (Quad_t)SvIV(fromstr);
4829 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4832 #endif /* HAS_QUAD */
4834 len = 1; /* assume SV is correct length */
4839 if (fromstr == &PL_sv_undef)
4843 /* XXX better yet, could spirit away the string to
4844 * a safe spot and hang on to it until the result
4845 * of pack() (and all copies of the result) are
4848 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4850 "Attempt to pack pointer to temporary value");
4851 if (SvPOK(fromstr) || SvNIOK(fromstr))
4852 aptr = SvPV(fromstr,n_a);
4854 aptr = SvPV_force(fromstr,n_a);
4856 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4861 aptr = SvPV(fromstr, fromlen);
4862 SvGROW(cat, fromlen * 4 / 3);
4867 while (fromlen > 0) {
4874 doencodes(cat, aptr, todo);
4893 register I32 limit = POPi; /* note, negative is forever */
4896 register char *s = SvPV(sv, len);
4897 char *strend = s + len;
4899 register REGEXP *rx;
4903 I32 maxiters = (strend - s) + 10;
4906 I32 origlimit = limit;
4909 AV *oldstack = PL_curstack;
4910 I32 gimme = GIMME_V;
4911 I32 oldsave = PL_savestack_ix;
4912 I32 make_mortal = 1;
4913 MAGIC *mg = (MAGIC *) NULL;
4916 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4921 DIE("panic: do_split");
4922 rx = pm->op_pmregexp;
4924 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4925 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4927 if (pm->op_pmreplroot)
4928 ary = GvAVn((GV*)pm->op_pmreplroot);
4929 else if (gimme != G_ARRAY)
4931 ary = (AV*)PL_curpad[0];
4933 ary = GvAVn(PL_defgv);
4934 #endif /* USE_THREADS */
4937 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4943 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4945 XPUSHs(SvTIED_obj((SV*)ary, mg));
4950 for (i = AvFILLp(ary); i >= 0; i--)
4951 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4953 /* temporarily switch stacks */
4954 SWITCHSTACK(PL_curstack, ary);
4958 base = SP - PL_stack_base;
4960 if (pm->op_pmflags & PMf_SKIPWHITE) {
4961 if (pm->op_pmflags & PMf_LOCALE) {
4962 while (isSPACE_LC(*s))
4970 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4971 SAVEINT(PL_multiline);
4972 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4976 limit = maxiters + 2;
4977 if (pm->op_pmflags & PMf_WHITE) {
4980 while (m < strend &&
4981 !((pm->op_pmflags & PMf_LOCALE)
4982 ? isSPACE_LC(*m) : isSPACE(*m)))
4987 dstr = NEWSV(30, m-s);
4988 sv_setpvn(dstr, s, m-s);
4994 while (s < strend &&
4995 ((pm->op_pmflags & PMf_LOCALE)
4996 ? isSPACE_LC(*s) : isSPACE(*s)))
5000 else if (strEQ("^", rx->precomp)) {
5003 for (m = s; m < strend && *m != '\n'; m++) ;
5007 dstr = NEWSV(30, m-s);
5008 sv_setpvn(dstr, s, m-s);
5015 else if (rx->check_substr && !rx->nparens
5016 && (rx->reganch & ROPT_CHECK_ALL)
5017 && !(rx->reganch & ROPT_ANCH)) {
5018 i = SvCUR(rx->check_substr);
5019 if (i == 1 && !SvTAIL(rx->check_substr)) {
5020 i = *SvPVX(rx->check_substr);
5023 for (m = s; m < strend && *m != i; m++) ;
5026 dstr = NEWSV(30, m-s);
5027 sv_setpvn(dstr, s, m-s);
5036 while (s < strend && --limit &&
5037 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
5038 rx->check_substr, 0)) )
5041 dstr = NEWSV(31, m-s);
5042 sv_setpvn(dstr, s, m-s);
5051 maxiters += (strend - s) * rx->nparens;
5052 while (s < strend && --limit &&
5053 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
5055 TAINT_IF(RX_MATCH_TAINTED(rx));
5057 && rx->subbase != orig) {
5062 strend = s + (strend - m);
5065 dstr = NEWSV(32, m-s);
5066 sv_setpvn(dstr, s, m-s);
5071 for (i = 1; i <= rx->nparens; i++) {
5075 dstr = NEWSV(33, m-s);
5076 sv_setpvn(dstr, s, m-s);
5079 dstr = NEWSV(33, 0);
5089 LEAVE_SCOPE(oldsave);
5090 iters = (SP - PL_stack_base) - base;
5091 if (iters > maxiters)
5094 /* keep field after final delim? */
5095 if (s < strend || (iters && origlimit)) {
5096 dstr = NEWSV(34, strend-s);
5097 sv_setpvn(dstr, s, strend-s);
5103 else if (!origlimit) {
5104 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5110 SWITCHSTACK(ary, oldstack);
5111 if (SvSMAGICAL(ary)) {
5116 if (gimme == G_ARRAY) {
5118 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5126 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5129 if (gimme == G_ARRAY) {
5130 /* EXTEND should not be needed - we just popped them */
5132 for (i=0; i < iters; i++) {
5133 SV **svp = av_fetch(ary, i, FALSE);
5134 PUSHs((svp) ? *svp : &PL_sv_undef);
5141 if (gimme == G_ARRAY)
5144 if (iters || !pm->op_pmreplroot) {
5154 unlock_condpair(void *svv)
5157 MAGIC *mg = mg_find((SV*)svv, 'm');
5160 croak("panic: unlock_condpair unlocking non-mutex");
5161 MUTEX_LOCK(MgMUTEXP(mg));
5162 if (MgOWNER(mg) != thr)
5163 croak("panic: unlock_condpair unlocking mutex that we don't own");
5165 COND_SIGNAL(MgOWNERCONDP(mg));
5166 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5167 (unsigned long)thr, (unsigned long)svv);)
5168 MUTEX_UNLOCK(MgMUTEXP(mg));
5170 #endif /* USE_THREADS */
5183 mg = condpair_magic(sv);
5184 MUTEX_LOCK(MgMUTEXP(mg));
5185 if (MgOWNER(mg) == thr)
5186 MUTEX_UNLOCK(MgMUTEXP(mg));
5189 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5191 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5192 (unsigned long)thr, (unsigned long)sv);)
5193 MUTEX_UNLOCK(MgMUTEXP(mg));
5194 save_destructor(unlock_condpair, sv);
5196 #endif /* USE_THREADS */
5197 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5198 || SvTYPE(retsv) == SVt_PVCV) {
5199 retsv = refto(retsv);
5210 if (PL_op->op_private & OPpLVAL_INTRO)
5211 PUSHs(*save_threadsv(PL_op->op_targ));
5213 PUSHs(THREADSV(PL_op->op_targ));
5216 DIE("tried to access per-thread data in non-threaded perl");
5217 #endif /* USE_THREADS */