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 cUNOP->op_first->op_type == OP_PADSV ) {
251 SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
252 char *name = SvPV(padname,len);
253 GV *gv = (GV *) newSV(0);
254 gv_init(gv, PL_curcop->cop_stash, name, len, 0);
255 sv_upgrade(sv, SVt_RV);
256 SvRV(sv) = (SV *) gv;
260 if (PL_op->op_flags & OPf_REF ||
261 PL_op->op_private & HINT_STRICT_REFS)
262 DIE(PL_no_usym, "a symbol");
263 if (ckWARN(WARN_UNINITIALIZED))
264 warner(WARN_UNINITIALIZED, PL_warn_uninit);
268 if ((PL_op->op_flags & OPf_SPECIAL) &&
269 !(PL_op->op_flags & OPf_MOD))
271 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
276 if (PL_op->op_private & HINT_STRICT_REFS)
277 DIE(PL_no_symref, sym, "a symbol");
278 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
282 if (PL_op->op_private & OPpLVAL_INTRO)
283 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
294 tryAMAGICunDEREF(to_sv);
297 switch (SvTYPE(sv)) {
301 DIE("Not a SCALAR reference");
309 if (SvTYPE(gv) != SVt_PVGV) {
310 if (SvGMAGICAL(sv)) {
316 if (PL_op->op_flags & OPf_REF ||
317 PL_op->op_private & HINT_STRICT_REFS)
318 DIE(PL_no_usym, "a SCALAR");
319 if (ckWARN(WARN_UNINITIALIZED))
320 warner(WARN_UNINITIALIZED, PL_warn_uninit);
324 if ((PL_op->op_flags & OPf_SPECIAL) &&
325 !(PL_op->op_flags & OPf_MOD))
327 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
332 if (PL_op->op_private & HINT_STRICT_REFS)
333 DIE(PL_no_symref, sym, "a SCALAR");
334 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
339 if (PL_op->op_flags & OPf_MOD) {
340 if (PL_op->op_private & OPpLVAL_INTRO)
341 sv = save_scalar((GV*)TOPs);
342 else if (PL_op->op_private & OPpDEREF)
343 vivify_ref(sv, PL_op->op_private & OPpDEREF);
353 SV *sv = AvARYLEN(av);
355 AvARYLEN(av) = sv = NEWSV(0,0);
356 sv_upgrade(sv, SVt_IV);
357 sv_magic(sv, (SV*)av, '#', Nullch, 0);
365 djSP; dTARGET; dPOPss;
367 if (PL_op->op_flags & OPf_MOD) {
368 if (SvTYPE(TARG) < SVt_PVLV) {
369 sv_upgrade(TARG, SVt_PVLV);
370 sv_magic(TARG, Nullsv, '.', Nullch, 0);
374 if (LvTARG(TARG) != sv) {
376 SvREFCNT_dec(LvTARG(TARG));
377 LvTARG(TARG) = SvREFCNT_inc(sv);
379 PUSHs(TARG); /* no SvSETMAGIC */
385 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
386 mg = mg_find(sv, 'g');
387 if (mg && mg->mg_len >= 0) {
391 PUSHi(i + PL_curcop->cop_arybase);
405 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
406 /* (But not in defined().) */
407 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
410 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
413 cv = (CV*)&PL_sv_undef;
427 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
428 char *s = SvPVX(TOPs);
429 if (strnEQ(s, "CORE::", 6)) {
432 code = keyword(s + 6, SvCUR(TOPs) - 6);
433 if (code < 0) { /* Overridable. */
434 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
435 int i = 0, n = 0, seen_question = 0;
437 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
439 while (i < MAXO) { /* The slow way. */
440 if (strEQ(s + 6, PL_op_name[i])
441 || strEQ(s + 6, PL_op_desc[i]))
447 goto nonesuch; /* Should not happen... */
449 oa = PL_opargs[i] >> OASHIFT;
451 if (oa & OA_OPTIONAL) {
455 else if (seen_question)
456 goto set; /* XXXX system, exec */
457 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
458 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
461 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
462 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
466 ret = sv_2mortal(newSVpvn(str, n - 1));
468 else if (code) /* Non-Overridable */
470 else { /* None such */
472 croak("Cannot find an opnumber for \"%s\"", s+6);
476 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
478 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
487 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
489 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
505 if (GIMME != G_ARRAY) {
509 *MARK = &PL_sv_undef;
510 *MARK = refto(*MARK);
514 EXTEND_MORTAL(SP - MARK);
516 *MARK = refto(*MARK);
525 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
528 if (!(sv = LvTARG(sv)))
533 else if (SvPADTMP(sv))
537 (void)SvREFCNT_inc(sv);
540 sv_upgrade(rv, SVt_RV);
554 if (sv && SvGMAGICAL(sv))
557 if (!sv || !SvROK(sv))
561 pv = sv_reftype(sv,TRUE);
562 PUSHp(pv, strlen(pv));
572 stash = PL_curcop->cop_stash;
576 char *ptr = SvPV(ssv,len);
577 if (ckWARN(WARN_UNSAFE) && len == 0)
579 "Explicit blessing to '' (assuming package main)");
580 stash = gv_stashpvn(ptr, len, TRUE);
583 (void)sv_bless(TOPs, stash);
597 elem = SvPV(sv, n_a);
601 switch (elem ? *elem : '\0')
604 if (strEQ(elem, "ARRAY"))
605 tmpRef = (SV*)GvAV(gv);
608 if (strEQ(elem, "CODE"))
609 tmpRef = (SV*)GvCVu(gv);
612 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
613 tmpRef = (SV*)GvIOp(gv);
616 if (strEQ(elem, "GLOB"))
620 if (strEQ(elem, "HASH"))
621 tmpRef = (SV*)GvHV(gv);
624 if (strEQ(elem, "IO"))
625 tmpRef = (SV*)GvIOp(gv);
628 if (strEQ(elem, "NAME"))
629 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
632 if (strEQ(elem, "PACKAGE"))
633 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
636 if (strEQ(elem, "SCALAR"))
650 /* Pattern matching */
655 register UNOP *unop = cUNOP;
656 register unsigned char *s;
659 register I32 *sfirst;
663 if (sv == PL_lastscream) {
669 SvSCREAM_off(PL_lastscream);
670 SvREFCNT_dec(PL_lastscream);
672 PL_lastscream = SvREFCNT_inc(sv);
675 s = (unsigned char*)(SvPV(sv, len));
679 if (pos > PL_maxscream) {
680 if (PL_maxscream < 0) {
681 PL_maxscream = pos + 80;
682 New(301, PL_screamfirst, 256, I32);
683 New(302, PL_screamnext, PL_maxscream, I32);
686 PL_maxscream = pos + pos / 4;
687 Renew(PL_screamnext, PL_maxscream, I32);
691 sfirst = PL_screamfirst;
692 snext = PL_screamnext;
694 if (!sfirst || !snext)
695 DIE("do_study: out of memory");
697 for (ch = 256; ch; --ch)
704 snext[pos] = sfirst[ch] - pos;
711 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
720 if (PL_op->op_flags & OPf_STACKED)
726 TARG = sv_newmortal();
731 /* Lvalue operators. */
743 djSP; dMARK; dTARGET;
753 SETi(do_chomp(TOPs));
759 djSP; dMARK; dTARGET;
760 register I32 count = 0;
763 count += do_chomp(POPs);
774 if (!sv || !SvANY(sv))
776 switch (SvTYPE(sv)) {
778 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
782 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
786 if (CvROOT(sv) || CvXSUB(sv))
803 if (!PL_op->op_private) {
812 if (SvTHINKFIRST(sv))
815 switch (SvTYPE(sv)) {
825 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
826 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
827 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
831 /* let user-undef'd sub keep its identity */
832 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
839 SvSetMagicSV(sv, &PL_sv_undef);
843 Newz(602, gp, 1, GP);
844 GvGP(sv) = gp_ref(gp);
845 GvSV(sv) = NEWSV(72,0);
846 GvLINE(sv) = PL_curcop->cop_line;
852 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
855 SvPV_set(sv, Nullch);
868 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
870 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
871 SvIVX(TOPs) != IV_MIN)
874 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
885 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
887 sv_setsv(TARG, TOPs);
888 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
889 SvIVX(TOPs) != IV_MAX)
892 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
906 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
908 sv_setsv(TARG, TOPs);
909 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
910 SvIVX(TOPs) != IV_MIN)
913 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
922 /* Ordinary operators. */
926 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
929 SETn( pow( left, right) );
936 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
939 SETn( left * right );
946 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
951 DIE("Illegal division by zero");
953 /* insure that 20./5. == 4. */
956 if ((double)I_V(left) == left &&
957 (double)I_V(right) == right &&
958 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
962 value = left / right;
966 value = left / right;
975 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
985 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
987 right = (right_neg = (i < 0)) ? -i : i;
992 right_neg = dright < 0;
997 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
999 left = (left_neg = (i < 0)) ? -i : i;
1007 left_neg = dleft < 0;
1016 /* Tried: DOUBLESIZE <= UV_SIZE = Precision of UV more than of NV.
1017 * But in fact this is an optimization - trunc may be slow */
1019 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1021 # define CAST_D2UV(d) U_V(d)
1023 # define CAST_D2UV(d) ((UV)(d))
1026 if (dright <= UV_MAX && dleft <= UV_MAX) {
1027 right = CAST_D2UV(dright);
1028 left = CAST_D2UV(dleft);
1033 /* Backward-compatibility clause: */
1035 dright = trunc(dright + 0.5);
1036 dleft = trunc(dleft + 0.5);
1038 dright = floor(dright + 0.5);
1039 dleft = floor(dleft + 0.5);
1043 DIE("Illegal modulus zero");
1045 dans = fmod(dleft, dright);
1046 if ((left_neg != right_neg) && dans)
1047 dans = dright - dans;
1050 sv_setnv(TARG, dans);
1057 DIE("Illegal modulus zero");
1060 if ((left_neg != right_neg) && ans)
1063 /* XXX may warn: unary minus operator applied to unsigned type */
1064 /* could change -foo to be (~foo)+1 instead */
1065 if (ans <= ~((UV)IV_MAX)+1)
1066 sv_setiv(TARG, ~ans+1);
1068 sv_setnv(TARG, -(double)ans);
1071 sv_setuv(TARG, ans);
1080 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1082 register I32 count = POPi;
1083 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1085 I32 items = SP - MARK;
1088 max = items * count;
1097 repeatcpy((char*)(MARK + items), (char*)MARK,
1098 items * sizeof(SV*), count - 1);
1101 else if (count <= 0)
1104 else { /* Note: mark already snarfed by pp_list */
1109 SvSetSV(TARG, tmpstr);
1110 SvPV_force(TARG, len);
1115 SvGROW(TARG, (count * len) + 1);
1116 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1117 SvCUR(TARG) *= count;
1119 *SvEND(TARG) = '\0';
1121 (void)SvPOK_only(TARG);
1130 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1133 SETn( left - right );
1140 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1143 if (PL_op->op_private & HINT_INTEGER) {
1145 i = BWi(i) << shift;
1159 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1162 if (PL_op->op_private & HINT_INTEGER) {
1164 i = BWi(i) >> shift;
1178 djSP; tryAMAGICbinSET(lt,0);
1181 SETs(boolSV(TOPn < value));
1188 djSP; tryAMAGICbinSET(gt,0);
1191 SETs(boolSV(TOPn > value));
1198 djSP; tryAMAGICbinSET(le,0);
1201 SETs(boolSV(TOPn <= value));
1208 djSP; tryAMAGICbinSET(ge,0);
1211 SETs(boolSV(TOPn >= value));
1218 djSP; tryAMAGICbinSET(ne,0);
1221 SETs(boolSV(TOPn != value));
1228 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1235 else if (left < right)
1237 else if (left > right)
1250 djSP; tryAMAGICbinSET(slt,0);
1253 int cmp = ((PL_op->op_private & OPpLOCALE)
1254 ? sv_cmp_locale(left, right)
1255 : sv_cmp(left, right));
1256 SETs(boolSV(cmp < 0));
1263 djSP; tryAMAGICbinSET(sgt,0);
1266 int cmp = ((PL_op->op_private & OPpLOCALE)
1267 ? sv_cmp_locale(left, right)
1268 : sv_cmp(left, right));
1269 SETs(boolSV(cmp > 0));
1276 djSP; tryAMAGICbinSET(sle,0);
1279 int cmp = ((PL_op->op_private & OPpLOCALE)
1280 ? sv_cmp_locale(left, right)
1281 : sv_cmp(left, right));
1282 SETs(boolSV(cmp <= 0));
1289 djSP; tryAMAGICbinSET(sge,0);
1292 int cmp = ((PL_op->op_private & OPpLOCALE)
1293 ? sv_cmp_locale(left, right)
1294 : sv_cmp(left, right));
1295 SETs(boolSV(cmp >= 0));
1302 djSP; tryAMAGICbinSET(seq,0);
1305 SETs(boolSV(sv_eq(left, right)));
1312 djSP; tryAMAGICbinSET(sne,0);
1315 SETs(boolSV(!sv_eq(left, right)));
1322 djSP; dTARGET; tryAMAGICbin(scmp,0);
1325 int cmp = ((PL_op->op_private & OPpLOCALE)
1326 ? sv_cmp_locale(left, right)
1327 : sv_cmp(left, right));
1335 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1338 if (SvNIOKp(left) || SvNIOKp(right)) {
1339 if (PL_op->op_private & HINT_INTEGER) {
1340 IBW value = SvIV(left) & SvIV(right);
1344 UBW value = SvUV(left) & SvUV(right);
1349 do_vop(PL_op->op_type, TARG, left, right);
1358 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1361 if (SvNIOKp(left) || SvNIOKp(right)) {
1362 if (PL_op->op_private & HINT_INTEGER) {
1363 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1367 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1372 do_vop(PL_op->op_type, TARG, left, right);
1381 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1384 if (SvNIOKp(left) || SvNIOKp(right)) {
1385 if (PL_op->op_private & HINT_INTEGER) {
1386 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1390 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1395 do_vop(PL_op->op_type, TARG, left, right);
1404 djSP; dTARGET; tryAMAGICun(neg);
1409 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1411 else if (SvNIOKp(sv))
1413 else if (SvPOKp(sv)) {
1415 char *s = SvPV(sv, len);
1416 if (isIDFIRST(*s)) {
1417 sv_setpvn(TARG, "-", 1);
1420 else if (*s == '+' || *s == '-') {
1422 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1424 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1425 sv_setpvn(TARG, "-", 1);
1429 sv_setnv(TARG, -SvNV(sv));
1440 djSP; tryAMAGICunSET(not);
1441 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1447 djSP; dTARGET; tryAMAGICun(compl);
1451 if (PL_op->op_private & HINT_INTEGER) {
1452 IBW value = ~SvIV(sv);
1456 UBW value = ~SvUV(sv);
1461 register char *tmps;
1462 register long *tmpl;
1467 tmps = SvPV_force(TARG, len);
1470 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1473 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1477 for ( ; anum > 0; anum--, tmps++)
1486 /* integer versions of some of the above */
1490 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1493 SETi( left * right );
1500 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1504 DIE("Illegal division by zero");
1505 value = POPi / value;
1513 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1517 DIE("Illegal modulus zero");
1518 SETi( left % right );
1525 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1528 SETi( left + right );
1535 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1538 SETi( left - right );
1545 djSP; tryAMAGICbinSET(lt,0);
1548 SETs(boolSV(left < right));
1555 djSP; tryAMAGICbinSET(gt,0);
1558 SETs(boolSV(left > right));
1565 djSP; tryAMAGICbinSET(le,0);
1568 SETs(boolSV(left <= right));
1575 djSP; tryAMAGICbinSET(ge,0);
1578 SETs(boolSV(left >= right));
1585 djSP; tryAMAGICbinSET(eq,0);
1588 SETs(boolSV(left == right));
1595 djSP; tryAMAGICbinSET(ne,0);
1598 SETs(boolSV(left != right));
1605 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1612 else if (left < right)
1623 djSP; dTARGET; tryAMAGICun(neg);
1628 /* High falutin' math. */
1632 djSP; dTARGET; tryAMAGICbin(atan2,0);
1635 SETn(atan2(left, right));
1642 djSP; dTARGET; tryAMAGICun(sin);
1654 djSP; dTARGET; tryAMAGICun(cos);
1664 /* Support Configure command-line overrides for rand() functions.
1665 After 5.005, perhaps we should replace this by Configure support
1666 for drand48(), random(), or rand(). For 5.005, though, maintain
1667 compatibility by calling rand() but allow the user to override it.
1668 See INSTALL for details. --Andy Dougherty 15 July 1998
1670 /* Now it's after 5.005, and Configure supports drand48() and random(),
1671 in addition to rand(). So the overrides should not be needed any more.
1672 --Jarkko Hietaniemi 27 September 1998
1675 #ifndef HAS_DRAND48_PROTO
1676 extern double drand48 _((void));
1689 if (!PL_srand_called) {
1690 (void)seedDrand01((Rand_seed_t)seed());
1691 PL_srand_called = TRUE;
1706 (void)seedDrand01((Rand_seed_t)anum);
1707 PL_srand_called = TRUE;
1716 * This is really just a quick hack which grabs various garbage
1717 * values. It really should be a real hash algorithm which
1718 * spreads the effect of every input bit onto every output bit,
1719 * if someone who knows about such things would bother to write it.
1720 * Might be a good idea to add that function to CORE as well.
1721 * No numbers below come from careful analysis or anything here,
1722 * except they are primes and SEED_C1 > 1E6 to get a full-width
1723 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1724 * probably be bigger too.
1727 # define SEED_C1 1000003
1728 #define SEED_C4 73819
1730 # define SEED_C1 25747
1731 #define SEED_C4 20639
1735 #define SEED_C5 26107
1738 #ifndef PERL_NO_DEV_RANDOM
1743 # include <starlet.h>
1744 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1745 * in 100-ns units, typically incremented ever 10 ms. */
1746 unsigned int when[2];
1748 # ifdef HAS_GETTIMEOFDAY
1749 struct timeval when;
1755 /* This test is an escape hatch, this symbol isn't set by Configure. */
1756 #ifndef PERL_NO_DEV_RANDOM
1757 #ifndef PERL_RANDOM_DEVICE
1758 /* /dev/random isn't used by default because reads from it will block
1759 * if there isn't enough entropy available. You can compile with
1760 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1761 * is enough real entropy to fill the seed. */
1762 # define PERL_RANDOM_DEVICE "/dev/urandom"
1764 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1766 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1775 _ckvmssts(sys$gettim(when));
1776 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1778 # ifdef HAS_GETTIMEOFDAY
1779 gettimeofday(&when,(struct timezone *) 0);
1780 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1783 u = (U32)SEED_C1 * when;
1786 u += SEED_C3 * (U32)getpid();
1787 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1788 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1789 u += SEED_C5 * (U32)(UV)&when;
1796 djSP; dTARGET; tryAMAGICun(exp);
1808 djSP; dTARGET; tryAMAGICun(log);
1813 SET_NUMERIC_STANDARD();
1814 DIE("Can't take log of %g", value);
1824 djSP; dTARGET; tryAMAGICun(sqrt);
1829 SET_NUMERIC_STANDARD();
1830 DIE("Can't take sqrt of %g", value);
1832 value = sqrt(value);
1842 double value = TOPn;
1845 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1851 (void)modf(value, &value);
1853 (void)modf(-value, &value);
1868 djSP; dTARGET; tryAMAGICun(abs);
1870 double value = TOPn;
1873 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1874 (iv = SvIVX(TOPs)) != IV_MIN) {
1896 XPUSHu(scan_hex(tmps, 99, &argtype));
1909 while (*tmps && isSPACE(*tmps))
1914 value = scan_hex(++tmps, 99, &argtype);
1915 else if (*tmps == 'b')
1916 value = scan_bin(++tmps, 99, &argtype);
1918 value = scan_oct(tmps, 99, &argtype);
1930 SETi( sv_len_utf8(TOPs) );
1934 SETi( sv_len(TOPs) );
1948 I32 lvalue = PL_op->op_flags & OPf_MOD;
1950 I32 arybase = PL_curcop->cop_arybase;
1954 SvTAINTED_off(TARG); /* decontaminate */
1958 repl = SvPV(sv, repl_len);
1965 tmps = SvPV(sv, curlen);
1967 utfcurlen = sv_len_utf8(sv);
1968 if (utfcurlen == curlen)
1976 if (pos >= arybase) {
1994 else if (len >= 0) {
1996 if (rem > (I32)curlen)
2010 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2011 warner(WARN_SUBSTR, "substr outside of string");
2016 sv_pos_u2b(sv, &pos, &rem);
2018 sv_setpvn(TARG, tmps, rem);
2019 if (lvalue) { /* it's an lvalue! */
2020 if (!SvGMAGICAL(sv)) {
2024 if (ckWARN(WARN_SUBSTR))
2026 "Attempt to use reference as lvalue in substr");
2028 if (SvOK(sv)) /* is it defined ? */
2029 (void)SvPOK_only(sv);
2031 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2034 if (SvTYPE(TARG) < SVt_PVLV) {
2035 sv_upgrade(TARG, SVt_PVLV);
2036 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2040 if (LvTARG(TARG) != sv) {
2042 SvREFCNT_dec(LvTARG(TARG));
2043 LvTARG(TARG) = SvREFCNT_inc(sv);
2045 LvTARGOFF(TARG) = pos;
2046 LvTARGLEN(TARG) = rem;
2049 sv_insert(sv, pos, rem, repl, repl_len);
2052 PUSHs(TARG); /* avoid SvSETMAGIC here */
2059 register I32 size = POPi;
2060 register I32 offset = POPi;
2061 register SV *src = POPs;
2062 I32 lvalue = PL_op->op_flags & OPf_MOD;
2064 unsigned char *s = (unsigned char*)SvPV(src, srclen);
2065 unsigned long retnum;
2068 SvTAINTED_off(TARG); /* decontaminate */
2069 offset *= size; /* turn into bit offset */
2070 len = (offset + size + 7) / 8;
2071 if (offset < 0 || size < 1)
2074 if (lvalue) { /* it's an lvalue! */
2075 if (SvTYPE(TARG) < SVt_PVLV) {
2076 sv_upgrade(TARG, SVt_PVLV);
2077 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2081 if (LvTARG(TARG) != src) {
2083 SvREFCNT_dec(LvTARG(TARG));
2084 LvTARG(TARG) = SvREFCNT_inc(src);
2086 LvTARGOFF(TARG) = offset;
2087 LvTARGLEN(TARG) = size;
2095 if (offset >= srclen)
2098 retnum = (unsigned long) s[offset] << 8;
2100 else if (size == 32) {
2101 if (offset >= srclen)
2103 else if (offset + 1 >= srclen)
2104 retnum = (unsigned long) s[offset] << 24;
2105 else if (offset + 2 >= srclen)
2106 retnum = ((unsigned long) s[offset] << 24) +
2107 ((unsigned long) s[offset + 1] << 16);
2109 retnum = ((unsigned long) s[offset] << 24) +
2110 ((unsigned long) s[offset + 1] << 16) +
2111 (s[offset + 2] << 8);
2116 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2121 else if (size == 16)
2122 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2123 else if (size == 32)
2124 retnum = ((unsigned long) s[offset] << 24) +
2125 ((unsigned long) s[offset + 1] << 16) +
2126 (s[offset + 2] << 8) + s[offset+3];
2130 sv_setuv(TARG, (UV)retnum);
2145 I32 arybase = PL_curcop->cop_arybase;
2150 offset = POPi - arybase;
2153 tmps = SvPV(big, biglen);
2154 if (IN_UTF8 && offset > 0)
2155 sv_pos_u2b(big, &offset, 0);
2158 else if (offset > biglen)
2160 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2161 (unsigned char*)tmps + biglen, little, 0)))
2164 retval = tmps2 - tmps;
2165 if (IN_UTF8 && retval > 0)
2166 sv_pos_b2u(big, &retval);
2167 PUSHi(retval + arybase);
2182 I32 arybase = PL_curcop->cop_arybase;
2188 tmps2 = SvPV(little, llen);
2189 tmps = SvPV(big, blen);
2193 if (IN_UTF8 && offset > 0)
2194 sv_pos_u2b(big, &offset, 0);
2195 offset = offset - arybase + llen;
2199 else if (offset > blen)
2201 if (!(tmps2 = rninstr(tmps, tmps + offset,
2202 tmps2, tmps2 + llen)))
2205 retval = tmps2 - tmps;
2206 if (IN_UTF8 && retval > 0)
2207 sv_pos_b2u(big, &retval);
2208 PUSHi(retval + arybase);
2214 djSP; dMARK; dORIGMARK; dTARGET;
2215 #ifdef USE_LOCALE_NUMERIC
2216 if (PL_op->op_private & OPpLOCALE)
2217 SET_NUMERIC_LOCAL();
2219 SET_NUMERIC_STANDARD();
2221 do_sprintf(TARG, SP-MARK, MARK+1);
2222 TAINT_IF(SvTAINTED(TARG));
2233 U8 *tmps = (U8*)POPpx;
2236 if (IN_UTF8 && (*tmps & 0x80))
2237 value = utf8_to_uv(tmps, &retlen);
2239 value = (UV)(*tmps & 255);
2250 (void)SvUPGRADE(TARG,SVt_PV);
2252 if (IN_UTF8 && value >= 128) {
2255 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2256 SvCUR_set(TARG, tmps - SvPVX(TARG));
2258 (void)SvPOK_only(TARG);
2268 (void)SvPOK_only(TARG);
2275 djSP; dTARGET; dPOPTOPssrl;
2278 char *tmps = SvPV(left, n_a);
2280 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2282 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2286 "The crypt() function is unimplemented due to excessive paranoia.");
2299 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2303 UV uv = utf8_to_uv(s, &ulen);
2305 if (PL_op->op_private & OPpLOCALE) {
2308 uv = toTITLE_LC_uni(uv);
2311 uv = toTITLE_utf8(s);
2313 tend = uv_to_utf8(tmpbuf, uv);
2315 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2317 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2318 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2322 s = (U8*)SvPV_force(sv, slen);
2323 Copy(tmpbuf, s, ulen, U8);
2328 if (!SvPADTMP(sv)) {
2334 s = (U8*)SvPV_force(sv, slen);
2336 if (PL_op->op_private & OPpLOCALE) {
2339 *s = toUPPER_LC(*s);
2355 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2359 UV uv = utf8_to_uv(s, &ulen);
2361 if (PL_op->op_private & OPpLOCALE) {
2364 uv = toLOWER_LC_uni(uv);
2367 uv = toLOWER_utf8(s);
2369 tend = uv_to_utf8(tmpbuf, uv);
2371 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2373 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2374 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2378 s = (U8*)SvPV_force(sv, slen);
2379 Copy(tmpbuf, s, ulen, U8);
2384 if (!SvPADTMP(sv)) {
2390 s = (U8*)SvPV_force(sv, slen);
2392 if (PL_op->op_private & OPpLOCALE) {
2395 *s = toLOWER_LC(*s);
2418 s = (U8*)SvPV(sv,len);
2420 sv_setpvn(TARG, "", 0);
2425 (void)SvUPGRADE(TARG, SVt_PV);
2426 SvGROW(TARG, (len * 2) + 1);
2427 (void)SvPOK_only(TARG);
2428 d = (U8*)SvPVX(TARG);
2430 if (PL_op->op_private & OPpLOCALE) {
2434 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2440 d = uv_to_utf8(d, toUPPER_utf8( s ));
2445 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2450 if (!SvPADTMP(sv)) {
2457 s = (U8*)SvPV_force(sv, len);
2459 register U8 *send = s + len;
2461 if (PL_op->op_private & OPpLOCALE) {
2464 for (; s < send; s++)
2465 *s = toUPPER_LC(*s);
2468 for (; s < send; s++)
2488 s = (U8*)SvPV(sv,len);
2490 sv_setpvn(TARG, "", 0);
2495 (void)SvUPGRADE(TARG, SVt_PV);
2496 SvGROW(TARG, (len * 2) + 1);
2497 (void)SvPOK_only(TARG);
2498 d = (U8*)SvPVX(TARG);
2500 if (PL_op->op_private & OPpLOCALE) {
2504 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2510 d = uv_to_utf8(d, toLOWER_utf8(s));
2515 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2520 if (!SvPADTMP(sv)) {
2527 s = (U8*)SvPV_force(sv, len);
2529 register U8 *send = s + len;
2531 if (PL_op->op_private & OPpLOCALE) {
2534 for (; s < send; s++)
2535 *s = toLOWER_LC(*s);
2538 for (; s < send; s++)
2550 register char *s = SvPV(sv,len);
2554 (void)SvUPGRADE(TARG, SVt_PV);
2555 SvGROW(TARG, (len * 2) + 1);
2560 STRLEN ulen = UTF8SKIP(s);
2583 SvCUR_set(TARG, d - SvPVX(TARG));
2584 (void)SvPOK_only(TARG);
2587 sv_setpvn(TARG, s, len);
2596 djSP; dMARK; dORIGMARK;
2598 register AV* av = (AV*)POPs;
2599 register I32 lval = PL_op->op_flags & OPf_MOD;
2600 I32 arybase = PL_curcop->cop_arybase;
2603 if (SvTYPE(av) == SVt_PVAV) {
2604 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2606 for (svp = MARK + 1; svp <= SP; svp++) {
2611 if (max > AvMAX(av))
2614 while (++MARK <= SP) {
2615 elem = SvIVx(*MARK);
2619 svp = av_fetch(av, elem, lval);
2621 if (!svp || *svp == &PL_sv_undef)
2622 DIE(PL_no_aelem, elem);
2623 if (PL_op->op_private & OPpLVAL_INTRO)
2624 save_aelem(av, elem, svp);
2626 *MARK = svp ? *svp : &PL_sv_undef;
2629 if (GIMME != G_ARRAY) {
2637 /* Associative arrays. */
2642 HV *hash = (HV*)POPs;
2644 I32 gimme = GIMME_V;
2645 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2648 /* might clobber stack_sp */
2649 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2654 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2655 if (gimme == G_ARRAY) {
2657 /* might clobber stack_sp */
2658 sv_setsv(TARG, realhv ?
2659 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2664 else if (gimme == G_SCALAR)
2683 I32 gimme = GIMME_V;
2684 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2688 if (PL_op->op_private & OPpSLICE) {
2692 hvtype = SvTYPE(hv);
2693 while (++MARK <= SP) {
2694 if (hvtype == SVt_PVHV)
2695 sv = hv_delete_ent(hv, *MARK, discard, 0);
2697 DIE("Not a HASH reference");
2698 *MARK = sv ? sv : &PL_sv_undef;
2702 else if (gimme == G_SCALAR) {
2711 if (SvTYPE(hv) == SVt_PVHV)
2712 sv = hv_delete_ent(hv, keysv, discard, 0);
2714 DIE("Not a HASH reference");
2728 if (SvTYPE(hv) == SVt_PVHV) {
2729 if (hv_exists_ent(hv, tmpsv, 0))
2732 else if (SvTYPE(hv) == SVt_PVAV) {
2733 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2737 DIE("Not a HASH reference");
2744 djSP; dMARK; dORIGMARK;
2745 register HV *hv = (HV*)POPs;
2746 register I32 lval = PL_op->op_flags & OPf_MOD;
2747 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2749 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2750 DIE("Can't localize pseudo-hash element");
2752 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2753 while (++MARK <= SP) {
2757 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2758 svp = he ? &HeVAL(he) : 0;
2761 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2764 if (!svp || *svp == &PL_sv_undef) {
2766 DIE(PL_no_helem, SvPV(keysv, n_a));
2768 if (PL_op->op_private & OPpLVAL_INTRO)
2769 save_helem(hv, keysv, svp);
2771 *MARK = svp ? *svp : &PL_sv_undef;
2774 if (GIMME != G_ARRAY) {
2782 /* List operators. */
2787 if (GIMME != G_ARRAY) {
2789 *MARK = *SP; /* unwanted list, return last item */
2791 *MARK = &PL_sv_undef;
2800 SV **lastrelem = PL_stack_sp;
2801 SV **lastlelem = PL_stack_base + POPMARK;
2802 SV **firstlelem = PL_stack_base + POPMARK + 1;
2803 register SV **firstrelem = lastlelem + 1;
2804 I32 arybase = PL_curcop->cop_arybase;
2805 I32 lval = PL_op->op_flags & OPf_MOD;
2806 I32 is_something_there = lval;
2808 register I32 max = lastrelem - lastlelem;
2809 register SV **lelem;
2812 if (GIMME != G_ARRAY) {
2813 ix = SvIVx(*lastlelem);
2818 if (ix < 0 || ix >= max)
2819 *firstlelem = &PL_sv_undef;
2821 *firstlelem = firstrelem[ix];
2827 SP = firstlelem - 1;
2831 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2836 *lelem = &PL_sv_undef;
2837 else if (!(*lelem = firstrelem[ix]))
2838 *lelem = &PL_sv_undef;
2842 if (ix >= max || !(*lelem = firstrelem[ix]))
2843 *lelem = &PL_sv_undef;
2845 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2846 is_something_there = TRUE;
2848 if (is_something_there)
2851 SP = firstlelem - 1;
2857 djSP; dMARK; dORIGMARK;
2858 I32 items = SP - MARK;
2859 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2860 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2867 djSP; dMARK; dORIGMARK;
2868 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2872 SV *val = NEWSV(46, 0);
2874 sv_setsv(val, *++MARK);
2875 else if (ckWARN(WARN_UNSAFE))
2876 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2877 (void)hv_store_ent(hv,key,val,0);
2886 djSP; dMARK; dORIGMARK;
2887 register AV *ary = (AV*)*++MARK;
2891 register I32 offset;
2892 register I32 length;
2899 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2900 *MARK-- = SvTIED_obj((SV*)ary, mg);
2904 perl_call_method("SPLICE",GIMME_V);
2913 offset = i = SvIVx(*MARK);
2915 offset += AvFILLp(ary) + 1;
2917 offset -= PL_curcop->cop_arybase;
2919 DIE(PL_no_aelem, i);
2921 length = SvIVx(*MARK++);
2923 length += AvFILLp(ary) - offset + 1;
2929 length = AvMAX(ary) + 1; /* close enough to infinity */
2933 length = AvMAX(ary) + 1;
2935 if (offset > AvFILLp(ary) + 1)
2936 offset = AvFILLp(ary) + 1;
2937 after = AvFILLp(ary) + 1 - (offset + length);
2938 if (after < 0) { /* not that much array */
2939 length += after; /* offset+length now in array */
2945 /* At this point, MARK .. SP-1 is our new LIST */
2948 diff = newlen - length;
2949 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2952 if (diff < 0) { /* shrinking the area */
2954 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2955 Copy(MARK, tmparyval, newlen, SV*);
2958 MARK = ORIGMARK + 1;
2959 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2960 MEXTEND(MARK, length);
2961 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2963 EXTEND_MORTAL(length);
2964 for (i = length, dst = MARK; i; i--) {
2965 sv_2mortal(*dst); /* free them eventualy */
2972 *MARK = AvARRAY(ary)[offset+length-1];
2975 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2976 SvREFCNT_dec(*dst++); /* free them now */
2979 AvFILLp(ary) += diff;
2981 /* pull up or down? */
2983 if (offset < after) { /* easier to pull up */
2984 if (offset) { /* esp. if nothing to pull */
2985 src = &AvARRAY(ary)[offset-1];
2986 dst = src - diff; /* diff is negative */
2987 for (i = offset; i > 0; i--) /* can't trust Copy */
2991 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2995 if (after) { /* anything to pull down? */
2996 src = AvARRAY(ary) + offset + length;
2997 dst = src + diff; /* diff is negative */
2998 Move(src, dst, after, SV*);
3000 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3001 /* avoid later double free */
3005 dst[--i] = &PL_sv_undef;
3008 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3010 *dst = NEWSV(46, 0);
3011 sv_setsv(*dst++, *src++);
3013 Safefree(tmparyval);
3016 else { /* no, expanding (or same) */
3018 New(452, tmparyval, length, SV*); /* so remember deletion */
3019 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3022 if (diff > 0) { /* expanding */
3024 /* push up or down? */
3026 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3030 Move(src, dst, offset, SV*);
3032 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3034 AvFILLp(ary) += diff;
3037 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3038 av_extend(ary, AvFILLp(ary) + diff);
3039 AvFILLp(ary) += diff;
3042 dst = AvARRAY(ary) + AvFILLp(ary);
3044 for (i = after; i; i--) {
3051 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3052 *dst = NEWSV(46, 0);
3053 sv_setsv(*dst++, *src++);
3055 MARK = ORIGMARK + 1;
3056 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3058 Copy(tmparyval, MARK, length, SV*);
3060 EXTEND_MORTAL(length);
3061 for (i = length, dst = MARK; i; i--) {
3062 sv_2mortal(*dst); /* free them eventualy */
3066 Safefree(tmparyval);
3070 else if (length--) {
3071 *MARK = tmparyval[length];
3074 while (length-- > 0)
3075 SvREFCNT_dec(tmparyval[length]);
3077 Safefree(tmparyval);
3080 *MARK = &PL_sv_undef;
3088 djSP; dMARK; dORIGMARK; dTARGET;
3089 register AV *ary = (AV*)*++MARK;
3090 register SV *sv = &PL_sv_undef;
3093 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3094 *MARK-- = SvTIED_obj((SV*)ary, mg);
3098 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3103 /* Why no pre-extend of ary here ? */
3104 for (++MARK; MARK <= SP; MARK++) {
3107 sv_setsv(sv, *MARK);
3112 PUSHi( AvFILL(ary) + 1 );
3120 SV *sv = av_pop(av);
3122 (void)sv_2mortal(sv);
3131 SV *sv = av_shift(av);
3136 (void)sv_2mortal(sv);
3143 djSP; dMARK; dORIGMARK; dTARGET;
3144 register AV *ary = (AV*)*++MARK;
3149 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3150 *MARK-- = SvTIED_obj((SV*)ary, mg);
3154 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3159 av_unshift(ary, SP - MARK);
3162 sv_setsv(sv, *++MARK);
3163 (void)av_store(ary, i++, sv);
3167 PUSHi( AvFILL(ary) + 1 );
3177 if (GIMME == G_ARRAY) {
3188 register char *down;
3194 do_join(TARG, &PL_sv_no, MARK, SP);
3196 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3197 up = SvPV_force(TARG, len);
3199 if (IN_UTF8) { /* first reverse each character */
3200 U8* s = (U8*)SvPVX(TARG);
3201 U8* send = (U8*)(s + len);
3210 down = (char*)(s - 1);
3211 if (s > send || !((*down & 0xc0) == 0x80)) {
3212 warn("Malformed UTF-8 character");
3224 down = SvPVX(TARG) + len - 1;
3230 (void)SvPOK_only(TARG);
3239 mul128(SV *sv, U8 m)
3242 char *s = SvPV(sv, len);
3246 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3247 SV *tmpNew = newSVpvn("0000000000", 10);
3249 sv_catsv(tmpNew, sv);
3250 SvREFCNT_dec(sv); /* free old sv */
3255 while (!*t) /* trailing '\0'? */
3258 i = ((*t - '0') << 7) + m;
3259 *(t--) = '0' + (i % 10);
3265 /* Explosives and implosives. */
3267 #if 'I' == 73 && 'J' == 74
3268 /* On an ASCII/ISO kind of system */
3269 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3272 Some other sort of character set - use memchr() so we don't match
3275 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3283 I32 gimme = GIMME_V;
3287 register char *pat = SvPV(left, llen);
3288 register char *s = SvPV(right, rlen);
3289 char *strend = s + rlen;
3291 register char *patend = pat + llen;
3296 /* These must not be in registers: */
3313 register U32 culong;
3316 #ifdef PERL_NATINT_PACK
3317 int natint; /* native integer */
3318 int unatint; /* unsigned native integer */
3321 if (gimme != G_ARRAY) { /* arrange to do first one only */
3323 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3324 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3326 while (isDIGIT(*patend) || *patend == '*')
3332 while (pat < patend) {
3334 datumtype = *pat++ & 0xFF;
3335 #ifdef PERL_NATINT_PACK
3338 if (isSPACE(datumtype))
3341 char *natstr = "sSiIlL";
3343 if (strchr(natstr, datumtype)) {
3344 #ifdef PERL_NATINT_PACK
3350 croak("'!' allowed only after types %s", natstr);
3354 else if (*pat == '*') {
3355 len = strend - strbeg; /* long enough */
3358 else if (isDIGIT(*pat)) {
3360 while (isDIGIT(*pat))
3361 len = (len * 10) + (*pat++ - '0');
3364 len = (datumtype != '@');
3367 croak("Invalid type in unpack: '%c'", (int)datumtype);
3368 case ',': /* grandfather in commas but with a warning */
3369 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3370 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3373 if (len == 1 && pat[-1] != '1')
3382 if (len > strend - strbeg)
3383 DIE("@ outside of string");
3387 if (len > s - strbeg)
3388 DIE("X outside of string");
3392 if (len > strend - s)
3393 DIE("x outside of string");
3399 if (len > strend - s)
3402 goto uchar_checksum;
3403 sv = NEWSV(35, len);
3404 sv_setpvn(sv, s, len);
3406 if (datumtype == 'A' || datumtype == 'Z') {
3407 aptr = s; /* borrow register */
3408 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3413 else { /* 'A' strips both nulls and spaces */
3414 s = SvPVX(sv) + len - 1;
3415 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3419 SvCUR_set(sv, s - SvPVX(sv));
3420 s = aptr; /* unborrow register */
3422 XPUSHs(sv_2mortal(sv));
3426 if (pat[-1] == '*' || len > (strend - s) * 8)
3427 len = (strend - s) * 8;
3430 Newz(601, PL_bitcount, 256, char);
3431 for (bits = 1; bits < 256; bits++) {
3432 if (bits & 1) PL_bitcount[bits]++;
3433 if (bits & 2) PL_bitcount[bits]++;
3434 if (bits & 4) PL_bitcount[bits]++;
3435 if (bits & 8) PL_bitcount[bits]++;
3436 if (bits & 16) PL_bitcount[bits]++;
3437 if (bits & 32) PL_bitcount[bits]++;
3438 if (bits & 64) PL_bitcount[bits]++;
3439 if (bits & 128) PL_bitcount[bits]++;
3443 culong += PL_bitcount[*(unsigned char*)s++];
3448 if (datumtype == 'b') {
3450 if (bits & 1) culong++;
3456 if (bits & 128) culong++;
3463 sv = NEWSV(35, len + 1);
3466 aptr = pat; /* borrow register */
3468 if (datumtype == 'b') {
3470 for (len = 0; len < aint; len++) {
3471 if (len & 7) /*SUPPRESS 595*/
3475 *pat++ = '0' + (bits & 1);
3480 for (len = 0; len < aint; len++) {
3485 *pat++ = '0' + ((bits & 128) != 0);
3489 pat = aptr; /* unborrow register */
3490 XPUSHs(sv_2mortal(sv));
3494 if (pat[-1] == '*' || len > (strend - s) * 2)
3495 len = (strend - s) * 2;
3496 sv = NEWSV(35, len + 1);
3499 aptr = pat; /* borrow register */
3501 if (datumtype == 'h') {
3503 for (len = 0; len < aint; len++) {
3508 *pat++ = PL_hexdigit[bits & 15];
3513 for (len = 0; len < aint; len++) {
3518 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3522 pat = aptr; /* unborrow register */
3523 XPUSHs(sv_2mortal(sv));
3526 if (len > strend - s)
3531 if (aint >= 128) /* fake up signed chars */
3541 if (aint >= 128) /* fake up signed chars */
3544 sv_setiv(sv, (IV)aint);
3545 PUSHs(sv_2mortal(sv));
3550 if (len > strend - s)
3565 sv_setiv(sv, (IV)auint);
3566 PUSHs(sv_2mortal(sv));
3571 if (len > strend - s)
3574 while (len-- > 0 && s < strend) {
3575 auint = utf8_to_uv((U8*)s, &along);
3578 cdouble += (double)auint;
3586 while (len-- > 0 && s < strend) {
3587 auint = utf8_to_uv((U8*)s, &along);
3590 sv_setuv(sv, (UV)auint);
3591 PUSHs(sv_2mortal(sv));
3596 #if SHORTSIZE == SIZE16
3597 along = (strend - s) / SIZE16;
3599 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3604 #if SHORTSIZE != SIZE16
3607 COPYNN(s, &ashort, sizeof(short));
3618 #if SHORTSIZE > SIZE16
3630 #if SHORTSIZE != SIZE16
3633 COPYNN(s, &ashort, sizeof(short));
3636 sv_setiv(sv, (IV)ashort);
3637 PUSHs(sv_2mortal(sv));
3645 #if SHORTSIZE > SIZE16
3651 sv_setiv(sv, (IV)ashort);
3652 PUSHs(sv_2mortal(sv));
3660 #if SHORTSIZE == SIZE16
3661 along = (strend - s) / SIZE16;
3663 unatint = natint && datumtype == 'S';
3664 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3669 #if SHORTSIZE != SIZE16
3672 COPYNN(s, &aushort, sizeof(unsigned short));
3673 s += sizeof(unsigned short);
3681 COPY16(s, &aushort);
3684 if (datumtype == 'n')
3685 aushort = PerlSock_ntohs(aushort);
3688 if (datumtype == 'v')
3689 aushort = vtohs(aushort);
3698 #if SHORTSIZE != SIZE16
3701 COPYNN(s, &aushort, sizeof(unsigned short));
3702 s += sizeof(unsigned short);
3704 sv_setiv(sv, (UV)aushort);
3705 PUSHs(sv_2mortal(sv));
3712 COPY16(s, &aushort);
3716 if (datumtype == 'n')
3717 aushort = PerlSock_ntohs(aushort);
3720 if (datumtype == 'v')
3721 aushort = vtohs(aushort);
3723 sv_setiv(sv, (UV)aushort);
3724 PUSHs(sv_2mortal(sv));
3730 along = (strend - s) / sizeof(int);
3735 Copy(s, &aint, 1, int);
3738 cdouble += (double)aint;
3747 Copy(s, &aint, 1, int);
3751 /* Without the dummy below unpack("i", pack("i",-1))
3752 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3753 * cc with optimization turned on.
3755 * The bug was detected in
3756 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3757 * with optimization (-O4) turned on.
3758 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3759 * does not have this problem even with -O4.
3761 * This bug was reported as DECC_BUGS 1431
3762 * and tracked internally as GEM_BUGS 7775.
3764 * The bug is fixed in
3765 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3766 * UNIX V4.0F support: DEC C V5.9-006 or later
3767 * UNIX V4.0E support: DEC C V5.8-011 or later
3770 * See also few lines later for the same bug.
3773 sv_setiv(sv, (IV)aint) :
3775 sv_setiv(sv, (IV)aint);
3776 PUSHs(sv_2mortal(sv));
3781 along = (strend - s) / sizeof(unsigned int);
3786 Copy(s, &auint, 1, unsigned int);
3787 s += sizeof(unsigned int);
3789 cdouble += (double)auint;
3798 Copy(s, &auint, 1, unsigned int);
3799 s += sizeof(unsigned int);
3802 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3803 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3804 * See details few lines earlier. */
3806 sv_setuv(sv, (UV)auint) :
3808 sv_setuv(sv, (UV)auint);
3809 PUSHs(sv_2mortal(sv));
3814 #if LONGSIZE == SIZE32
3815 along = (strend - s) / SIZE32;
3817 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3822 #if LONGSIZE != SIZE32
3825 COPYNN(s, &along, sizeof(long));
3828 cdouble += (double)along;
3838 #if LONGSIZE > SIZE32
3839 if (along > 2147483647)
3840 along -= 4294967296;
3844 cdouble += (double)along;
3853 #if LONGSIZE != SIZE32
3856 COPYNN(s, &along, sizeof(long));
3859 sv_setiv(sv, (IV)along);
3860 PUSHs(sv_2mortal(sv));
3868 #if LONGSIZE > SIZE32
3869 if (along > 2147483647)
3870 along -= 4294967296;
3874 sv_setiv(sv, (IV)along);
3875 PUSHs(sv_2mortal(sv));
3883 #if LONGSIZE == SIZE32
3884 along = (strend - s) / SIZE32;
3886 unatint = natint && datumtype == 'L';
3887 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3892 #if LONGSIZE != SIZE32
3895 COPYNN(s, &aulong, sizeof(unsigned long));
3896 s += sizeof(unsigned long);
3898 cdouble += (double)aulong;
3910 if (datumtype == 'N')
3911 aulong = PerlSock_ntohl(aulong);
3914 if (datumtype == 'V')
3915 aulong = vtohl(aulong);
3918 cdouble += (double)aulong;
3927 #if LONGSIZE != SIZE32
3930 COPYNN(s, &aulong, sizeof(unsigned long));
3931 s += sizeof(unsigned long);
3933 sv_setuv(sv, (UV)aulong);
3934 PUSHs(sv_2mortal(sv));
3944 if (datumtype == 'N')
3945 aulong = PerlSock_ntohl(aulong);
3948 if (datumtype == 'V')
3949 aulong = vtohl(aulong);
3952 sv_setuv(sv, (UV)aulong);
3953 PUSHs(sv_2mortal(sv));
3959 along = (strend - s) / sizeof(char*);
3965 if (sizeof(char*) > strend - s)
3968 Copy(s, &aptr, 1, char*);
3974 PUSHs(sv_2mortal(sv));
3984 while ((len > 0) && (s < strend)) {
3985 auv = (auv << 7) | (*s & 0x7f);
3986 if (!(*s++ & 0x80)) {
3990 PUSHs(sv_2mortal(sv));
3994 else if (++bytes >= sizeof(UV)) { /* promote to string */
3998 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3999 while (s < strend) {
4000 sv = mul128(sv, *s & 0x7f);
4001 if (!(*s++ & 0x80)) {
4010 PUSHs(sv_2mortal(sv));
4015 if ((s >= strend) && bytes)
4016 croak("Unterminated compressed integer");
4021 if (sizeof(char*) > strend - s)
4024 Copy(s, &aptr, 1, char*);
4029 sv_setpvn(sv, aptr, len);
4030 PUSHs(sv_2mortal(sv));
4034 along = (strend - s) / sizeof(Quad_t);
4040 if (s + sizeof(Quad_t) > strend)
4043 Copy(s, &aquad, 1, Quad_t);
4044 s += sizeof(Quad_t);
4047 if (aquad >= IV_MIN && aquad <= IV_MAX)
4048 sv_setiv(sv, (IV)aquad);
4050 sv_setnv(sv, (double)aquad);
4051 PUSHs(sv_2mortal(sv));
4055 along = (strend - s) / sizeof(Quad_t);
4061 if (s + sizeof(Uquad_t) > strend)
4064 Copy(s, &auquad, 1, Uquad_t);
4065 s += sizeof(Uquad_t);
4068 if (auquad <= UV_MAX)
4069 sv_setuv(sv, (UV)auquad);
4071 sv_setnv(sv, (double)auquad);
4072 PUSHs(sv_2mortal(sv));
4076 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4079 along = (strend - s) / sizeof(float);
4084 Copy(s, &afloat, 1, float);
4093 Copy(s, &afloat, 1, float);
4096 sv_setnv(sv, (double)afloat);
4097 PUSHs(sv_2mortal(sv));
4103 along = (strend - s) / sizeof(double);
4108 Copy(s, &adouble, 1, double);
4109 s += sizeof(double);
4117 Copy(s, &adouble, 1, double);
4118 s += sizeof(double);
4120 sv_setnv(sv, (double)adouble);
4121 PUSHs(sv_2mortal(sv));
4127 * Initialise the decode mapping. By using a table driven
4128 * algorithm, the code will be character-set independent
4129 * (and just as fast as doing character arithmetic)
4131 if (PL_uudmap['M'] == 0) {
4134 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4135 PL_uudmap[PL_uuemap[i]] = i;
4137 * Because ' ' and '`' map to the same value,
4138 * we need to decode them both the same.
4143 along = (strend - s) * 3 / 4;
4144 sv = NEWSV(42, along);
4147 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4152 len = PL_uudmap[*s++] & 077;
4154 if (s < strend && ISUUCHAR(*s))
4155 a = PL_uudmap[*s++] & 077;
4158 if (s < strend && ISUUCHAR(*s))
4159 b = PL_uudmap[*s++] & 077;
4162 if (s < strend && ISUUCHAR(*s))
4163 c = PL_uudmap[*s++] & 077;
4166 if (s < strend && ISUUCHAR(*s))
4167 d = PL_uudmap[*s++] & 077;
4170 hunk[0] = (a << 2) | (b >> 4);
4171 hunk[1] = (b << 4) | (c >> 2);
4172 hunk[2] = (c << 6) | d;
4173 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4178 else if (s[1] == '\n') /* possible checksum byte */
4181 XPUSHs(sv_2mortal(sv));
4186 if (strchr("fFdD", datumtype) ||
4187 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4191 while (checksum >= 16) {
4195 while (checksum >= 4) {
4201 along = (1 << checksum) - 1;
4202 while (cdouble < 0.0)
4204 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4205 sv_setnv(sv, cdouble);
4208 if (checksum < 32) {
4209 aulong = (1 << checksum) - 1;
4212 sv_setuv(sv, (UV)culong);
4214 XPUSHs(sv_2mortal(sv));
4218 if (SP == oldsp && gimme == G_SCALAR)
4219 PUSHs(&PL_sv_undef);
4224 doencodes(register SV *sv, register char *s, register I32 len)
4228 *hunk = PL_uuemap[len];
4229 sv_catpvn(sv, hunk, 1);
4232 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4233 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4234 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4235 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4236 sv_catpvn(sv, hunk, 4);
4241 char r = (len > 1 ? s[1] : '\0');
4242 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4243 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4244 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4245 hunk[3] = PL_uuemap[0];
4246 sv_catpvn(sv, hunk, 4);
4248 sv_catpvn(sv, "\n", 1);
4252 is_an_int(char *s, STRLEN l)
4255 SV *result = newSVpvn(s, l);
4256 char *result_c = SvPV(result, n_a); /* convenience */
4257 char *out = result_c;
4267 SvREFCNT_dec(result);
4290 SvREFCNT_dec(result);
4296 SvCUR_set(result, out - result_c);
4301 div128(SV *pnum, bool *done)
4302 /* must be '\0' terminated */
4306 char *s = SvPV(pnum, len);
4315 i = m * 10 + (*t - '0');
4317 r = (i >> 7); /* r < 10 */
4324 SvCUR_set(pnum, (STRLEN) (t - s));
4331 djSP; dMARK; dORIGMARK; dTARGET;
4332 register SV *cat = TARG;
4335 register char *pat = SvPVx(*++MARK, fromlen);
4336 register char *patend = pat + fromlen;
4341 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4342 static char *space10 = " ";
4344 /* These must not be in registers: */
4359 #ifdef PERL_NATINT_PACK
4360 int natint; /* native integer */
4365 sv_setpvn(cat, "", 0);
4366 while (pat < patend) {
4367 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4368 datumtype = *pat++ & 0xFF;
4369 #ifdef PERL_NATINT_PACK
4372 if (isSPACE(datumtype))
4375 char *natstr = "sSiIlL";
4377 if (strchr(natstr, datumtype)) {
4378 #ifdef PERL_NATINT_PACK
4384 croak("'!' allowed only after types %s", natstr);
4387 len = strchr("@Xxu", datumtype) ? 0 : items;
4390 else if (isDIGIT(*pat)) {
4392 while (isDIGIT(*pat))
4393 len = (len * 10) + (*pat++ - '0');
4399 croak("Invalid type in pack: '%c'", (int)datumtype);
4400 case ',': /* grandfather in commas but with a warning */
4401 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4402 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4405 DIE("%% may only be used in unpack");
4416 if (SvCUR(cat) < len)
4417 DIE("X outside of string");
4424 sv_catpvn(cat, null10, 10);
4427 sv_catpvn(cat, null10, len);
4433 aptr = SvPV(fromstr, fromlen);
4437 sv_catpvn(cat, aptr, len);
4439 sv_catpvn(cat, aptr, fromlen);
4441 if (datumtype == 'A') {
4443 sv_catpvn(cat, space10, 10);
4446 sv_catpvn(cat, space10, len);
4450 sv_catpvn(cat, null10, 10);
4453 sv_catpvn(cat, null10, len);
4460 char *savepat = pat;
4465 aptr = SvPV(fromstr, fromlen);
4470 SvCUR(cat) += (len+7)/8;
4471 SvGROW(cat, SvCUR(cat) + 1);
4472 aptr = SvPVX(cat) + aint;
4477 if (datumtype == 'B') {
4478 for (len = 0; len++ < aint;) {
4479 items |= *pat++ & 1;
4483 *aptr++ = items & 0xff;
4489 for (len = 0; len++ < aint;) {
4495 *aptr++ = items & 0xff;
4501 if (datumtype == 'B')
4502 items <<= 7 - (aint & 7);
4504 items >>= 7 - (aint & 7);
4505 *aptr++ = items & 0xff;
4507 pat = SvPVX(cat) + SvCUR(cat);
4518 char *savepat = pat;
4523 aptr = SvPV(fromstr, fromlen);
4528 SvCUR(cat) += (len+1)/2;
4529 SvGROW(cat, SvCUR(cat) + 1);
4530 aptr = SvPVX(cat) + aint;
4535 if (datumtype == 'H') {
4536 for (len = 0; len++ < aint;) {
4538 items |= ((*pat++ & 15) + 9) & 15;
4540 items |= *pat++ & 15;
4544 *aptr++ = items & 0xff;
4550 for (len = 0; len++ < aint;) {
4552 items |= (((*pat++ & 15) + 9) & 15) << 4;
4554 items |= (*pat++ & 15) << 4;
4558 *aptr++ = items & 0xff;
4564 *aptr++ = items & 0xff;
4565 pat = SvPVX(cat) + SvCUR(cat);
4577 aint = SvIV(fromstr);
4579 sv_catpvn(cat, &achar, sizeof(char));
4585 auint = SvUV(fromstr);
4586 SvGROW(cat, SvCUR(cat) + 10);
4587 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4592 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4597 afloat = (float)SvNV(fromstr);
4598 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4605 adouble = (double)SvNV(fromstr);
4606 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4612 ashort = (I16)SvIV(fromstr);
4614 ashort = PerlSock_htons(ashort);
4616 CAT16(cat, &ashort);
4622 ashort = (I16)SvIV(fromstr);
4624 ashort = htovs(ashort);
4626 CAT16(cat, &ashort);
4630 #if SHORTSIZE != SIZE16
4632 unsigned short aushort;
4636 aushort = SvUV(fromstr);
4637 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4647 aushort = (U16)SvUV(fromstr);
4648 CAT16(cat, &aushort);
4654 #if SHORTSIZE != SIZE16
4658 ashort = SvIV(fromstr);
4659 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4667 ashort = (I16)SvIV(fromstr);
4668 CAT16(cat, &ashort);
4675 auint = SvUV(fromstr);
4676 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4682 adouble = floor(SvNV(fromstr));
4685 croak("Cannot compress negative numbers");
4691 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4692 adouble <= UV_MAX_cxux
4699 char buf[1 + sizeof(UV)];
4700 char *in = buf + sizeof(buf);
4701 UV auv = U_V(adouble);;
4704 *--in = (auv & 0x7f) | 0x80;
4707 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4708 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4710 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4711 char *from, *result, *in;
4716 /* Copy string and check for compliance */
4717 from = SvPV(fromstr, len);
4718 if ((norm = is_an_int(from, len)) == NULL)
4719 croak("can compress only unsigned integer");
4721 New('w', result, len, char);
4725 *--in = div128(norm, &done) | 0x80;
4726 result[len - 1] &= 0x7F; /* clear continue bit */
4727 sv_catpvn(cat, in, (result + len) - in);
4729 SvREFCNT_dec(norm); /* free norm */
4731 else if (SvNOKp(fromstr)) {
4732 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4733 char *in = buf + sizeof(buf);
4736 double next = floor(adouble / 128);
4737 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4738 if (--in < buf) /* this cannot happen ;-) */
4739 croak ("Cannot compress integer");
4741 } while (adouble > 0);
4742 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4743 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4746 croak("Cannot compress non integer");
4752 aint = SvIV(fromstr);
4753 sv_catpvn(cat, (char*)&aint, sizeof(int));
4759 aulong = SvUV(fromstr);
4761 aulong = PerlSock_htonl(aulong);
4763 CAT32(cat, &aulong);
4769 aulong = SvUV(fromstr);
4771 aulong = htovl(aulong);
4773 CAT32(cat, &aulong);
4777 #if LONGSIZE != SIZE32
4781 aulong = SvUV(fromstr);
4782 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4790 aulong = SvUV(fromstr);
4791 CAT32(cat, &aulong);
4796 #if LONGSIZE != SIZE32
4800 along = SvIV(fromstr);
4801 sv_catpvn(cat, (char *)&along, sizeof(long));
4809 along = SvIV(fromstr);
4818 auquad = (Uquad_t)SvIV(fromstr);
4819 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4825 aquad = (Quad_t)SvIV(fromstr);
4826 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4829 #endif /* HAS_QUAD */
4831 len = 1; /* assume SV is correct length */
4836 if (fromstr == &PL_sv_undef)
4840 /* XXX better yet, could spirit away the string to
4841 * a safe spot and hang on to it until the result
4842 * of pack() (and all copies of the result) are
4845 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4847 "Attempt to pack pointer to temporary value");
4848 if (SvPOK(fromstr) || SvNIOK(fromstr))
4849 aptr = SvPV(fromstr,n_a);
4851 aptr = SvPV_force(fromstr,n_a);
4853 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4858 aptr = SvPV(fromstr, fromlen);
4859 SvGROW(cat, fromlen * 4 / 3);
4864 while (fromlen > 0) {
4871 doencodes(cat, aptr, todo);
4890 register I32 limit = POPi; /* note, negative is forever */
4893 register char *s = SvPV(sv, len);
4894 char *strend = s + len;
4896 register REGEXP *rx;
4900 I32 maxiters = (strend - s) + 10;
4903 I32 origlimit = limit;
4906 AV *oldstack = PL_curstack;
4907 I32 gimme = GIMME_V;
4908 I32 oldsave = PL_savestack_ix;
4909 I32 make_mortal = 1;
4910 MAGIC *mg = (MAGIC *) NULL;
4913 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4918 DIE("panic: do_split");
4919 rx = pm->op_pmregexp;
4921 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4922 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4924 if (pm->op_pmreplroot)
4925 ary = GvAVn((GV*)pm->op_pmreplroot);
4926 else if (gimme != G_ARRAY)
4928 ary = (AV*)PL_curpad[0];
4930 ary = GvAVn(PL_defgv);
4931 #endif /* USE_THREADS */
4934 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4940 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4942 XPUSHs(SvTIED_obj((SV*)ary, mg));
4947 for (i = AvFILLp(ary); i >= 0; i--)
4948 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4950 /* temporarily switch stacks */
4951 SWITCHSTACK(PL_curstack, ary);
4955 base = SP - PL_stack_base;
4957 if (pm->op_pmflags & PMf_SKIPWHITE) {
4958 if (pm->op_pmflags & PMf_LOCALE) {
4959 while (isSPACE_LC(*s))
4967 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4968 SAVEINT(PL_multiline);
4969 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4973 limit = maxiters + 2;
4974 if (pm->op_pmflags & PMf_WHITE) {
4977 while (m < strend &&
4978 !((pm->op_pmflags & PMf_LOCALE)
4979 ? isSPACE_LC(*m) : isSPACE(*m)))
4984 dstr = NEWSV(30, m-s);
4985 sv_setpvn(dstr, s, m-s);
4991 while (s < strend &&
4992 ((pm->op_pmflags & PMf_LOCALE)
4993 ? isSPACE_LC(*s) : isSPACE(*s)))
4997 else if (strEQ("^", rx->precomp)) {
5000 for (m = s; m < strend && *m != '\n'; m++) ;
5004 dstr = NEWSV(30, m-s);
5005 sv_setpvn(dstr, s, m-s);
5012 else if (rx->check_substr && !rx->nparens
5013 && (rx->reganch & ROPT_CHECK_ALL)
5014 && !(rx->reganch & ROPT_ANCH)) {
5015 i = SvCUR(rx->check_substr);
5016 if (i == 1 && !SvTAIL(rx->check_substr)) {
5017 i = *SvPVX(rx->check_substr);
5020 for (m = s; m < strend && *m != i; m++) ;
5023 dstr = NEWSV(30, m-s);
5024 sv_setpvn(dstr, s, m-s);
5033 while (s < strend && --limit &&
5034 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
5035 rx->check_substr, 0)) )
5038 dstr = NEWSV(31, m-s);
5039 sv_setpvn(dstr, s, m-s);
5048 maxiters += (strend - s) * rx->nparens;
5049 while (s < strend && --limit &&
5050 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
5052 TAINT_IF(RX_MATCH_TAINTED(rx));
5054 && rx->subbase != orig) {
5059 strend = s + (strend - m);
5062 dstr = NEWSV(32, m-s);
5063 sv_setpvn(dstr, s, m-s);
5068 for (i = 1; i <= rx->nparens; i++) {
5072 dstr = NEWSV(33, m-s);
5073 sv_setpvn(dstr, s, m-s);
5076 dstr = NEWSV(33, 0);
5086 LEAVE_SCOPE(oldsave);
5087 iters = (SP - PL_stack_base) - base;
5088 if (iters > maxiters)
5091 /* keep field after final delim? */
5092 if (s < strend || (iters && origlimit)) {
5093 dstr = NEWSV(34, strend-s);
5094 sv_setpvn(dstr, s, strend-s);
5100 else if (!origlimit) {
5101 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5107 SWITCHSTACK(ary, oldstack);
5108 if (SvSMAGICAL(ary)) {
5113 if (gimme == G_ARRAY) {
5115 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5123 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5126 if (gimme == G_ARRAY) {
5127 /* EXTEND should not be needed - we just popped them */
5129 for (i=0; i < iters; i++) {
5130 SV **svp = av_fetch(ary, i, FALSE);
5131 PUSHs((svp) ? *svp : &PL_sv_undef);
5138 if (gimme == G_ARRAY)
5141 if (iters || !pm->op_pmreplroot) {
5151 unlock_condpair(void *svv)
5154 MAGIC *mg = mg_find((SV*)svv, 'm');
5157 croak("panic: unlock_condpair unlocking non-mutex");
5158 MUTEX_LOCK(MgMUTEXP(mg));
5159 if (MgOWNER(mg) != thr)
5160 croak("panic: unlock_condpair unlocking mutex that we don't own");
5162 COND_SIGNAL(MgOWNERCONDP(mg));
5163 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5164 (unsigned long)thr, (unsigned long)svv);)
5165 MUTEX_UNLOCK(MgMUTEXP(mg));
5167 #endif /* USE_THREADS */
5180 mg = condpair_magic(sv);
5181 MUTEX_LOCK(MgMUTEXP(mg));
5182 if (MgOWNER(mg) == thr)
5183 MUTEX_UNLOCK(MgMUTEXP(mg));
5186 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5188 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5189 (unsigned long)thr, (unsigned long)sv);)
5190 MUTEX_UNLOCK(MgMUTEXP(mg));
5191 save_destructor(unlock_condpair, sv);
5193 #endif /* USE_THREADS */
5194 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5195 || SvTYPE(retsv) == SVt_PVCV) {
5196 retsv = refto(retsv);
5207 if (PL_op->op_private & OPpLVAL_INTRO)
5208 PUSHs(*save_threadsv(PL_op->op_targ));
5210 PUSHs(THREADSV(PL_op->op_targ));
5213 DIE("tried to access per-thread data in non-threaded perl");
5214 #endif /* USE_THREADS */