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.
8 * $FreeBSD: src/contrib/perl5/pp.c,v 1.2 1999/12/13 19:11:53 ache Exp $
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Types used in bitwise operations.
33 * Normally we'd just use IV and UV. However, some hardware and
34 * software combinations (e.g. Alpha and current OSF/1) don't have a
35 * floating-point type to use for NV that has adequate bits to fully
36 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
38 * It just so happens that "int" is the right size almost everywhere.
44 * Mask used after bitwise operations.
46 * There is at least one realm (Cray word machines) that doesn't
47 * have an integral type (except char) small enough to be represented
48 * in a double without loss; that is, it has no 32-bit type.
50 #if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
52 # define BW_MASK ((1 << BW_BITS) - 1)
53 # define BW_SIGN (1 << (BW_BITS - 1))
54 # define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
55 # define BWu(u) ((u) & BW_MASK)
62 * Offset for integer pack/unpack.
64 * On architectures where I16 and I32 aren't really 16 and 32 bits,
65 * which for now are all Crays, pack and unpack have to play games.
69 * These values are required for portability of pack() output.
70 * If they're not right on your machine, then pack() and unpack()
71 * wouldn't work right anyway; you'll need to apply the Cray hack.
72 * (I'd like to check them with #if, but you can't use sizeof() in
73 * the preprocessor.) --???
76 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
77 defines are now in config.h. --Andy Dougherty April 1998
82 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
83 # if BYTEORDER == 0x12345678
84 # define OFF16(p) (char*)(p)
85 # define OFF32(p) (char*)(p)
87 # if BYTEORDER == 0x87654321
88 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
89 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
91 }}}} bad cray byte order
94 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
95 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
96 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
97 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
99 # define COPY16(s,p) Copy(s, p, SIZE16, char)
100 # define COPY32(s,p) Copy(s, p, SIZE32, char)
101 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
102 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
106 static void doencodes _((SV* sv, char* s, I32 len));
107 static SV* refto _((SV* sv));
108 static U32 seed _((void));
109 static bool srand_called = FALSE;
113 /* variations on pp_null */
119 /* XXX I can't imagine anyone who doesn't have this actually _needs_
120 it, since pid_t is an integral type.
123 #ifdef NEED_GETPID_PROTO
124 extern Pid_t getpid (void);
130 if (GIMME_V == G_SCALAR)
131 XPUSHs(&PL_sv_undef);
145 if (PL_op->op_private & OPpLVAL_INTRO)
146 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
148 if (PL_op->op_flags & OPf_REF) {
152 if (GIMME == G_ARRAY) {
153 I32 maxarg = AvFILL((AV*)TARG) + 1;
155 if (SvMAGICAL(TARG)) {
157 for (i=0; i < maxarg; i++) {
158 SV **svp = av_fetch((AV*)TARG, i, FALSE);
159 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
163 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
168 SV* sv = sv_newmortal();
169 I32 maxarg = AvFILL((AV*)TARG) + 1;
170 sv_setiv(sv, maxarg);
182 if (PL_op->op_private & OPpLVAL_INTRO)
183 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
184 if (PL_op->op_flags & OPf_REF)
187 if (gimme == G_ARRAY) {
188 RETURNOP(do_kv(ARGS));
190 else if (gimme == G_SCALAR) {
191 SV* sv = sv_newmortal();
192 if (HvFILL((HV*)TARG))
193 sv_setpvf(sv, "%ld/%ld",
194 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
204 DIE("NOT IMPL LINE %d",__LINE__);
216 if (SvTYPE(sv) == SVt_PVIO) {
217 GV *gv = (GV*) sv_newmortal();
218 gv_init(gv, 0, "", 0, 0);
219 GvIOp(gv) = (IO *)sv;
220 (void)SvREFCNT_inc(sv);
222 } else if (SvTYPE(sv) != SVt_PVGV)
223 DIE("Not a GLOB reference");
226 if (SvTYPE(sv) != SVt_PVGV) {
230 if (SvGMAGICAL(sv)) {
236 if (PL_op->op_flags & OPf_REF ||
237 PL_op->op_private & HINT_STRICT_REFS)
238 DIE(no_usym, "a symbol");
244 if (PL_op->op_private & HINT_STRICT_REFS)
245 DIE(no_symref, sym, "a symbol");
246 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
249 if (PL_op->op_private & OPpLVAL_INTRO)
250 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
262 switch (SvTYPE(sv)) {
266 DIE("Not a SCALAR reference");
274 if (SvTYPE(gv) != SVt_PVGV) {
275 if (SvGMAGICAL(sv)) {
281 if (PL_op->op_flags & OPf_REF ||
282 PL_op->op_private & HINT_STRICT_REFS)
283 DIE(no_usym, "a SCALAR");
289 if (PL_op->op_private & HINT_STRICT_REFS)
290 DIE(no_symref, sym, "a SCALAR");
291 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
295 if (PL_op->op_flags & OPf_MOD) {
296 if (PL_op->op_private & OPpLVAL_INTRO)
297 sv = save_scalar((GV*)TOPs);
298 else if (PL_op->op_private & OPpDEREF)
299 vivify_ref(sv, PL_op->op_private & OPpDEREF);
309 SV *sv = AvARYLEN(av);
311 AvARYLEN(av) = sv = NEWSV(0,0);
312 sv_upgrade(sv, SVt_IV);
313 sv_magic(sv, (SV*)av, '#', Nullch, 0);
321 djSP; dTARGET; dPOPss;
323 if (PL_op->op_flags & OPf_MOD) {
324 if (SvTYPE(TARG) < SVt_PVLV) {
325 sv_upgrade(TARG, SVt_PVLV);
326 sv_magic(TARG, Nullsv, '.', Nullch, 0);
330 if (LvTARG(TARG) != sv) {
332 SvREFCNT_dec(LvTARG(TARG));
333 LvTARG(TARG) = SvREFCNT_inc(sv);
335 PUSHs(TARG); /* no SvSETMAGIC */
341 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
342 mg = mg_find(sv, 'g');
343 if (mg && mg->mg_len >= 0) {
344 PUSHi(mg->mg_len + PL_curcop->cop_arybase);
358 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
359 /* (But not in defined().) */
360 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
363 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
366 cv = (CV*)&PL_sv_undef;
380 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
381 char *s = SvPVX(TOPs);
382 if (strnEQ(s, "CORE::", 6)) {
385 code = keyword(s + 6, SvCUR(TOPs) - 6);
386 if (code < 0) { /* Overridable. */
387 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
388 int i = 0, n = 0, seen_question = 0;
390 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
392 while (i < MAXO) { /* The slow way. */
393 if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
397 goto nonesuch; /* Should not happen... */
399 oa = opargs[i] >> OASHIFT;
401 if (oa & OA_OPTIONAL) {
404 } else if (seen_question)
405 goto set; /* XXXX system, exec */
406 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
407 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
410 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
411 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
415 ret = sv_2mortal(newSVpv(str, n - 1));
416 } else if (code) /* Non-Overridable */
418 else { /* None such */
420 croak("Cannot find an opnumber for \"%s\"", s+6);
424 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
426 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
435 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
437 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
453 if (GIMME != G_ARRAY) {
457 *MARK = &PL_sv_undef;
458 *MARK = refto(*MARK);
462 EXTEND_MORTAL(SP - MARK);
464 *MARK = refto(*MARK);
473 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
476 if (!(sv = LvTARG(sv)))
479 else if (SvPADTMP(sv))
483 (void)SvREFCNT_inc(sv);
486 sv_upgrade(rv, SVt_RV);
500 if (sv && SvGMAGICAL(sv))
503 if (!sv || !SvROK(sv))
507 pv = sv_reftype(sv,TRUE);
508 PUSHp(pv, strlen(pv));
518 stash = PL_curcop->cop_stash;
522 char *ptr = SvPV(ssv,len);
523 if (PL_dowarn && len == 0)
524 warn("Explicit blessing to '' (assuming package main)");
525 stash = gv_stashpvn(ptr, len, TRUE);
528 (void)sv_bless(TOPs, stash);
542 elem = SvPV(sv, n_a);
546 switch (elem ? *elem : '\0')
549 if (strEQ(elem, "ARRAY"))
550 tmpRef = (SV*)GvAV(gv);
553 if (strEQ(elem, "CODE"))
554 tmpRef = (SV*)GvCVu(gv);
557 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
558 tmpRef = (SV*)GvIOp(gv);
561 if (strEQ(elem, "GLOB"))
565 if (strEQ(elem, "HASH"))
566 tmpRef = (SV*)GvHV(gv);
569 if (strEQ(elem, "IO"))
570 tmpRef = (SV*)GvIOp(gv);
573 if (strEQ(elem, "NAME"))
574 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
577 if (strEQ(elem, "PACKAGE"))
578 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
581 if (strEQ(elem, "SCALAR"))
595 /* Pattern matching */
600 register UNOP *unop = cUNOP;
601 register unsigned char *s;
604 register I32 *sfirst;
608 if (sv == PL_lastscream) {
614 SvSCREAM_off(PL_lastscream);
615 SvREFCNT_dec(PL_lastscream);
617 PL_lastscream = SvREFCNT_inc(sv);
620 s = (unsigned char*)(SvPV(sv, len));
624 if (pos > PL_maxscream) {
625 if (PL_maxscream < 0) {
626 PL_maxscream = pos + 80;
627 New(301, PL_screamfirst, 256, I32);
628 New(302, PL_screamnext, PL_maxscream, I32);
631 PL_maxscream = pos + pos / 4;
632 Renew(PL_screamnext, PL_maxscream, I32);
636 sfirst = PL_screamfirst;
637 snext = PL_screamnext;
639 if (!sfirst || !snext)
640 DIE("do_study: out of memory");
642 for (ch = 256; ch; --ch)
649 snext[pos] = sfirst[ch] - pos;
656 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
665 if (PL_op->op_flags & OPf_STACKED)
671 TARG = sv_newmortal();
672 PUSHi(do_trans(sv, PL_op));
676 /* Lvalue operators. */
688 djSP; dMARK; dTARGET;
698 SETi(do_chomp(TOPs));
704 djSP; dMARK; dTARGET;
705 register I32 count = 0;
708 count += do_chomp(POPs);
719 if (!sv || !SvANY(sv))
721 switch (SvTYPE(sv)) {
723 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
727 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
731 if (CvROOT(sv) || CvXSUB(sv))
748 if (!PL_op->op_private) {
757 if (SvTHINKFIRST(sv)) {
758 if (SvREADONLY(sv)) {
760 if (PL_curcop != &PL_compiling)
767 switch (SvTYPE(sv)) {
777 if (PL_dowarn && cv_const_sv((CV*)sv))
778 warn("Constant subroutine %s undefined",
779 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
782 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
784 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
788 SvSetMagicSV(sv, &PL_sv_undef);
792 Newz(602, gp, 1, GP);
793 GvGP(sv) = gp_ref(gp);
794 GvSV(sv) = NEWSV(72,0);
795 GvLINE(sv) = PL_curcop->cop_line;
801 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
804 SvPV_set(sv, Nullch);
817 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
819 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
820 SvIVX(TOPs) != IV_MIN)
823 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
834 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
836 sv_setsv(TARG, TOPs);
837 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
838 SvIVX(TOPs) != IV_MAX)
841 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
855 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
857 sv_setsv(TARG, TOPs);
858 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
859 SvIVX(TOPs) != IV_MIN)
862 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
871 /* Ordinary operators. */
875 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
878 SETn( pow( left, right) );
885 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
888 SETn( left * right );
895 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
900 DIE("Illegal division by zero");
902 /* insure that 20./5. == 4. */
905 if ((double)I_V(left) == left &&
906 (double)I_V(right) == right &&
907 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
910 value = left / right;
914 value = left / right;
923 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
931 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
933 right = (right_neg = (i < 0)) ? -i : i;
937 right = U_V((right_neg = (n < 0)) ? -n : n);
940 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
942 left = (left_neg = (i < 0)) ? -i : i;
946 left = U_V((left_neg = (n < 0)) ? -n : n);
950 DIE("Illegal modulus zero");
953 if ((left_neg != right_neg) && ans)
956 /* XXX may warn: unary minus operator applied to unsigned type */
957 /* could change -foo to be (~foo)+1 instead */
958 if (ans <= ~((UV)IV_MAX)+1)
959 sv_setiv(TARG, ~ans+1);
961 sv_setnv(TARG, -(double)ans);
972 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
974 register I32 count = POPi;
975 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
977 I32 items = SP - MARK;
989 repeatcpy((char*)(MARK + items), (char*)MARK,
990 items * sizeof(SV*), count - 1);
996 else { /* Note: mark already snarfed by pp_list */
1001 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1002 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1003 DIE("Can't x= to readonly value");
1007 SvSetSV(TARG, tmpstr);
1008 SvPV_force(TARG, len);
1013 SvGROW(TARG, (count * len) + 1);
1014 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1015 SvCUR(TARG) *= count;
1017 *SvEND(TARG) = '\0';
1019 (void)SvPOK_only(TARG);
1028 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1031 SETn( left - right );
1038 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1041 if (PL_op->op_private & HINT_INTEGER) {
1043 i = BWi(i) << shift;
1057 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1060 if (PL_op->op_private & HINT_INTEGER) {
1062 i = BWi(i) >> shift;
1076 djSP; tryAMAGICbinSET(lt,0);
1079 SETs(boolSV(TOPn < value));
1086 djSP; tryAMAGICbinSET(gt,0);
1089 SETs(boolSV(TOPn > value));
1096 djSP; tryAMAGICbinSET(le,0);
1099 SETs(boolSV(TOPn <= value));
1106 djSP; tryAMAGICbinSET(ge,0);
1109 SETs(boolSV(TOPn >= value));
1116 djSP; tryAMAGICbinSET(ne,0);
1119 SETs(boolSV(TOPn != value));
1126 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1133 else if (left < right)
1135 else if (left > right)
1148 djSP; tryAMAGICbinSET(slt,0);
1151 int cmp = ((PL_op->op_private & OPpLOCALE)
1152 ? sv_cmp_locale(left, right)
1153 : sv_cmp(left, right));
1154 SETs(boolSV(cmp < 0));
1161 djSP; tryAMAGICbinSET(sgt,0);
1164 int cmp = ((PL_op->op_private & OPpLOCALE)
1165 ? sv_cmp_locale(left, right)
1166 : sv_cmp(left, right));
1167 SETs(boolSV(cmp > 0));
1174 djSP; tryAMAGICbinSET(sle,0);
1177 int cmp = ((PL_op->op_private & OPpLOCALE)
1178 ? sv_cmp_locale(left, right)
1179 : sv_cmp(left, right));
1180 SETs(boolSV(cmp <= 0));
1187 djSP; tryAMAGICbinSET(sge,0);
1190 int cmp = ((PL_op->op_private & OPpLOCALE)
1191 ? sv_cmp_locale(left, right)
1192 : sv_cmp(left, right));
1193 SETs(boolSV(cmp >= 0));
1200 djSP; tryAMAGICbinSET(seq,0);
1203 SETs(boolSV(sv_eq(left, right)));
1210 djSP; tryAMAGICbinSET(sne,0);
1213 SETs(boolSV(!sv_eq(left, right)));
1220 djSP; dTARGET; tryAMAGICbin(scmp,0);
1223 int cmp = ((PL_op->op_private & OPpLOCALE)
1224 ? sv_cmp_locale(left, right)
1225 : sv_cmp(left, right));
1233 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1236 if (SvNIOKp(left) || SvNIOKp(right)) {
1237 if (PL_op->op_private & HINT_INTEGER) {
1238 IBW value = SvIV(left) & SvIV(right);
1242 UBW value = SvUV(left) & SvUV(right);
1247 do_vop(PL_op->op_type, TARG, left, right);
1256 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1259 if (SvNIOKp(left) || SvNIOKp(right)) {
1260 if (PL_op->op_private & HINT_INTEGER) {
1261 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1265 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1270 do_vop(PL_op->op_type, TARG, left, right);
1279 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1282 if (SvNIOKp(left) || SvNIOKp(right)) {
1283 if (PL_op->op_private & HINT_INTEGER) {
1284 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1288 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1293 do_vop(PL_op->op_type, TARG, left, right);
1302 djSP; dTARGET; tryAMAGICun(neg);
1307 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1309 else if (SvNIOKp(sv))
1311 else if (SvPOKp(sv)) {
1313 char *s = SvPV(sv, len);
1314 if (isIDFIRST(*s)) {
1315 sv_setpvn(TARG, "-", 1);
1318 else if (*s == '+' || *s == '-') {
1320 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1323 sv_setnv(TARG, -SvNV(sv));
1335 djSP; tryAMAGICunSET(not);
1336 #endif /* OVERLOAD */
1337 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1343 djSP; dTARGET; tryAMAGICun(compl);
1347 if (PL_op->op_private & HINT_INTEGER) {
1348 IBW value = ~SvIV(sv);
1352 UBW value = ~SvUV(sv);
1357 register char *tmps;
1358 register long *tmpl;
1363 tmps = SvPV_force(TARG, len);
1366 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1369 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1373 for ( ; anum > 0; anum--, tmps++)
1382 /* integer versions of some of the above */
1386 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1389 SETi( left * right );
1396 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1400 DIE("Illegal division by zero");
1401 value = POPi / value;
1409 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1413 DIE("Illegal modulus zero");
1414 SETi( left % right );
1421 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1424 SETi( left + right );
1431 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1434 SETi( left - right );
1441 djSP; tryAMAGICbinSET(lt,0);
1444 SETs(boolSV(left < right));
1451 djSP; tryAMAGICbinSET(gt,0);
1454 SETs(boolSV(left > right));
1461 djSP; tryAMAGICbinSET(le,0);
1464 SETs(boolSV(left <= right));
1471 djSP; tryAMAGICbinSET(ge,0);
1474 SETs(boolSV(left >= right));
1481 djSP; tryAMAGICbinSET(eq,0);
1484 SETs(boolSV(left == right));
1491 djSP; tryAMAGICbinSET(ne,0);
1494 SETs(boolSV(left != right));
1501 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1508 else if (left < right)
1519 djSP; dTARGET; tryAMAGICun(neg);
1524 /* High falutin' math. */
1528 djSP; dTARGET; tryAMAGICbin(atan2,0);
1531 SETn(atan2(left, right));
1538 djSP; dTARGET; tryAMAGICun(sin);
1550 djSP; dTARGET; tryAMAGICun(cos);
1560 /* Support Configure command-line overrides for rand() functions.
1561 After 5.005, perhaps we should replace this by Configure support
1562 for drand48(), random(), or rand(). For 5.005, though, maintain
1563 compatibility by calling rand() but allow the user to override it.
1564 See INSTALL for details. --Andy Dougherty 15 July 1998
1567 # define my_rand rand
1570 # define my_srand srand
1583 if (!srand_called) {
1584 (void)my_srand((unsigned)seed());
1585 srand_called = TRUE;
1588 value = my_rand() * value / 2147483648.0;
1591 value = my_rand() * value / 65536.0;
1594 value = my_rand() * value / 32768.0;
1596 value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
1612 (void)my_srand((unsigned)anum);
1613 srand_called = TRUE;
1622 * This is really just a quick hack which grabs various garbage
1623 * values. It really should be a real hash algorithm which
1624 * spreads the effect of every input bit onto every output bit,
1625 * if someone who knows about such tings would bother to write it.
1626 * Might be a good idea to add that function to CORE as well.
1627 * No numbers below come from careful analysis or anyting here,
1628 * except they are primes and SEED_C1 > 1E6 to get a full-width
1629 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1630 * probably be bigger too.
1633 # define SEED_C1 1000003
1634 #define SEED_C4 73819
1636 # define SEED_C1 25747
1637 #define SEED_C4 20639
1641 #define SEED_C5 26107
1644 #ifndef PERL_NO_DEV_RANDOM
1649 # include <starlet.h>
1650 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1651 * in 100-ns units, typically incremented ever 10 ms. */
1652 unsigned int when[2];
1654 # ifdef HAS_GETTIMEOFDAY
1655 struct timeval when;
1661 /* This test is an escape hatch, this symbol isn't set by Configure. */
1662 #ifndef PERL_NO_DEV_RANDOM
1663 #ifndef PERL_RANDOM_DEVICE
1664 /* /dev/random isn't used by default because reads from it will block
1665 * if there isn't enough entropy available. You can compile with
1666 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1667 * is enough real entropy to fill the seed. */
1668 # define PERL_RANDOM_DEVICE "/dev/urandom"
1670 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1672 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1681 _ckvmssts(sys$gettim(when));
1682 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1684 # ifdef HAS_GETTIMEOFDAY
1685 gettimeofday(&when,(struct timezone *) 0);
1686 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1689 u = (U32)SEED_C1 * when;
1692 u += SEED_C3 * (U32)getpid();
1693 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1694 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1695 u += SEED_C5 * (U32)(UV)&when;
1702 djSP; dTARGET; tryAMAGICun(exp);
1714 djSP; dTARGET; tryAMAGICun(log);
1719 SET_NUMERIC_STANDARD();
1720 DIE("Can't take log of %g", value);
1730 djSP; dTARGET; tryAMAGICun(sqrt);
1735 SET_NUMERIC_STANDARD();
1736 DIE("Can't take sqrt of %g", value);
1738 value = sqrt(value);
1748 double value = TOPn;
1751 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1757 (void)modf(value, &value);
1759 (void)modf(-value, &value);
1774 djSP; dTARGET; tryAMAGICun(abs);
1776 double value = TOPn;
1779 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1780 (iv = SvIVX(TOPs)) != IV_MIN) {
1802 XPUSHu(scan_hex(tmps, 99, &argtype));
1815 while (*tmps && isSPACE(*tmps))
1820 value = scan_hex(++tmps, 99, &argtype);
1822 value = scan_oct(tmps, 99, &argtype);
1832 SETi( sv_len(TOPs) );
1845 I32 lvalue = PL_op->op_flags & OPf_MOD;
1847 I32 arybase = PL_curcop->cop_arybase;
1851 SvTAINTED_off(TARG); /* decontaminate */
1855 repl = SvPV(sv, repl_len);
1862 tmps = SvPV(sv, curlen);
1863 if (pos >= arybase) {
1881 else if (len >= 0) {
1883 if (rem > (I32)curlen)
1897 if (PL_dowarn || lvalue || repl)
1898 warn("substr outside of string");
1903 sv_setpvn(TARG, tmps, rem);
1904 if (lvalue) { /* it's an lvalue! */
1905 if (!SvGMAGICAL(sv)) {
1910 warn("Attempt to use reference as lvalue in substr");
1912 if (SvOK(sv)) /* is it defined ? */
1913 (void)SvPOK_only(sv);
1915 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1918 if (SvTYPE(TARG) < SVt_PVLV) {
1919 sv_upgrade(TARG, SVt_PVLV);
1920 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1924 if (LvTARG(TARG) != sv) {
1926 SvREFCNT_dec(LvTARG(TARG));
1927 LvTARG(TARG) = SvREFCNT_inc(sv);
1929 LvTARGOFF(TARG) = pos;
1930 LvTARGLEN(TARG) = rem;
1933 sv_insert(sv, pos, rem, repl, repl_len);
1936 PUSHs(TARG); /* avoid SvSETMAGIC here */
1943 register I32 size = POPi;
1944 register I32 offset = POPi;
1945 register SV *src = POPs;
1946 I32 lvalue = PL_op->op_flags & OPf_MOD;
1948 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1949 unsigned long retnum;
1952 SvTAINTED_off(TARG); /* decontaminate */
1953 offset *= size; /* turn into bit offset */
1954 len = (offset + size + 7) / 8;
1955 if (offset < 0 || size < 1)
1958 if (lvalue) { /* it's an lvalue! */
1959 if (SvTYPE(TARG) < SVt_PVLV) {
1960 sv_upgrade(TARG, SVt_PVLV);
1961 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1965 if (LvTARG(TARG) != src) {
1967 SvREFCNT_dec(LvTARG(TARG));
1968 LvTARG(TARG) = SvREFCNT_inc(src);
1970 LvTARGOFF(TARG) = offset;
1971 LvTARGLEN(TARG) = size;
1979 if (offset >= srclen)
1982 retnum = (unsigned long) s[offset] << 8;
1984 else if (size == 32) {
1985 if (offset >= srclen)
1987 else if (offset + 1 >= srclen)
1988 retnum = (unsigned long) s[offset] << 24;
1989 else if (offset + 2 >= srclen)
1990 retnum = ((unsigned long) s[offset] << 24) +
1991 ((unsigned long) s[offset + 1] << 16);
1993 retnum = ((unsigned long) s[offset] << 24) +
1994 ((unsigned long) s[offset + 1] << 16) +
1995 (s[offset + 2] << 8);
2000 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2005 else if (size == 16)
2006 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2007 else if (size == 32)
2008 retnum = ((unsigned long) s[offset] << 24) +
2009 ((unsigned long) s[offset + 1] << 16) +
2010 (s[offset + 2] << 8) + s[offset+3];
2014 sv_setuv(TARG, (UV)retnum);
2029 I32 arybase = PL_curcop->cop_arybase;
2034 offset = POPi - arybase;
2037 tmps = SvPV(big, biglen);
2040 else if (offset > biglen)
2042 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2043 (unsigned char*)tmps + biglen, little, 0)))
2044 retval = -1 + arybase;
2046 retval = tmps2 - tmps + arybase;
2063 I32 arybase = PL_curcop->cop_arybase;
2069 tmps2 = SvPV(little, llen);
2070 tmps = SvPV(big, blen);
2074 offset = SvIV(offstr) - arybase + llen;
2077 else if (offset > blen)
2079 if (!(tmps2 = rninstr(tmps, tmps + offset,
2080 tmps2, tmps2 + llen)))
2081 retval = -1 + arybase;
2083 retval = tmps2 - tmps + arybase;
2090 djSP; dMARK; dORIGMARK; dTARGET;
2091 #ifdef USE_LOCALE_NUMERIC
2092 if (PL_op->op_private & OPpLOCALE)
2093 SET_NUMERIC_LOCAL();
2095 SET_NUMERIC_STANDARD();
2097 do_sprintf(TARG, SP-MARK, MARK+1);
2098 TAINT_IF(SvTAINTED(TARG));
2113 value = (I32) (*tmps & 255);
2118 value = (I32) (anum & 255);
2129 (void)SvUPGRADE(TARG,SVt_PV);
2135 (void)SvPOK_only(TARG);
2142 djSP; dTARGET; dPOPTOPssrl;
2145 char *tmps = SvPV(left, n_a);
2147 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2149 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2153 "The crypt() function is unimplemented due to excessive paranoia.");
2166 if (!SvPADTMP(sv)) {
2172 s = SvPV_force(sv, n_a);
2174 if (PL_op->op_private & OPpLOCALE) {
2177 *s = toUPPER_LC(*s);
2194 if (!SvPADTMP(sv)) {
2200 s = SvPV_force(sv, n_a);
2202 if (PL_op->op_private & OPpLOCALE) {
2205 *s = toLOWER_LC(*s);
2224 if (!SvPADTMP(sv)) {
2231 s = SvPV_force(sv, len);
2233 register char *send = s + len;
2235 if (PL_op->op_private & OPpLOCALE) {
2238 for (; s < send; s++)
2239 *s = toUPPER_LC(*s);
2242 for (; s < send; s++)
2258 if (!SvPADTMP(sv)) {
2265 s = SvPV_force(sv, len);
2267 register char *send = s + len;
2269 if (PL_op->op_private & OPpLOCALE) {
2272 for (; s < send; s++)
2273 *s = toLOWER_LC(*s);
2276 for (; s < send; s++)
2290 register char *s = SvPV(sv,len);
2294 (void)SvUPGRADE(TARG, SVt_PV);
2295 SvGROW(TARG, (len * 2) + 1);
2303 SvCUR_set(TARG, d - SvPVX(TARG));
2304 (void)SvPOK_only(TARG);
2307 sv_setpvn(TARG, s, len);
2309 if (SvSMAGICAL(TARG))
2318 djSP; dMARK; dORIGMARK;
2320 register AV* av = (AV*)POPs;
2321 register I32 lval = PL_op->op_flags & OPf_MOD;
2322 I32 arybase = PL_curcop->cop_arybase;
2325 if (SvTYPE(av) == SVt_PVAV) {
2326 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2328 for (svp = MARK + 1; svp <= SP; svp++) {
2333 if (max > AvMAX(av))
2336 while (++MARK <= SP) {
2337 elem = SvIVx(*MARK);
2341 svp = av_fetch(av, elem, lval);
2343 if (!svp || *svp == &PL_sv_undef)
2344 DIE(no_aelem, elem);
2345 if (PL_op->op_private & OPpLVAL_INTRO)
2346 save_aelem(av, elem, svp);
2348 *MARK = svp ? *svp : &PL_sv_undef;
2351 if (GIMME != G_ARRAY) {
2359 /* Associative arrays. */
2364 HV *hash = (HV*)POPs;
2366 I32 gimme = GIMME_V;
2367 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2370 /* might clobber stack_sp */
2371 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2376 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2377 if (gimme == G_ARRAY) {
2379 /* might clobber stack_sp */
2380 sv_setsv(TARG, realhv ?
2381 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2386 else if (gimme == G_SCALAR)
2405 I32 gimme = GIMME_V;
2406 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2410 if (PL_op->op_private & OPpSLICE) {
2414 hvtype = SvTYPE(hv);
2415 while (++MARK <= SP) {
2416 if (hvtype == SVt_PVHV)
2417 sv = hv_delete_ent(hv, *MARK, discard, 0);
2419 DIE("Not a HASH reference");
2420 *MARK = sv ? sv : &PL_sv_undef;
2424 else if (gimme == G_SCALAR) {
2433 if (SvTYPE(hv) == SVt_PVHV)
2434 sv = hv_delete_ent(hv, keysv, discard, 0);
2436 DIE("Not a HASH reference");
2450 if (SvTYPE(hv) == SVt_PVHV) {
2451 if (hv_exists_ent(hv, tmpsv, 0))
2453 } else if (SvTYPE(hv) == SVt_PVAV) {
2454 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2457 DIE("Not a HASH reference");
2464 djSP; dMARK; dORIGMARK;
2465 register HV *hv = (HV*)POPs;
2466 register I32 lval = PL_op->op_flags & OPf_MOD;
2467 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2469 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2470 DIE("Can't localize pseudo-hash element");
2472 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2473 while (++MARK <= SP) {
2477 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2478 svp = he ? &HeVAL(he) : 0;
2480 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2483 if (!svp || *svp == &PL_sv_undef) {
2485 DIE(no_helem, SvPV(keysv, n_a));
2487 if (PL_op->op_private & OPpLVAL_INTRO)
2488 save_helem(hv, keysv, svp);
2490 *MARK = svp ? *svp : &PL_sv_undef;
2493 if (GIMME != G_ARRAY) {
2501 /* List operators. */
2506 if (GIMME != G_ARRAY) {
2508 *MARK = *SP; /* unwanted list, return last item */
2510 *MARK = &PL_sv_undef;
2519 SV **lastrelem = PL_stack_sp;
2520 SV **lastlelem = PL_stack_base + POPMARK;
2521 SV **firstlelem = PL_stack_base + POPMARK + 1;
2522 register SV **firstrelem = lastlelem + 1;
2523 I32 arybase = PL_curcop->cop_arybase;
2524 I32 lval = PL_op->op_flags & OPf_MOD;
2525 I32 is_something_there = lval;
2527 register I32 max = lastrelem - lastlelem;
2528 register SV **lelem;
2531 if (GIMME != G_ARRAY) {
2532 ix = SvIVx(*lastlelem);
2537 if (ix < 0 || ix >= max)
2538 *firstlelem = &PL_sv_undef;
2540 *firstlelem = firstrelem[ix];
2546 SP = firstlelem - 1;
2550 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2555 *lelem = &PL_sv_undef;
2556 else if (!(*lelem = firstrelem[ix]))
2557 *lelem = &PL_sv_undef;
2561 if (ix >= max || !(*lelem = firstrelem[ix]))
2562 *lelem = &PL_sv_undef;
2564 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2565 is_something_there = TRUE;
2567 if (is_something_there)
2570 SP = firstlelem - 1;
2576 djSP; dMARK; dORIGMARK;
2577 I32 items = SP - MARK;
2578 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2579 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2586 djSP; dMARK; dORIGMARK;
2587 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2591 SV *val = NEWSV(46, 0);
2593 sv_setsv(val, *++MARK);
2595 warn("Odd number of elements in hash assignment");
2596 (void)hv_store_ent(hv,key,val,0);
2605 djSP; dMARK; dORIGMARK;
2606 register AV *ary = (AV*)*++MARK;
2610 register I32 offset;
2611 register I32 length;
2618 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2619 *MARK-- = SvTIED_obj((SV*)ary, mg);
2623 perl_call_method("SPLICE",GIMME_V);
2632 offset = i = SvIVx(*MARK);
2634 offset += AvFILLp(ary) + 1;
2636 offset -= PL_curcop->cop_arybase;
2640 length = SvIVx(*MARK++);
2642 length += AvFILLp(ary) - offset + 1;
2648 length = AvMAX(ary) + 1; /* close enough to infinity */
2652 length = AvMAX(ary) + 1;
2654 if (offset > AvFILLp(ary) + 1)
2655 offset = AvFILLp(ary) + 1;
2656 after = AvFILLp(ary) + 1 - (offset + length);
2657 if (after < 0) { /* not that much array */
2658 length += after; /* offset+length now in array */
2664 /* At this point, MARK .. SP-1 is our new LIST */
2667 diff = newlen - length;
2668 if (newlen && !AvREAL(ary)) {
2672 assert(AvREAL(ary)); /* would leak, so croak */
2675 if (diff < 0) { /* shrinking the area */
2677 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2678 Copy(MARK, tmparyval, newlen, SV*);
2681 MARK = ORIGMARK + 1;
2682 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2683 MEXTEND(MARK, length);
2684 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2686 EXTEND_MORTAL(length);
2687 for (i = length, dst = MARK; i; i--) {
2688 sv_2mortal(*dst); /* free them eventualy */
2695 *MARK = AvARRAY(ary)[offset+length-1];
2698 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2699 SvREFCNT_dec(*dst++); /* free them now */
2702 AvFILLp(ary) += diff;
2704 /* pull up or down? */
2706 if (offset < after) { /* easier to pull up */
2707 if (offset) { /* esp. if nothing to pull */
2708 src = &AvARRAY(ary)[offset-1];
2709 dst = src - diff; /* diff is negative */
2710 for (i = offset; i > 0; i--) /* can't trust Copy */
2714 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2718 if (after) { /* anything to pull down? */
2719 src = AvARRAY(ary) + offset + length;
2720 dst = src + diff; /* diff is negative */
2721 Move(src, dst, after, SV*);
2723 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2724 /* avoid later double free */
2728 dst[--i] = &PL_sv_undef;
2731 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2733 *dst = NEWSV(46, 0);
2734 sv_setsv(*dst++, *src++);
2736 Safefree(tmparyval);
2739 else { /* no, expanding (or same) */
2741 New(452, tmparyval, length, SV*); /* so remember deletion */
2742 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2745 if (diff > 0) { /* expanding */
2747 /* push up or down? */
2749 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2753 Move(src, dst, offset, SV*);
2755 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2757 AvFILLp(ary) += diff;
2760 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2761 av_extend(ary, AvFILLp(ary) + diff);
2762 AvFILLp(ary) += diff;
2765 dst = AvARRAY(ary) + AvFILLp(ary);
2767 for (i = after; i; i--) {
2774 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2775 *dst = NEWSV(46, 0);
2776 sv_setsv(*dst++, *src++);
2778 MARK = ORIGMARK + 1;
2779 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2781 Copy(tmparyval, MARK, length, SV*);
2783 EXTEND_MORTAL(length);
2784 for (i = length, dst = MARK; i; i--) {
2785 sv_2mortal(*dst); /* free them eventualy */
2789 Safefree(tmparyval);
2793 else if (length--) {
2794 *MARK = tmparyval[length];
2797 while (length-- > 0)
2798 SvREFCNT_dec(tmparyval[length]);
2800 Safefree(tmparyval);
2803 *MARK = &PL_sv_undef;
2811 djSP; dMARK; dORIGMARK; dTARGET;
2812 register AV *ary = (AV*)*++MARK;
2813 register SV *sv = &PL_sv_undef;
2816 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2817 *MARK-- = SvTIED_obj((SV*)ary, mg);
2821 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2826 /* Why no pre-extend of ary here ? */
2827 for (++MARK; MARK <= SP; MARK++) {
2830 sv_setsv(sv, *MARK);
2835 PUSHi( AvFILL(ary) + 1 );
2843 SV *sv = av_pop(av);
2845 (void)sv_2mortal(sv);
2854 SV *sv = av_shift(av);
2859 (void)sv_2mortal(sv);
2866 djSP; dMARK; dORIGMARK; dTARGET;
2867 register AV *ary = (AV*)*++MARK;
2872 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2873 *MARK-- = SvTIED_obj((SV*)ary, mg);
2877 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2882 av_unshift(ary, SP - MARK);
2885 sv_setsv(sv, *++MARK);
2886 (void)av_store(ary, i++, sv);
2890 PUSHi( AvFILL(ary) + 1 );
2900 if (GIMME == G_ARRAY) {
2911 register char *down;
2917 do_join(TARG, &PL_sv_no, MARK, SP);
2919 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
2920 up = SvPV_force(TARG, len);
2922 down = SvPVX(TARG) + len - 1;
2928 (void)SvPOK_only(TARG);
2937 mul128(SV *sv, U8 m)
2940 char *s = SvPV(sv, len);
2944 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
2945 SV *tmpNew = newSVpv("0000000000", 10);
2947 sv_catsv(tmpNew, sv);
2948 SvREFCNT_dec(sv); /* free old sv */
2953 while (!*t) /* trailing '\0'? */
2956 i = ((*t - '0') << 7) + m;
2957 *(t--) = '0' + (i % 10);
2963 /* Explosives and implosives. */
2965 static const char uuemap[] =
2966 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
2968 static char uudmap[256]; /* Initialised on first use */
2970 #if 'I' == 73 && 'J' == 74
2971 /* On an ASCII/ISO kind of system */
2972 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
2975 Some other sort of character set - use memchr() so we don't match
2978 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
2986 I32 gimme = GIMME_V;
2990 register char *pat = SvPV(left, llen);
2991 register char *s = SvPV(right, rlen);
2992 char *strend = s + rlen;
2994 register char *patend = pat + llen;
2999 /* These must not be in registers: */
3010 unsigned Quad_t auquad;
3016 register U32 culong;
3019 static char* bitcount = 0;
3023 if (gimme != G_ARRAY) { /* arrange to do first one only */
3025 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3026 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3028 while (isDIGIT(*patend) || *patend == '*')
3034 while (pat < patend) {
3036 datumtype = *pat++ & 0xFF;
3037 if (isSPACE(datumtype))
3041 else if (*pat == '*') {
3042 len = strend - strbeg; /* long enough */
3045 else if (isDIGIT(*pat)) {
3047 while (isDIGIT(*pat))
3048 len = (len * 10) + (*pat++ - '0');
3051 len = (datumtype != '@');
3054 croak("Invalid type in unpack: '%c'", (int)datumtype);
3055 case ',': /* grandfather in commas but with a warning */
3056 if (commas++ == 0 && PL_dowarn)
3057 warn("Invalid type in unpack: '%c'", (int)datumtype);
3060 if (len == 1 && pat[-1] != '1')
3069 if (len > strend - strbeg)
3070 DIE("@ outside of string");
3074 if (len > s - strbeg)
3075 DIE("X outside of string");
3079 if (len > strend - s)
3080 DIE("x outside of string");
3086 if (len > strend - s)
3089 goto uchar_checksum;
3090 sv = NEWSV(35, len);
3091 sv_setpvn(sv, s, len);
3093 if (datumtype == 'A' || datumtype == 'Z') {
3094 aptr = s; /* borrow register */
3095 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3100 else { /* 'A' strips both nulls and spaces */
3101 s = SvPVX(sv) + len - 1;
3102 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3106 SvCUR_set(sv, s - SvPVX(sv));
3107 s = aptr; /* unborrow register */
3109 XPUSHs(sv_2mortal(sv));
3113 if (pat[-1] == '*' || len > (strend - s) * 8)
3114 len = (strend - s) * 8;
3117 Newz(601, bitcount, 256, char);
3118 for (bits = 1; bits < 256; bits++) {
3119 if (bits & 1) bitcount[bits]++;
3120 if (bits & 2) bitcount[bits]++;
3121 if (bits & 4) bitcount[bits]++;
3122 if (bits & 8) bitcount[bits]++;
3123 if (bits & 16) bitcount[bits]++;
3124 if (bits & 32) bitcount[bits]++;
3125 if (bits & 64) bitcount[bits]++;
3126 if (bits & 128) bitcount[bits]++;
3130 culong += bitcount[*(unsigned char*)s++];
3135 if (datumtype == 'b') {
3137 if (bits & 1) culong++;
3143 if (bits & 128) culong++;
3150 sv = NEWSV(35, len + 1);
3153 aptr = pat; /* borrow register */
3155 if (datumtype == 'b') {
3157 for (len = 0; len < aint; len++) {
3158 if (len & 7) /*SUPPRESS 595*/
3162 *pat++ = '0' + (bits & 1);
3167 for (len = 0; len < aint; len++) {
3172 *pat++ = '0' + ((bits & 128) != 0);
3176 pat = aptr; /* unborrow register */
3177 XPUSHs(sv_2mortal(sv));
3181 if (pat[-1] == '*' || len > (strend - s) * 2)
3182 len = (strend - s) * 2;
3183 sv = NEWSV(35, len + 1);
3186 aptr = pat; /* borrow register */
3188 if (datumtype == 'h') {
3190 for (len = 0; len < aint; len++) {
3195 *pat++ = PL_hexdigit[bits & 15];
3200 for (len = 0; len < aint; len++) {
3205 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3209 pat = aptr; /* unborrow register */
3210 XPUSHs(sv_2mortal(sv));
3213 if (len > strend - s)
3218 if (aint >= 128) /* fake up signed chars */
3228 if (aint >= 128) /* fake up signed chars */
3231 sv_setiv(sv, (IV)aint);
3232 PUSHs(sv_2mortal(sv));
3237 if (len > strend - s)
3252 sv_setiv(sv, (IV)auint);
3253 PUSHs(sv_2mortal(sv));
3258 along = (strend - s) / SIZE16;
3264 #if SHORTSIZE > SIZE16
3277 #if SHORTSIZE > SIZE16
3283 sv_setiv(sv, (IV)ashort);
3284 PUSHs(sv_2mortal(sv));
3291 along = (strend - s) / SIZE16;
3296 COPY16(s, &aushort);
3299 if (datumtype == 'n')
3300 aushort = PerlSock_ntohs(aushort);
3303 if (datumtype == 'v')
3304 aushort = vtohs(aushort);
3313 COPY16(s, &aushort);
3317 if (datumtype == 'n')
3318 aushort = PerlSock_ntohs(aushort);
3321 if (datumtype == 'v')
3322 aushort = vtohs(aushort);
3324 sv_setiv(sv, (IV)aushort);
3325 PUSHs(sv_2mortal(sv));
3330 along = (strend - s) / sizeof(int);
3335 Copy(s, &aint, 1, int);
3338 cdouble += (double)aint;
3347 Copy(s, &aint, 1, int);
3351 /* Without the dummy below unpack("i", pack("i",-1))
3352 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3353 * cc with optimization turned on */
3355 sv_setiv(sv, (IV)aint) :
3357 sv_setiv(sv, (IV)aint);
3358 PUSHs(sv_2mortal(sv));
3363 along = (strend - s) / sizeof(unsigned int);
3368 Copy(s, &auint, 1, unsigned int);
3369 s += sizeof(unsigned int);
3371 cdouble += (double)auint;
3380 Copy(s, &auint, 1, unsigned int);
3381 s += sizeof(unsigned int);
3384 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3385 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3386 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3387 * with optimization turned on.
3388 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3389 * does not have this problem even with -O4)
3392 sv_setuv(sv, (UV)auint) :
3394 sv_setuv(sv, (UV)auint);
3395 PUSHs(sv_2mortal(sv));
3400 along = (strend - s) / SIZE32;
3406 #if LONGSIZE > SIZE32
3407 if (along > 2147483647)
3408 along -= 4294967296;
3412 cdouble += (double)along;
3422 #if LONGSIZE > SIZE32
3423 if (along > 2147483647)
3424 along -= 4294967296;
3428 sv_setiv(sv, (IV)along);
3429 PUSHs(sv_2mortal(sv));
3436 along = (strend - s) / SIZE32;
3444 if (datumtype == 'N')
3445 aulong = PerlSock_ntohl(aulong);
3448 if (datumtype == 'V')
3449 aulong = vtohl(aulong);
3452 cdouble += (double)aulong;
3464 if (datumtype == 'N')
3465 aulong = PerlSock_ntohl(aulong);
3468 if (datumtype == 'V')
3469 aulong = vtohl(aulong);
3472 sv_setuv(sv, (UV)aulong);
3473 PUSHs(sv_2mortal(sv));
3478 along = (strend - s) / sizeof(char*);
3484 if (sizeof(char*) > strend - s)
3487 Copy(s, &aptr, 1, char*);
3493 PUSHs(sv_2mortal(sv));
3503 while ((len > 0) && (s < strend)) {
3504 auv = (auv << 7) | (*s & 0x7f);
3505 if (!(*s++ & 0x80)) {
3509 PUSHs(sv_2mortal(sv));
3513 else if (++bytes >= sizeof(UV)) { /* promote to string */
3517 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3518 while (s < strend) {
3519 sv = mul128(sv, *s & 0x7f);
3520 if (!(*s++ & 0x80)) {
3529 PUSHs(sv_2mortal(sv));
3534 if ((s >= strend) && bytes)
3535 croak("Unterminated compressed integer");
3540 if (sizeof(char*) > strend - s)
3543 Copy(s, &aptr, 1, char*);
3548 sv_setpvn(sv, aptr, len);
3549 PUSHs(sv_2mortal(sv));
3553 along = (strend - s) / sizeof(Quad_t);
3559 if (s + sizeof(Quad_t) > strend)
3562 Copy(s, &aquad, 1, Quad_t);
3563 s += sizeof(Quad_t);
3566 if (aquad >= IV_MIN && aquad <= IV_MAX)
3567 sv_setiv(sv, (IV)aquad);
3569 sv_setnv(sv, (double)aquad);
3570 PUSHs(sv_2mortal(sv));
3574 along = (strend - s) / sizeof(Quad_t);
3580 if (s + sizeof(unsigned Quad_t) > strend)
3583 Copy(s, &auquad, 1, unsigned Quad_t);
3584 s += sizeof(unsigned Quad_t);
3587 if (auquad <= UV_MAX)
3588 sv_setuv(sv, (UV)auquad);
3590 sv_setnv(sv, (double)auquad);
3591 PUSHs(sv_2mortal(sv));
3595 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3598 along = (strend - s) / sizeof(float);
3603 Copy(s, &afloat, 1, float);
3612 Copy(s, &afloat, 1, float);
3615 sv_setnv(sv, (double)afloat);
3616 PUSHs(sv_2mortal(sv));
3622 along = (strend - s) / sizeof(double);
3627 Copy(s, &adouble, 1, double);
3628 s += sizeof(double);
3636 Copy(s, &adouble, 1, double);
3637 s += sizeof(double);
3639 sv_setnv(sv, (double)adouble);
3640 PUSHs(sv_2mortal(sv));
3646 * Initialise the decode mapping. By using a table driven
3647 * algorithm, the code will be character-set independent
3648 * (and just as fast as doing character arithmetic)
3650 if (uudmap['M'] == 0) {
3653 for (i = 0; i < sizeof(uuemap); i += 1)
3654 uudmap[uuemap[i]] = i;
3656 * Because ' ' and '`' map to the same value,
3657 * we need to decode them both the same.
3662 along = (strend - s) * 3 / 4;
3663 sv = NEWSV(42, along);
3666 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3671 len = uudmap[*s++] & 077;
3673 if (s < strend && ISUUCHAR(*s))
3674 a = uudmap[*s++] & 077;
3677 if (s < strend && ISUUCHAR(*s))
3678 b = uudmap[*s++] & 077;
3681 if (s < strend && ISUUCHAR(*s))
3682 c = uudmap[*s++] & 077;
3685 if (s < strend && ISUUCHAR(*s))
3686 d = uudmap[*s++] & 077;
3689 hunk[0] = (a << 2) | (b >> 4);
3690 hunk[1] = (b << 4) | (c >> 2);
3691 hunk[2] = (c << 6) | d;
3692 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3697 else if (s[1] == '\n') /* possible checksum byte */
3700 XPUSHs(sv_2mortal(sv));
3705 if (strchr("fFdD", datumtype) ||
3706 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3710 while (checksum >= 16) {
3714 while (checksum >= 4) {
3720 along = (1 << checksum) - 1;
3721 while (cdouble < 0.0)
3723 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3724 sv_setnv(sv, cdouble);
3727 if (checksum < 32) {
3728 aulong = (1 << checksum) - 1;
3731 sv_setuv(sv, (UV)culong);
3733 XPUSHs(sv_2mortal(sv));
3737 if (SP == oldsp && gimme == G_SCALAR)
3738 PUSHs(&PL_sv_undef);
3743 doencodes(register SV *sv, register char *s, register I32 len)
3747 *hunk = uuemap[len];
3748 sv_catpvn(sv, hunk, 1);
3751 hunk[0] = uuemap[(077 & (*s >> 2))];
3752 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3753 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3754 hunk[3] = uuemap[(077 & (s[2] & 077))];
3755 sv_catpvn(sv, hunk, 4);
3760 char r = (len > 1 ? s[1] : '\0');
3761 hunk[0] = uuemap[(077 & (*s >> 2))];
3762 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3763 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3764 hunk[3] = uuemap[0];
3765 sv_catpvn(sv, hunk, 4);
3767 sv_catpvn(sv, "\n", 1);
3771 is_an_int(char *s, STRLEN l)
3774 SV *result = newSVpv("", l);
3775 char *result_c = SvPV(result, n_a); /* convenience */
3776 char *out = result_c;
3786 SvREFCNT_dec(result);
3809 SvREFCNT_dec(result);
3815 SvCUR_set(result, out - result_c);
3820 div128(SV *pnum, bool *done)
3821 /* must be '\0' terminated */
3825 char *s = SvPV(pnum, len);
3834 i = m * 10 + (*t - '0');
3836 r = (i >> 7); /* r < 10 */
3843 SvCUR_set(pnum, (STRLEN) (t - s));
3850 djSP; dMARK; dORIGMARK; dTARGET;
3851 register SV *cat = TARG;
3854 register char *pat = SvPVx(*++MARK, fromlen);
3855 register char *patend = pat + fromlen;
3860 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3861 static char *space10 = " ";
3863 /* These must not be in registers: */
3872 unsigned Quad_t auquad;
3881 sv_setpvn(cat, "", 0);
3882 while (pat < patend) {
3883 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
3884 datumtype = *pat++ & 0xFF;
3885 if (isSPACE(datumtype))
3888 len = strchr("@Xxu", datumtype) ? 0 : items;
3891 else if (isDIGIT(*pat)) {
3893 while (isDIGIT(*pat))
3894 len = (len * 10) + (*pat++ - '0');
3900 croak("Invalid type in pack: '%c'", (int)datumtype);
3901 case ',': /* grandfather in commas but with a warning */
3902 if (commas++ == 0 && PL_dowarn)
3903 warn("Invalid type in pack: '%c'", (int)datumtype);
3906 DIE("%% may only be used in unpack");
3917 if (SvCUR(cat) < len)
3918 DIE("X outside of string");
3925 sv_catpvn(cat, null10, 10);
3928 sv_catpvn(cat, null10, len);
3934 aptr = SvPV(fromstr, fromlen);
3938 sv_catpvn(cat, aptr, len);
3940 sv_catpvn(cat, aptr, fromlen);
3942 if (datumtype == 'A') {
3944 sv_catpvn(cat, space10, 10);
3947 sv_catpvn(cat, space10, len);
3951 sv_catpvn(cat, null10, 10);
3954 sv_catpvn(cat, null10, len);
3961 char *savepat = pat;
3966 aptr = SvPV(fromstr, fromlen);
3971 SvCUR(cat) += (len+7)/8;
3972 SvGROW(cat, SvCUR(cat) + 1);
3973 aptr = SvPVX(cat) + aint;
3978 if (datumtype == 'B') {
3979 for (len = 0; len++ < aint;) {
3980 items |= *pat++ & 1;
3984 *aptr++ = items & 0xff;
3990 for (len = 0; len++ < aint;) {
3996 *aptr++ = items & 0xff;
4002 if (datumtype == 'B')
4003 items <<= 7 - (aint & 7);
4005 items >>= 7 - (aint & 7);
4006 *aptr++ = items & 0xff;
4008 pat = SvPVX(cat) + SvCUR(cat);
4019 char *savepat = pat;
4024 aptr = SvPV(fromstr, fromlen);
4029 SvCUR(cat) += (len+1)/2;
4030 SvGROW(cat, SvCUR(cat) + 1);
4031 aptr = SvPVX(cat) + aint;
4036 if (datumtype == 'H') {
4037 for (len = 0; len++ < aint;) {
4039 items |= ((*pat++ & 15) + 9) & 15;
4041 items |= *pat++ & 15;
4045 *aptr++ = items & 0xff;
4051 for (len = 0; len++ < aint;) {
4053 items |= (((*pat++ & 15) + 9) & 15) << 4;
4055 items |= (*pat++ & 15) << 4;
4059 *aptr++ = items & 0xff;
4065 *aptr++ = items & 0xff;
4066 pat = SvPVX(cat) + SvCUR(cat);
4078 aint = SvIV(fromstr);
4080 sv_catpvn(cat, &achar, sizeof(char));
4083 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4088 afloat = (float)SvNV(fromstr);
4089 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4096 adouble = (double)SvNV(fromstr);
4097 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4103 ashort = (I16)SvIV(fromstr);
4105 ashort = PerlSock_htons(ashort);
4107 CAT16(cat, &ashort);
4113 ashort = (I16)SvIV(fromstr);
4115 ashort = htovs(ashort);
4117 CAT16(cat, &ashort);
4124 ashort = (I16)SvIV(fromstr);
4125 CAT16(cat, &ashort);
4131 auint = SvUV(fromstr);
4132 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4138 adouble = floor(SvNV(fromstr));
4141 croak("Cannot compress negative numbers");
4147 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4148 adouble <= UV_MAX_cxux
4155 char buf[1 + sizeof(UV)];
4156 char *in = buf + sizeof(buf);
4157 UV auv = U_V(adouble);;
4160 *--in = (auv & 0x7f) | 0x80;
4163 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4164 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4166 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4167 char *from, *result, *in;
4172 /* Copy string and check for compliance */
4173 from = SvPV(fromstr, len);
4174 if ((norm = is_an_int(from, len)) == NULL)
4175 croak("can compress only unsigned integer");
4177 New('w', result, len, char);
4181 *--in = div128(norm, &done) | 0x80;
4182 result[len - 1] &= 0x7F; /* clear continue bit */
4183 sv_catpvn(cat, in, (result + len) - in);
4185 SvREFCNT_dec(norm); /* free norm */
4187 else if (SvNOKp(fromstr)) {
4188 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4189 char *in = buf + sizeof(buf);
4192 double next = floor(adouble / 128);
4193 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4194 if (--in < buf) /* this cannot happen ;-) */
4195 croak ("Cannot compress integer");
4197 } while (adouble > 0);
4198 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4199 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4202 croak("Cannot compress non integer");
4208 aint = SvIV(fromstr);
4209 sv_catpvn(cat, (char*)&aint, sizeof(int));
4215 aulong = SvUV(fromstr);
4217 aulong = PerlSock_htonl(aulong);
4219 CAT32(cat, &aulong);
4225 aulong = SvUV(fromstr);
4227 aulong = htovl(aulong);
4229 CAT32(cat, &aulong);
4235 aulong = SvUV(fromstr);
4236 CAT32(cat, &aulong);
4242 along = SvIV(fromstr);
4250 auquad = (unsigned Quad_t)SvIV(fromstr);
4251 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4257 aquad = (Quad_t)SvIV(fromstr);
4258 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4261 #endif /* HAS_QUAD */
4263 len = 1; /* assume SV is correct length */
4268 if (fromstr == &PL_sv_undef)
4272 /* XXX better yet, could spirit away the string to
4273 * a safe spot and hang on to it until the result
4274 * of pack() (and all copies of the result) are
4277 if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4278 warn("Attempt to pack pointer to temporary value");
4279 if (SvPOK(fromstr) || SvNIOK(fromstr))
4280 aptr = SvPV(fromstr,n_a);
4282 aptr = SvPV_force(fromstr,n_a);
4284 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4289 aptr = SvPV(fromstr, fromlen);
4290 SvGROW(cat, fromlen * 4 / 3);
4295 while (fromlen > 0) {
4302 doencodes(cat, aptr, todo);
4321 register I32 limit = POPi; /* note, negative is forever */
4324 register char *s = SvPV(sv, len);
4325 char *strend = s + len;
4327 register REGEXP *rx;
4331 I32 maxiters = (strend - s) + 10;
4334 I32 origlimit = limit;
4337 AV *oldstack = PL_curstack;
4338 I32 gimme = GIMME_V;
4339 I32 oldsave = PL_savestack_ix;
4340 I32 make_mortal = 1;
4341 MAGIC *mg = (MAGIC *) NULL;
4344 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4349 DIE("panic: do_split");
4350 rx = pm->op_pmregexp;
4352 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4353 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4355 if (pm->op_pmreplroot)
4356 ary = GvAVn((GV*)pm->op_pmreplroot);
4357 else if (gimme != G_ARRAY)
4359 ary = (AV*)PL_curpad[0];
4361 ary = GvAVn(PL_defgv);
4362 #endif /* USE_THREADS */
4365 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4371 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4373 XPUSHs(SvTIED_obj((SV*)ary, mg));
4378 for (i = AvFILLp(ary); i >= 0; i--)
4379 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4381 /* temporarily switch stacks */
4382 SWITCHSTACK(PL_curstack, ary);
4386 base = SP - PL_stack_base;
4388 if (pm->op_pmflags & PMf_SKIPWHITE) {
4389 if (pm->op_pmflags & PMf_LOCALE) {
4390 while (isSPACE_LC(*s))
4398 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4399 SAVEINT(PL_multiline);
4400 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4404 limit = maxiters + 2;
4405 if (pm->op_pmflags & PMf_WHITE) {
4408 while (m < strend &&
4409 !((pm->op_pmflags & PMf_LOCALE)
4410 ? isSPACE_LC(*m) : isSPACE(*m)))
4415 dstr = NEWSV(30, m-s);
4416 sv_setpvn(dstr, s, m-s);
4422 while (s < strend &&
4423 ((pm->op_pmflags & PMf_LOCALE)
4424 ? isSPACE_LC(*s) : isSPACE(*s)))
4428 else if (strEQ("^", rx->precomp)) {
4431 for (m = s; m < strend && *m != '\n'; m++) ;
4435 dstr = NEWSV(30, m-s);
4436 sv_setpvn(dstr, s, m-s);
4443 else if (rx->check_substr && !rx->nparens
4444 && (rx->reganch & ROPT_CHECK_ALL)
4445 && !(rx->reganch & ROPT_ANCH)) {
4446 i = SvCUR(rx->check_substr);
4447 if (i == 1 && !SvTAIL(rx->check_substr)) {
4448 i = *SvPVX(rx->check_substr);
4451 for (m = s; m < strend && *m != i; m++) ;
4454 dstr = NEWSV(30, m-s);
4455 sv_setpvn(dstr, s, m-s);
4464 while (s < strend && --limit &&
4465 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4466 rx->check_substr, 0)) )
4469 dstr = NEWSV(31, m-s);
4470 sv_setpvn(dstr, s, m-s);
4479 maxiters += (strend - s) * rx->nparens;
4480 while (s < strend && --limit &&
4481 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4483 TAINT_IF(RX_MATCH_TAINTED(rx));
4485 && rx->subbase != orig) {
4490 strend = s + (strend - m);
4493 dstr = NEWSV(32, m-s);
4494 sv_setpvn(dstr, s, m-s);
4499 for (i = 1; i <= rx->nparens; i++) {
4503 dstr = NEWSV(33, m-s);
4504 sv_setpvn(dstr, s, m-s);
4507 dstr = NEWSV(33, 0);
4517 LEAVE_SCOPE(oldsave);
4518 iters = (SP - PL_stack_base) - base;
4519 if (iters > maxiters)
4522 /* keep field after final delim? */
4523 if (s < strend || (iters && origlimit)) {
4524 dstr = NEWSV(34, strend-s);
4525 sv_setpvn(dstr, s, strend-s);
4531 else if (!origlimit) {
4532 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4538 SWITCHSTACK(ary, oldstack);
4539 if (SvSMAGICAL(ary)) {
4544 if (gimme == G_ARRAY) {
4546 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4554 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4557 if (gimme == G_ARRAY) {
4558 /* EXTEND should not be needed - we just popped them */
4560 for (i=0; i < iters; i++) {
4561 SV **svp = av_fetch(ary, i, FALSE);
4562 PUSHs((svp) ? *svp : &PL_sv_undef);
4569 if (gimme == G_ARRAY)
4572 if (iters || !pm->op_pmreplroot) {
4582 unlock_condpair(void *svv)
4585 MAGIC *mg = mg_find((SV*)svv, 'm');
4588 croak("panic: unlock_condpair unlocking non-mutex");
4589 MUTEX_LOCK(MgMUTEXP(mg));
4590 if (MgOWNER(mg) != thr)
4591 croak("panic: unlock_condpair unlocking mutex that we don't own");
4593 COND_SIGNAL(MgOWNERCONDP(mg));
4594 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4595 (unsigned long)thr, (unsigned long)svv);)
4596 MUTEX_UNLOCK(MgMUTEXP(mg));
4598 #endif /* USE_THREADS */
4611 mg = condpair_magic(sv);
4612 MUTEX_LOCK(MgMUTEXP(mg));
4613 if (MgOWNER(mg) == thr)
4614 MUTEX_UNLOCK(MgMUTEXP(mg));
4617 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4619 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4620 (unsigned long)thr, (unsigned long)sv);)
4621 MUTEX_UNLOCK(MgMUTEXP(mg));
4622 save_destructor(unlock_condpair, sv);
4624 #endif /* USE_THREADS */
4625 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4626 || SvTYPE(retsv) == SVt_PVCV) {
4627 retsv = refto(retsv);
4638 if (PL_op->op_private & OPpLVAL_INTRO)
4639 PUSHs(*save_threadsv(PL_op->op_targ));
4641 PUSHs(THREADSV(PL_op->op_targ));
4644 DIE("tried to access per-thread data in non-threaded perl");
4645 #endif /* USE_THREADS */