3 * Copyright (c) 1991-1997, 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 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
82 # if BYTEORDER == 0x12345678
83 # define OFF16(p) (char*)(p)
84 # define OFF32(p) (char*)(p)
86 # if BYTEORDER == 0x87654321
87 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
88 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
90 }}}} bad cray byte order
93 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
94 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
95 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
96 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
98 # define COPY16(s,p) Copy(s, p, SIZE16, char)
99 # define COPY32(s,p) Copy(s, p, SIZE32, char)
100 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
101 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
105 static void doencodes _((SV* sv, char* s, I32 len));
106 static SV* refto _((SV* sv));
107 static U32 seed _((void));
110 static bool srand_called = FALSE;
112 /* variations on pp_null */
118 /* XXX I can't imagine anyone who doesn't have this actually _needs_
119 it, since pid_t is an integral type.
122 #ifdef NEED_GETPID_PROTO
123 extern Pid_t getpid (void);
129 if (GIMME_V == G_SCALAR)
130 XPUSHs(&PL_sv_undef);
144 if (PL_op->op_private & OPpLVAL_INTRO)
145 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
147 if (PL_op->op_flags & OPf_REF) {
151 if (GIMME == G_ARRAY) {
152 I32 maxarg = AvFILL((AV*)TARG) + 1;
154 if (SvMAGICAL(TARG)) {
156 for (i=0; i < maxarg; i++) {
157 SV **svp = av_fetch((AV*)TARG, i, FALSE);
158 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
162 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
167 SV* sv = sv_newmortal();
168 I32 maxarg = AvFILL((AV*)TARG) + 1;
169 sv_setiv(sv, maxarg);
181 if (PL_op->op_private & OPpLVAL_INTRO)
182 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
183 if (PL_op->op_flags & OPf_REF)
186 if (gimme == G_ARRAY) {
187 RETURNOP(do_kv(ARGS));
189 else if (gimme == G_SCALAR) {
190 SV* sv = sv_newmortal();
191 if (HvFILL((HV*)TARG))
192 sv_setpvf(sv, "%ld/%ld",
193 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
203 DIE("NOT IMPL LINE %d",__LINE__);
215 if (SvTYPE(sv) == SVt_PVIO) {
216 GV *gv = (GV*) sv_newmortal();
217 gv_init(gv, 0, "", 0, 0);
218 GvIOp(gv) = (IO *)sv;
219 (void)SvREFCNT_inc(sv);
221 } else if (SvTYPE(sv) != SVt_PVGV)
222 DIE("Not a GLOB reference");
225 if (SvTYPE(sv) != SVt_PVGV) {
228 if (SvGMAGICAL(sv)) {
234 if (PL_op->op_flags & OPf_REF ||
235 PL_op->op_private & HINT_STRICT_REFS)
236 DIE(no_usym, "a symbol");
241 sym = SvPV(sv, PL_na);
242 if (PL_op->op_private & HINT_STRICT_REFS)
243 DIE(no_symref, sym, "a symbol");
244 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
247 if (PL_op->op_private & OPpLVAL_INTRO)
248 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
260 switch (SvTYPE(sv)) {
264 DIE("Not a SCALAR reference");
271 if (SvTYPE(gv) != SVt_PVGV) {
272 if (SvGMAGICAL(sv)) {
278 if (PL_op->op_flags & OPf_REF ||
279 PL_op->op_private & HINT_STRICT_REFS)
280 DIE(no_usym, "a SCALAR");
285 sym = SvPV(sv, PL_na);
286 if (PL_op->op_private & HINT_STRICT_REFS)
287 DIE(no_symref, sym, "a SCALAR");
288 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
292 if (PL_op->op_flags & OPf_MOD) {
293 if (PL_op->op_private & OPpLVAL_INTRO)
294 sv = save_scalar((GV*)TOPs);
295 else if (PL_op->op_private & OPpDEREF)
296 vivify_ref(sv, PL_op->op_private & OPpDEREF);
306 SV *sv = AvARYLEN(av);
308 AvARYLEN(av) = sv = NEWSV(0,0);
309 sv_upgrade(sv, SVt_IV);
310 sv_magic(sv, (SV*)av, '#', Nullch, 0);
318 djSP; dTARGET; dPOPss;
320 if (PL_op->op_flags & OPf_MOD) {
321 if (SvTYPE(TARG) < SVt_PVLV) {
322 sv_upgrade(TARG, SVt_PVLV);
323 sv_magic(TARG, Nullsv, '.', Nullch, 0);
327 if (LvTARG(TARG) != sv) {
329 SvREFCNT_dec(LvTARG(TARG));
330 LvTARG(TARG) = SvREFCNT_inc(sv);
332 PUSHs(TARG); /* no SvSETMAGIC */
338 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
339 mg = mg_find(sv, 'g');
340 if (mg && mg->mg_len >= 0) {
341 PUSHi(mg->mg_len + PL_curcop->cop_arybase);
355 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
356 /* (But not in defined().) */
357 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
360 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
363 cv = (CV*)&PL_sv_undef;
377 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
378 char *s = SvPVX(TOPs);
379 if (strnEQ(s, "CORE::", 6)) {
382 code = keyword(s + 6, SvCUR(TOPs) - 6);
383 if (code < 0) { /* Overridable. */
384 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
385 int i = 0, n = 0, seen_question = 0;
387 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
389 while (i < MAXO) { /* The slow way. */
390 if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
394 goto nonesuch; /* Should not happen... */
396 oa = opargs[i] >> OASHIFT;
398 if (oa & OA_OPTIONAL) {
401 } else if (seen_question)
402 goto set; /* XXXX system, exec */
403 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
404 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
407 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
408 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
412 ret = sv_2mortal(newSVpv(str, n - 1));
413 } else if (code) /* Non-Overridable */
415 else { /* None such */
417 croak("Cannot find an opnumber for \"%s\"", s+6);
421 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
423 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
432 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
434 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
450 if (GIMME != G_ARRAY) {
454 *MARK = &PL_sv_undef;
455 *MARK = refto(*MARK);
459 EXTEND_MORTAL(SP - MARK);
461 *MARK = refto(*MARK);
470 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
473 if (!(sv = LvTARG(sv)))
476 else if (SvPADTMP(sv))
480 (void)SvREFCNT_inc(sv);
483 sv_upgrade(rv, SVt_RV);
497 if (sv && SvGMAGICAL(sv))
500 if (!sv || !SvROK(sv))
504 pv = sv_reftype(sv,TRUE);
505 PUSHp(pv, strlen(pv));
515 stash = PL_curcop->cop_stash;
519 char *ptr = SvPV(ssv,len);
520 if (PL_dowarn && len == 0)
521 warn("Explicit blessing to '' (assuming package main)");
522 stash = gv_stashpvn(ptr, len, TRUE);
525 (void)sv_bless(TOPs, stash);
538 elem = SvPV(sv, PL_na);
542 switch (elem ? *elem : '\0')
545 if (strEQ(elem, "ARRAY"))
546 tmpRef = (SV*)GvAV(gv);
549 if (strEQ(elem, "CODE"))
550 tmpRef = (SV*)GvCVu(gv);
553 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
554 tmpRef = (SV*)GvIOp(gv);
557 if (strEQ(elem, "GLOB"))
561 if (strEQ(elem, "HASH"))
562 tmpRef = (SV*)GvHV(gv);
565 if (strEQ(elem, "IO"))
566 tmpRef = (SV*)GvIOp(gv);
569 if (strEQ(elem, "NAME"))
570 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
573 if (strEQ(elem, "PACKAGE"))
574 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
577 if (strEQ(elem, "SCALAR"))
591 /* Pattern matching */
596 register UNOP *unop = cUNOP;
597 register unsigned char *s;
600 register I32 *sfirst;
604 if (sv == PL_lastscream) {
610 SvSCREAM_off(PL_lastscream);
611 SvREFCNT_dec(PL_lastscream);
613 PL_lastscream = SvREFCNT_inc(sv);
616 s = (unsigned char*)(SvPV(sv, len));
620 if (pos > PL_maxscream) {
621 if (PL_maxscream < 0) {
622 PL_maxscream = pos + 80;
623 New(301, PL_screamfirst, 256, I32);
624 New(302, PL_screamnext, PL_maxscream, I32);
627 PL_maxscream = pos + pos / 4;
628 Renew(PL_screamnext, PL_maxscream, I32);
632 sfirst = PL_screamfirst;
633 snext = PL_screamnext;
635 if (!sfirst || !snext)
636 DIE("do_study: out of memory");
638 for (ch = 256; ch; --ch)
645 snext[pos] = sfirst[ch] - pos;
652 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
661 if (PL_op->op_flags & OPf_STACKED)
667 TARG = sv_newmortal();
668 PUSHi(do_trans(sv, PL_op));
672 /* Lvalue operators. */
684 djSP; dMARK; dTARGET;
694 SETi(do_chomp(TOPs));
700 djSP; dMARK; dTARGET;
701 register I32 count = 0;
704 count += do_chomp(POPs);
715 if (!sv || !SvANY(sv))
717 switch (SvTYPE(sv)) {
719 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
723 if (HvARRAY(sv) || SvGMAGICAL(sv))
727 if (CvROOT(sv) || CvXSUB(sv))
744 if (!PL_op->op_private) {
753 if (SvTHINKFIRST(sv)) {
760 switch (SvTYPE(sv)) {
770 if (PL_dowarn && cv_const_sv((CV*)sv))
771 warn("Constant subroutine %s undefined",
772 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
775 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
777 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
781 SvSetMagicSV(sv, &PL_sv_undef);
785 Newz(602, gp, 1, GP);
786 GvGP(sv) = gp_ref(gp);
787 GvSV(sv) = NEWSV(72,0);
788 GvLINE(sv) = PL_curcop->cop_line;
794 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
797 SvPV_set(sv, Nullch);
810 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
812 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
813 SvIVX(TOPs) != IV_MIN)
816 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
827 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
829 sv_setsv(TARG, TOPs);
830 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
831 SvIVX(TOPs) != IV_MAX)
834 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
848 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
850 sv_setsv(TARG, TOPs);
851 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
852 SvIVX(TOPs) != IV_MIN)
855 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
864 /* Ordinary operators. */
868 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
871 SETn( pow( left, right) );
878 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
881 SETn( left * right );
888 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
893 DIE("Illegal division by zero");
895 /* insure that 20./5. == 4. */
898 if ((double)I_V(left) == left &&
899 (double)I_V(right) == right &&
900 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
903 value = left / right;
907 value = left / right;
916 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
924 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
926 right = (right_neg = (i < 0)) ? -i : i;
930 right = U_V((right_neg = (n < 0)) ? -n : n);
933 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
935 left = (left_neg = (i < 0)) ? -i : i;
939 left = U_V((left_neg = (n < 0)) ? -n : n);
943 DIE("Illegal modulus zero");
946 if ((left_neg != right_neg) && ans)
949 /* XXX may warn: unary minus operator applied to unsigned type */
950 /* could change -foo to be (~foo)+1 instead */
951 if (ans <= ~((UV)IV_MAX)+1)
952 sv_setiv(TARG, ~ans+1);
954 sv_setnv(TARG, -(double)ans);
965 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
967 register I32 count = POPi;
968 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
970 I32 items = SP - MARK;
982 repeatcpy((char*)(MARK + items), (char*)MARK,
983 items * sizeof(SV*), count - 1);
989 else { /* Note: mark already snarfed by pp_list */
994 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
995 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
996 DIE("Can't x= to readonly value");
1000 SvSetSV(TARG, tmpstr);
1001 SvPV_force(TARG, len);
1006 SvGROW(TARG, (count * len) + 1);
1007 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1008 SvCUR(TARG) *= count;
1010 *SvEND(TARG) = '\0';
1012 (void)SvPOK_only(TARG);
1021 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1024 SETn( left - right );
1031 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1034 if (PL_op->op_private & HINT_INTEGER) {
1036 i = BWi(i) << shift;
1050 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1053 if (PL_op->op_private & HINT_INTEGER) {
1055 i = BWi(i) >> shift;
1069 djSP; tryAMAGICbinSET(lt,0);
1072 SETs(boolSV(TOPn < value));
1079 djSP; tryAMAGICbinSET(gt,0);
1082 SETs(boolSV(TOPn > value));
1089 djSP; tryAMAGICbinSET(le,0);
1092 SETs(boolSV(TOPn <= value));
1099 djSP; tryAMAGICbinSET(ge,0);
1102 SETs(boolSV(TOPn >= value));
1109 djSP; tryAMAGICbinSET(ne,0);
1112 SETs(boolSV(TOPn != value));
1119 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1126 else if (left < right)
1128 else if (left > right)
1141 djSP; tryAMAGICbinSET(slt,0);
1144 int cmp = ((PL_op->op_private & OPpLOCALE)
1145 ? sv_cmp_locale(left, right)
1146 : sv_cmp(left, right));
1147 SETs(boolSV(cmp < 0));
1154 djSP; tryAMAGICbinSET(sgt,0);
1157 int cmp = ((PL_op->op_private & OPpLOCALE)
1158 ? sv_cmp_locale(left, right)
1159 : sv_cmp(left, right));
1160 SETs(boolSV(cmp > 0));
1167 djSP; tryAMAGICbinSET(sle,0);
1170 int cmp = ((PL_op->op_private & OPpLOCALE)
1171 ? sv_cmp_locale(left, right)
1172 : sv_cmp(left, right));
1173 SETs(boolSV(cmp <= 0));
1180 djSP; tryAMAGICbinSET(sge,0);
1183 int cmp = ((PL_op->op_private & OPpLOCALE)
1184 ? sv_cmp_locale(left, right)
1185 : sv_cmp(left, right));
1186 SETs(boolSV(cmp >= 0));
1193 djSP; tryAMAGICbinSET(seq,0);
1196 SETs(boolSV(sv_eq(left, right)));
1203 djSP; tryAMAGICbinSET(sne,0);
1206 SETs(boolSV(!sv_eq(left, right)));
1213 djSP; dTARGET; tryAMAGICbin(scmp,0);
1216 int cmp = ((PL_op->op_private & OPpLOCALE)
1217 ? sv_cmp_locale(left, right)
1218 : sv_cmp(left, right));
1226 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1229 if (SvNIOKp(left) || SvNIOKp(right)) {
1230 if (PL_op->op_private & HINT_INTEGER) {
1231 IBW value = SvIV(left) & SvIV(right);
1235 UBW value = SvUV(left) & SvUV(right);
1240 do_vop(PL_op->op_type, TARG, left, right);
1249 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1252 if (SvNIOKp(left) || SvNIOKp(right)) {
1253 if (PL_op->op_private & HINT_INTEGER) {
1254 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1258 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1263 do_vop(PL_op->op_type, TARG, left, right);
1272 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1275 if (SvNIOKp(left) || SvNIOKp(right)) {
1276 if (PL_op->op_private & HINT_INTEGER) {
1277 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1281 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1286 do_vop(PL_op->op_type, TARG, left, right);
1295 djSP; dTARGET; tryAMAGICun(neg);
1300 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1302 else if (SvNIOKp(sv))
1304 else if (SvPOKp(sv)) {
1306 char *s = SvPV(sv, len);
1307 if (isIDFIRST(*s)) {
1308 sv_setpvn(TARG, "-", 1);
1311 else if (*s == '+' || *s == '-') {
1313 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1316 sv_setnv(TARG, -SvNV(sv));
1328 djSP; tryAMAGICunSET(not);
1329 #endif /* OVERLOAD */
1330 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1336 djSP; dTARGET; tryAMAGICun(compl);
1340 if (PL_op->op_private & HINT_INTEGER) {
1341 IBW value = ~SvIV(sv);
1345 UBW value = ~SvUV(sv);
1350 register char *tmps;
1351 register long *tmpl;
1356 tmps = SvPV_force(TARG, len);
1359 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1362 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1366 for ( ; anum > 0; anum--, tmps++)
1375 /* integer versions of some of the above */
1379 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1382 SETi( left * right );
1389 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1393 DIE("Illegal division by zero");
1394 value = POPi / value;
1402 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1406 DIE("Illegal modulus zero");
1407 SETi( left % right );
1414 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1417 SETi( left + right );
1424 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1427 SETi( left - right );
1434 djSP; tryAMAGICbinSET(lt,0);
1437 SETs(boolSV(left < right));
1444 djSP; tryAMAGICbinSET(gt,0);
1447 SETs(boolSV(left > right));
1454 djSP; tryAMAGICbinSET(le,0);
1457 SETs(boolSV(left <= right));
1464 djSP; tryAMAGICbinSET(ge,0);
1467 SETs(boolSV(left >= right));
1474 djSP; tryAMAGICbinSET(eq,0);
1477 SETs(boolSV(left == right));
1484 djSP; tryAMAGICbinSET(ne,0);
1487 SETs(boolSV(left != right));
1494 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1501 else if (left < right)
1512 djSP; dTARGET; tryAMAGICun(neg);
1517 /* High falutin' math. */
1521 djSP; dTARGET; tryAMAGICbin(atan2,0);
1524 SETn(atan2(left, right));
1531 djSP; dTARGET; tryAMAGICun(sin);
1543 djSP; dTARGET; tryAMAGICun(cos);
1553 /* Support Configure command-line overrides for rand() functions.
1554 After 5.005, perhaps we should replace this by Configure support
1555 for drand48(), random(), or rand(). For 5.005, though, maintain
1556 compatibility by calling rand() but allow the user to override it.
1557 See INSTALL for details. --Andy Dougherty 15 July 1998
1560 # define my_rand rand
1563 # define my_srand srand
1576 if (!srand_called) {
1577 (void)my_srand((unsigned)seed());
1578 srand_called = TRUE;
1581 value = my_rand() * value / 2147483648.0;
1584 value = my_rand() * value / 65536.0;
1587 value = my_rand() * value / 32768.0;
1589 value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
1605 (void)my_srand((unsigned)anum);
1606 srand_called = TRUE;
1615 * This is really just a quick hack which grabs various garbage
1616 * values. It really should be a real hash algorithm which
1617 * spreads the effect of every input bit onto every output bit,
1618 * if someone who knows about such tings would bother to write it.
1619 * Might be a good idea to add that function to CORE as well.
1620 * No numbers below come from careful analysis or anyting here,
1621 * except they are primes and SEED_C1 > 1E6 to get a full-width
1622 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1623 * probably be bigger too.
1626 # define SEED_C1 1000003
1627 #define SEED_C4 73819
1629 # define SEED_C1 25747
1630 #define SEED_C4 20639
1634 #define SEED_C5 26107
1639 # include <starlet.h>
1640 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1641 * in 100-ns units, typically incremented ever 10 ms. */
1642 unsigned int when[2];
1643 _ckvmssts(sys$gettim(when));
1644 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1646 # ifdef HAS_GETTIMEOFDAY
1647 struct timeval when;
1648 gettimeofday(&when,(struct timezone *) 0);
1649 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1653 u = (U32)SEED_C1 * when;
1656 u += SEED_C3 * (U32)getpid();
1657 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1658 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1659 u += SEED_C5 * (U32)(UV)&when;
1666 djSP; dTARGET; tryAMAGICun(exp);
1678 djSP; dTARGET; tryAMAGICun(log);
1683 SET_NUMERIC_STANDARD();
1684 DIE("Can't take log of %g", value);
1694 djSP; dTARGET; tryAMAGICun(sqrt);
1699 SET_NUMERIC_STANDARD();
1700 DIE("Can't take sqrt of %g", value);
1702 value = sqrt(value);
1712 double value = TOPn;
1715 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1721 (void)modf(value, &value);
1723 (void)modf(-value, &value);
1738 djSP; dTARGET; tryAMAGICun(abs);
1740 double value = TOPn;
1743 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1744 (iv = SvIVX(TOPs)) != IV_MIN) {
1765 XPUSHu(scan_hex(tmps, 99, &argtype));
1777 while (*tmps && isSPACE(*tmps))
1782 value = scan_hex(++tmps, 99, &argtype);
1784 value = scan_oct(tmps, 99, &argtype);
1794 SETi( sv_len(TOPs) );
1807 I32 lvalue = PL_op->op_flags & OPf_MOD;
1809 I32 arybase = PL_curcop->cop_arybase;
1813 SvTAINTED_off(TARG); /* decontaminate */
1817 repl = SvPV(sv, repl_len);
1824 tmps = SvPV(sv, curlen);
1825 if (pos >= arybase) {
1843 else if (len >= 0) {
1845 if (rem > (I32)curlen)
1859 if (PL_dowarn || lvalue || repl)
1860 warn("substr outside of string");
1865 sv_setpvn(TARG, tmps, rem);
1866 if (lvalue) { /* it's an lvalue! */
1867 if (!SvGMAGICAL(sv)) {
1869 SvPV_force(sv,PL_na);
1871 warn("Attempt to use reference as lvalue in substr");
1873 if (SvOK(sv)) /* is it defined ? */
1874 (void)SvPOK_only(sv);
1876 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1879 if (SvTYPE(TARG) < SVt_PVLV) {
1880 sv_upgrade(TARG, SVt_PVLV);
1881 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1885 if (LvTARG(TARG) != sv) {
1887 SvREFCNT_dec(LvTARG(TARG));
1888 LvTARG(TARG) = SvREFCNT_inc(sv);
1890 LvTARGOFF(TARG) = pos;
1891 LvTARGLEN(TARG) = rem;
1894 sv_insert(sv, pos, rem, repl, repl_len);
1897 PUSHs(TARG); /* avoid SvSETMAGIC here */
1904 register I32 size = POPi;
1905 register I32 offset = POPi;
1906 register SV *src = POPs;
1907 I32 lvalue = PL_op->op_flags & OPf_MOD;
1909 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1910 unsigned long retnum;
1913 SvTAINTED_off(TARG); /* decontaminate */
1914 offset *= size; /* turn into bit offset */
1915 len = (offset + size + 7) / 8;
1916 if (offset < 0 || size < 1)
1919 if (lvalue) { /* it's an lvalue! */
1920 if (SvTYPE(TARG) < SVt_PVLV) {
1921 sv_upgrade(TARG, SVt_PVLV);
1922 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1926 if (LvTARG(TARG) != src) {
1928 SvREFCNT_dec(LvTARG(TARG));
1929 LvTARG(TARG) = SvREFCNT_inc(src);
1931 LvTARGOFF(TARG) = offset;
1932 LvTARGLEN(TARG) = size;
1940 if (offset >= srclen)
1943 retnum = (unsigned long) s[offset] << 8;
1945 else if (size == 32) {
1946 if (offset >= srclen)
1948 else if (offset + 1 >= srclen)
1949 retnum = (unsigned long) s[offset] << 24;
1950 else if (offset + 2 >= srclen)
1951 retnum = ((unsigned long) s[offset] << 24) +
1952 ((unsigned long) s[offset + 1] << 16);
1954 retnum = ((unsigned long) s[offset] << 24) +
1955 ((unsigned long) s[offset + 1] << 16) +
1956 (s[offset + 2] << 8);
1961 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1966 else if (size == 16)
1967 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1968 else if (size == 32)
1969 retnum = ((unsigned long) s[offset] << 24) +
1970 ((unsigned long) s[offset + 1] << 16) +
1971 (s[offset + 2] << 8) + s[offset+3];
1975 sv_setuv(TARG, (UV)retnum);
1990 I32 arybase = PL_curcop->cop_arybase;
1995 offset = POPi - arybase;
1998 tmps = SvPV(big, biglen);
2001 else if (offset > biglen)
2003 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2004 (unsigned char*)tmps + biglen, little, 0)))
2005 retval = -1 + arybase;
2007 retval = tmps2 - tmps + arybase;
2024 I32 arybase = PL_curcop->cop_arybase;
2030 tmps2 = SvPV(little, llen);
2031 tmps = SvPV(big, blen);
2035 offset = SvIV(offstr) - arybase + llen;
2038 else if (offset > blen)
2040 if (!(tmps2 = rninstr(tmps, tmps + offset,
2041 tmps2, tmps2 + llen)))
2042 retval = -1 + arybase;
2044 retval = tmps2 - tmps + arybase;
2051 djSP; dMARK; dORIGMARK; dTARGET;
2052 #ifdef USE_LOCALE_NUMERIC
2053 if (PL_op->op_private & OPpLOCALE)
2054 SET_NUMERIC_LOCAL();
2056 SET_NUMERIC_STANDARD();
2058 do_sprintf(TARG, SP-MARK, MARK+1);
2059 TAINT_IF(SvTAINTED(TARG));
2073 value = (I32) (*tmps & 255);
2078 value = (I32) (anum & 255);
2089 (void)SvUPGRADE(TARG,SVt_PV);
2095 (void)SvPOK_only(TARG);
2102 djSP; dTARGET; dPOPTOPssrl;
2104 char *tmps = SvPV(left, PL_na);
2106 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2108 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2112 "The crypt() function is unimplemented due to excessive paranoia.");
2124 if (!SvPADTMP(sv)) {
2130 s = SvPV_force(sv, PL_na);
2132 if (PL_op->op_private & OPpLOCALE) {
2135 *s = toUPPER_LC(*s);
2150 if (!SvPADTMP(sv)) {
2156 s = SvPV_force(sv, PL_na);
2158 if (PL_op->op_private & OPpLOCALE) {
2161 *s = toLOWER_LC(*s);
2178 if (!SvPADTMP(sv)) {
2185 s = SvPV_force(sv, len);
2187 register char *send = s + len;
2189 if (PL_op->op_private & OPpLOCALE) {
2192 for (; s < send; s++)
2193 *s = toUPPER_LC(*s);
2196 for (; s < send; s++)
2210 if (!SvPADTMP(sv)) {
2217 s = SvPV_force(sv, len);
2219 register char *send = s + len;
2221 if (PL_op->op_private & OPpLOCALE) {
2224 for (; s < send; s++)
2225 *s = toLOWER_LC(*s);
2228 for (; s < send; s++)
2240 register char *s = SvPV(sv,len);
2244 (void)SvUPGRADE(TARG, SVt_PV);
2245 SvGROW(TARG, (len * 2) + 1);
2253 SvCUR_set(TARG, d - SvPVX(TARG));
2254 (void)SvPOK_only(TARG);
2257 sv_setpvn(TARG, s, len);
2266 djSP; dMARK; dORIGMARK;
2268 register AV* av = (AV*)POPs;
2269 register I32 lval = PL_op->op_flags & OPf_MOD;
2270 I32 arybase = PL_curcop->cop_arybase;
2273 if (SvTYPE(av) == SVt_PVAV) {
2274 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2276 for (svp = MARK + 1; svp <= SP; svp++) {
2281 if (max > AvMAX(av))
2284 while (++MARK <= SP) {
2285 elem = SvIVx(*MARK);
2289 svp = av_fetch(av, elem, lval);
2291 if (!svp || *svp == &PL_sv_undef)
2292 DIE(no_aelem, elem);
2293 if (PL_op->op_private & OPpLVAL_INTRO)
2294 save_aelem(av, elem, svp);
2296 *MARK = svp ? *svp : &PL_sv_undef;
2299 if (GIMME != G_ARRAY) {
2307 /* Associative arrays. */
2312 HV *hash = (HV*)POPs;
2314 I32 gimme = GIMME_V;
2315 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2318 /* might clobber stack_sp */
2319 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2324 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2325 if (gimme == G_ARRAY) {
2327 /* might clobber stack_sp */
2328 sv_setsv(TARG, realhv ?
2329 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2334 else if (gimme == G_SCALAR)
2353 I32 gimme = GIMME_V;
2354 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2358 if (PL_op->op_private & OPpSLICE) {
2362 hvtype = SvTYPE(hv);
2363 while (++MARK <= SP) {
2364 if (hvtype == SVt_PVHV)
2365 sv = hv_delete_ent(hv, *MARK, discard, 0);
2367 DIE("Not a HASH reference");
2368 *MARK = sv ? sv : &PL_sv_undef;
2372 else if (gimme == G_SCALAR) {
2381 if (SvTYPE(hv) == SVt_PVHV)
2382 sv = hv_delete_ent(hv, keysv, discard, 0);
2384 DIE("Not a HASH reference");
2398 if (SvTYPE(hv) == SVt_PVHV) {
2399 if (hv_exists_ent(hv, tmpsv, 0))
2401 } else if (SvTYPE(hv) == SVt_PVAV) {
2402 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2405 DIE("Not a HASH reference");
2412 djSP; dMARK; dORIGMARK;
2413 register HV *hv = (HV*)POPs;
2414 register I32 lval = PL_op->op_flags & OPf_MOD;
2415 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2417 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2418 DIE("Can't localize pseudo-hash element");
2420 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2421 while (++MARK <= SP) {
2425 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2426 svp = he ? &HeVAL(he) : 0;
2428 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2431 if (!svp || *svp == &PL_sv_undef)
2432 DIE(no_helem, SvPV(keysv, PL_na));
2433 if (PL_op->op_private & OPpLVAL_INTRO)
2434 save_helem(hv, keysv, svp);
2436 *MARK = svp ? *svp : &PL_sv_undef;
2439 if (GIMME != G_ARRAY) {
2447 /* List operators. */
2452 if (GIMME != G_ARRAY) {
2454 *MARK = *SP; /* unwanted list, return last item */
2456 *MARK = &PL_sv_undef;
2465 SV **lastrelem = PL_stack_sp;
2466 SV **lastlelem = PL_stack_base + POPMARK;
2467 SV **firstlelem = PL_stack_base + POPMARK + 1;
2468 register SV **firstrelem = lastlelem + 1;
2469 I32 arybase = PL_curcop->cop_arybase;
2470 I32 lval = PL_op->op_flags & OPf_MOD;
2471 I32 is_something_there = lval;
2473 register I32 max = lastrelem - lastlelem;
2474 register SV **lelem;
2477 if (GIMME != G_ARRAY) {
2478 ix = SvIVx(*lastlelem);
2483 if (ix < 0 || ix >= max)
2484 *firstlelem = &PL_sv_undef;
2486 *firstlelem = firstrelem[ix];
2492 SP = firstlelem - 1;
2496 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2501 *lelem = &PL_sv_undef;
2502 else if (!(*lelem = firstrelem[ix]))
2503 *lelem = &PL_sv_undef;
2507 if (ix >= max || !(*lelem = firstrelem[ix]))
2508 *lelem = &PL_sv_undef;
2510 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2511 is_something_there = TRUE;
2513 if (is_something_there)
2516 SP = firstlelem - 1;
2522 djSP; dMARK; dORIGMARK;
2523 I32 items = SP - MARK;
2524 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2525 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2532 djSP; dMARK; dORIGMARK;
2533 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2537 SV *val = NEWSV(46, 0);
2539 sv_setsv(val, *++MARK);
2541 warn("Odd number of elements in hash assignment");
2542 (void)hv_store_ent(hv,key,val,0);
2551 djSP; dMARK; dORIGMARK;
2552 register AV *ary = (AV*)*++MARK;
2556 register I32 offset;
2557 register I32 length;
2564 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2565 *MARK-- = mg->mg_obj;
2569 perl_call_method("SPLICE",GIMME_V);
2578 offset = i = SvIVx(*MARK);
2580 offset += AvFILLp(ary) + 1;
2582 offset -= PL_curcop->cop_arybase;
2586 length = SvIVx(*MARK++);
2588 length += AvFILLp(ary) - offset + 1;
2594 length = AvMAX(ary) + 1; /* close enough to infinity */
2598 length = AvMAX(ary) + 1;
2600 if (offset > AvFILLp(ary) + 1)
2601 offset = AvFILLp(ary) + 1;
2602 after = AvFILLp(ary) + 1 - (offset + length);
2603 if (after < 0) { /* not that much array */
2604 length += after; /* offset+length now in array */
2610 /* At this point, MARK .. SP-1 is our new LIST */
2613 diff = newlen - length;
2614 if (newlen && !AvREAL(ary)) {
2618 assert(AvREAL(ary)); /* would leak, so croak */
2621 if (diff < 0) { /* shrinking the area */
2623 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2624 Copy(MARK, tmparyval, newlen, SV*);
2627 MARK = ORIGMARK + 1;
2628 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2629 MEXTEND(MARK, length);
2630 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2632 EXTEND_MORTAL(length);
2633 for (i = length, dst = MARK; i; i--) {
2634 sv_2mortal(*dst); /* free them eventualy */
2641 *MARK = AvARRAY(ary)[offset+length-1];
2644 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2645 SvREFCNT_dec(*dst++); /* free them now */
2648 AvFILLp(ary) += diff;
2650 /* pull up or down? */
2652 if (offset < after) { /* easier to pull up */
2653 if (offset) { /* esp. if nothing to pull */
2654 src = &AvARRAY(ary)[offset-1];
2655 dst = src - diff; /* diff is negative */
2656 for (i = offset; i > 0; i--) /* can't trust Copy */
2660 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2664 if (after) { /* anything to pull down? */
2665 src = AvARRAY(ary) + offset + length;
2666 dst = src + diff; /* diff is negative */
2667 Move(src, dst, after, SV*);
2669 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2670 /* avoid later double free */
2674 dst[--i] = &PL_sv_undef;
2677 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2679 *dst = NEWSV(46, 0);
2680 sv_setsv(*dst++, *src++);
2682 Safefree(tmparyval);
2685 else { /* no, expanding (or same) */
2687 New(452, tmparyval, length, SV*); /* so remember deletion */
2688 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2691 if (diff > 0) { /* expanding */
2693 /* push up or down? */
2695 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2699 Move(src, dst, offset, SV*);
2701 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2703 AvFILLp(ary) += diff;
2706 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2707 av_extend(ary, AvFILLp(ary) + diff);
2708 AvFILLp(ary) += diff;
2711 dst = AvARRAY(ary) + AvFILLp(ary);
2713 for (i = after; i; i--) {
2720 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2721 *dst = NEWSV(46, 0);
2722 sv_setsv(*dst++, *src++);
2724 MARK = ORIGMARK + 1;
2725 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2727 Copy(tmparyval, MARK, length, SV*);
2729 EXTEND_MORTAL(length);
2730 for (i = length, dst = MARK; i; i--) {
2731 sv_2mortal(*dst); /* free them eventualy */
2735 Safefree(tmparyval);
2739 else if (length--) {
2740 *MARK = tmparyval[length];
2743 while (length-- > 0)
2744 SvREFCNT_dec(tmparyval[length]);
2746 Safefree(tmparyval);
2749 *MARK = &PL_sv_undef;
2757 djSP; dMARK; dORIGMARK; dTARGET;
2758 register AV *ary = (AV*)*++MARK;
2759 register SV *sv = &PL_sv_undef;
2762 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2763 *MARK-- = mg->mg_obj;
2767 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2772 /* Why no pre-extend of ary here ? */
2773 for (++MARK; MARK <= SP; MARK++) {
2776 sv_setsv(sv, *MARK);
2781 PUSHi( AvFILL(ary) + 1 );
2789 SV *sv = av_pop(av);
2791 (void)sv_2mortal(sv);
2800 SV *sv = av_shift(av);
2805 (void)sv_2mortal(sv);
2812 djSP; dMARK; dORIGMARK; dTARGET;
2813 register AV *ary = (AV*)*++MARK;
2818 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2819 *MARK-- = mg->mg_obj;
2823 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2828 av_unshift(ary, SP - MARK);
2831 sv_setsv(sv, *++MARK);
2832 (void)av_store(ary, i++, sv);
2836 PUSHi( AvFILL(ary) + 1 );
2846 if (GIMME == G_ARRAY) {
2857 register char *down;
2863 do_join(TARG, &PL_sv_no, MARK, SP);
2865 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
2866 up = SvPV_force(TARG, len);
2868 down = SvPVX(TARG) + len - 1;
2874 (void)SvPOK_only(TARG);
2883 mul128(SV *sv, U8 m)
2886 char *s = SvPV(sv, len);
2890 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
2891 SV *tmpNew = newSVpv("0000000000", 10);
2893 sv_catsv(tmpNew, sv);
2894 SvREFCNT_dec(sv); /* free old sv */
2899 while (!*t) /* trailing '\0'? */
2902 i = ((*t - '0') << 7) + m;
2903 *(t--) = '0' + (i % 10);
2909 /* Explosives and implosives. */
2911 static const char uuemap[] =
2912 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
2913 static char uudmap[256]; /* Initialised on first use */
2914 #if 'I' == 73 && 'J' == 74
2915 /* On an ASCII/ISO kind of system */
2916 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
2919 Some other sort of character set - use memchr() so we don't match
2922 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
2930 I32 gimme = GIMME_V;
2934 register char *pat = SvPV(left, llen);
2935 register char *s = SvPV(right, rlen);
2936 char *strend = s + rlen;
2938 register char *patend = pat + llen;
2943 /* These must not be in registers: */
2954 unsigned Quad_t auquad;
2960 register U32 culong;
2962 static char* bitcount = 0;
2965 if (gimme != G_ARRAY) { /* arrange to do first one only */
2967 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
2968 if (strchr("aAbBhHP", *patend) || *pat == '%') {
2970 while (isDIGIT(*patend) || *patend == '*')
2976 while (pat < patend) {
2978 datumtype = *pat++ & 0xFF;
2979 if (isSPACE(datumtype))
2983 else if (*pat == '*') {
2984 len = strend - strbeg; /* long enough */
2987 else if (isDIGIT(*pat)) {
2989 while (isDIGIT(*pat))
2990 len = (len * 10) + (*pat++ - '0');
2993 len = (datumtype != '@');
2996 croak("Invalid type in unpack: '%c'", (int)datumtype);
2997 case ',': /* grandfather in commas but with a warning */
2998 if (commas++ == 0 && PL_dowarn)
2999 warn("Invalid type in unpack: '%c'", (int)datumtype);
3002 if (len == 1 && pat[-1] != '1')
3011 if (len > strend - strbeg)
3012 DIE("@ outside of string");
3016 if (len > s - strbeg)
3017 DIE("X outside of string");
3021 if (len > strend - s)
3022 DIE("x outside of string");
3027 if (len > strend - s)
3030 goto uchar_checksum;
3031 sv = NEWSV(35, len);
3032 sv_setpvn(sv, s, len);
3034 if (datumtype == 'A') {
3035 aptr = s; /* borrow register */
3036 s = SvPVX(sv) + len - 1;
3037 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3040 SvCUR_set(sv, s - SvPVX(sv));
3041 s = aptr; /* unborrow register */
3043 XPUSHs(sv_2mortal(sv));
3047 if (pat[-1] == '*' || len > (strend - s) * 8)
3048 len = (strend - s) * 8;
3051 Newz(601, bitcount, 256, char);
3052 for (bits = 1; bits < 256; bits++) {
3053 if (bits & 1) bitcount[bits]++;
3054 if (bits & 2) bitcount[bits]++;
3055 if (bits & 4) bitcount[bits]++;
3056 if (bits & 8) bitcount[bits]++;
3057 if (bits & 16) bitcount[bits]++;
3058 if (bits & 32) bitcount[bits]++;
3059 if (bits & 64) bitcount[bits]++;
3060 if (bits & 128) bitcount[bits]++;
3064 culong += bitcount[*(unsigned char*)s++];
3069 if (datumtype == 'b') {
3071 if (bits & 1) culong++;
3077 if (bits & 128) culong++;
3084 sv = NEWSV(35, len + 1);
3087 aptr = pat; /* borrow register */
3089 if (datumtype == 'b') {
3091 for (len = 0; len < aint; len++) {
3092 if (len & 7) /*SUPPRESS 595*/
3096 *pat++ = '0' + (bits & 1);
3101 for (len = 0; len < aint; len++) {
3106 *pat++ = '0' + ((bits & 128) != 0);
3110 pat = aptr; /* unborrow register */
3111 XPUSHs(sv_2mortal(sv));
3115 if (pat[-1] == '*' || len > (strend - s) * 2)
3116 len = (strend - s) * 2;
3117 sv = NEWSV(35, len + 1);
3120 aptr = pat; /* borrow register */
3122 if (datumtype == 'h') {
3124 for (len = 0; len < aint; len++) {
3129 *pat++ = PL_hexdigit[bits & 15];
3134 for (len = 0; len < aint; len++) {
3139 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3143 pat = aptr; /* unborrow register */
3144 XPUSHs(sv_2mortal(sv));
3147 if (len > strend - s)
3152 if (aint >= 128) /* fake up signed chars */
3162 if (aint >= 128) /* fake up signed chars */
3165 sv_setiv(sv, (IV)aint);
3166 PUSHs(sv_2mortal(sv));
3171 if (len > strend - s)
3186 sv_setiv(sv, (IV)auint);
3187 PUSHs(sv_2mortal(sv));
3192 along = (strend - s) / SIZE16;
3209 sv_setiv(sv, (IV)ashort);
3210 PUSHs(sv_2mortal(sv));
3217 along = (strend - s) / SIZE16;
3222 COPY16(s, &aushort);
3225 if (datumtype == 'n')
3226 aushort = PerlSock_ntohs(aushort);
3229 if (datumtype == 'v')
3230 aushort = vtohs(aushort);
3239 COPY16(s, &aushort);
3243 if (datumtype == 'n')
3244 aushort = PerlSock_ntohs(aushort);
3247 if (datumtype == 'v')
3248 aushort = vtohs(aushort);
3250 sv_setiv(sv, (IV)aushort);
3251 PUSHs(sv_2mortal(sv));
3256 along = (strend - s) / sizeof(int);
3261 Copy(s, &aint, 1, int);
3264 cdouble += (double)aint;
3273 Copy(s, &aint, 1, int);
3277 /* Without the dummy below unpack("i", pack("i",-1))
3278 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3279 * cc with optimization turned on */
3281 sv_setiv(sv, (IV)aint) :
3283 sv_setiv(sv, (IV)aint);
3284 PUSHs(sv_2mortal(sv));
3289 along = (strend - s) / sizeof(unsigned int);
3294 Copy(s, &auint, 1, unsigned int);
3295 s += sizeof(unsigned int);
3297 cdouble += (double)auint;
3306 Copy(s, &auint, 1, unsigned int);
3307 s += sizeof(unsigned int);
3309 sv_setuv(sv, (UV)auint);
3310 PUSHs(sv_2mortal(sv));
3315 along = (strend - s) / SIZE32;
3323 cdouble += (double)along;
3335 sv_setiv(sv, (IV)along);
3336 PUSHs(sv_2mortal(sv));
3343 along = (strend - s) / SIZE32;
3351 if (datumtype == 'N')
3352 aulong = PerlSock_ntohl(aulong);
3355 if (datumtype == 'V')
3356 aulong = vtohl(aulong);
3359 cdouble += (double)aulong;
3371 if (datumtype == 'N')
3372 aulong = PerlSock_ntohl(aulong);
3375 if (datumtype == 'V')
3376 aulong = vtohl(aulong);
3379 sv_setuv(sv, (UV)aulong);
3380 PUSHs(sv_2mortal(sv));
3385 along = (strend - s) / sizeof(char*);
3391 if (sizeof(char*) > strend - s)
3394 Copy(s, &aptr, 1, char*);
3400 PUSHs(sv_2mortal(sv));
3410 while ((len > 0) && (s < strend)) {
3411 auv = (auv << 7) | (*s & 0x7f);
3412 if (!(*s++ & 0x80)) {
3416 PUSHs(sv_2mortal(sv));
3420 else if (++bytes >= sizeof(UV)) { /* promote to string */
3423 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3424 while (s < strend) {
3425 sv = mul128(sv, *s & 0x7f);
3426 if (!(*s++ & 0x80)) {
3431 t = SvPV(sv, PL_na);
3435 PUSHs(sv_2mortal(sv));
3440 if ((s >= strend) && bytes)
3441 croak("Unterminated compressed integer");
3446 if (sizeof(char*) > strend - s)
3449 Copy(s, &aptr, 1, char*);
3454 sv_setpvn(sv, aptr, len);
3455 PUSHs(sv_2mortal(sv));
3459 along = (strend - s) / sizeof(Quad_t);
3465 if (s + sizeof(Quad_t) > strend)
3468 Copy(s, &aquad, 1, Quad_t);
3469 s += sizeof(Quad_t);
3472 if (aquad >= IV_MIN && aquad <= IV_MAX)
3473 sv_setiv(sv, (IV)aquad);
3475 sv_setnv(sv, (double)aquad);
3476 PUSHs(sv_2mortal(sv));
3480 along = (strend - s) / sizeof(Quad_t);
3486 if (s + sizeof(unsigned Quad_t) > strend)
3489 Copy(s, &auquad, 1, unsigned Quad_t);
3490 s += sizeof(unsigned Quad_t);
3493 if (auquad <= UV_MAX)
3494 sv_setuv(sv, (UV)auquad);
3496 sv_setnv(sv, (double)auquad);
3497 PUSHs(sv_2mortal(sv));
3501 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3504 along = (strend - s) / sizeof(float);
3509 Copy(s, &afloat, 1, float);
3518 Copy(s, &afloat, 1, float);
3521 sv_setnv(sv, (double)afloat);
3522 PUSHs(sv_2mortal(sv));
3528 along = (strend - s) / sizeof(double);
3533 Copy(s, &adouble, 1, double);
3534 s += sizeof(double);
3542 Copy(s, &adouble, 1, double);
3543 s += sizeof(double);
3545 sv_setnv(sv, (double)adouble);
3546 PUSHs(sv_2mortal(sv));
3552 * Initialise the decode mapping. By using a table driven
3553 * algorithm, the code will be character-set independent
3554 * (and just as fast as doing character arithmetic)
3556 if (uudmap['M'] == 0) {
3559 for (i = 0; i < sizeof(uuemap); i += 1)
3560 uudmap[uuemap[i]] = i;
3562 * Because ' ' and '`' map to the same value,
3563 * we need to decode them both the same.
3568 along = (strend - s) * 3 / 4;
3569 sv = NEWSV(42, along);
3572 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3577 len = (*s++ - ' ') & 077;
3579 if (s < strend && ISUUCHAR(*s))
3580 a = uudmap[*s++] & 077;
3583 if (s < strend && ISUUCHAR(*s))
3584 b = uudmap[*s++] & 077;
3587 if (s < strend && ISUUCHAR(*s))
3588 c = uudmap[*s++] & 077;
3591 if (s < strend && ISUUCHAR(*s))
3592 d = uudmap[*s++] & 077;
3595 hunk[0] = (a << 2) | (b >> 4);
3596 hunk[1] = (b << 4) | (c >> 2);
3597 hunk[2] = (c << 6) | d;
3598 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3603 else if (s[1] == '\n') /* possible checksum byte */
3606 XPUSHs(sv_2mortal(sv));
3611 if (strchr("fFdD", datumtype) ||
3612 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3616 while (checksum >= 16) {
3620 while (checksum >= 4) {
3626 along = (1 << checksum) - 1;
3627 while (cdouble < 0.0)
3629 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3630 sv_setnv(sv, cdouble);
3633 if (checksum < 32) {
3634 aulong = (1 << checksum) - 1;
3637 sv_setuv(sv, (UV)culong);
3639 XPUSHs(sv_2mortal(sv));
3643 if (SP == oldsp && gimme == G_SCALAR)
3644 PUSHs(&PL_sv_undef);
3649 doencodes(register SV *sv, register char *s, register I32 len)
3653 *hunk = uuemap[len];
3654 sv_catpvn(sv, hunk, 1);
3657 hunk[0] = uuemap[(077 & (*s >> 2))];
3658 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3659 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3660 hunk[3] = uuemap[(077 & (s[2] & 077))];
3661 sv_catpvn(sv, hunk, 4);
3666 char r = (len > 1 ? s[1] : '\0');
3667 hunk[0] = uuemap[(077 & (*s >> 2))];
3668 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3669 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3670 hunk[3] = uuemap[0];
3671 sv_catpvn(sv, hunk, 4);
3673 sv_catpvn(sv, "\n", 1);
3677 is_an_int(char *s, STRLEN l)
3679 SV *result = newSVpv("", l);
3680 char *result_c = SvPV(result, PL_na); /* convenience */
3681 char *out = result_c;
3691 SvREFCNT_dec(result);
3714 SvREFCNT_dec(result);
3720 SvCUR_set(result, out - result_c);
3725 div128(SV *pnum, bool *done)
3726 /* must be '\0' terminated */
3730 char *s = SvPV(pnum, len);
3739 i = m * 10 + (*t - '0');
3741 r = (i >> 7); /* r < 10 */
3748 SvCUR_set(pnum, (STRLEN) (t - s));
3755 djSP; dMARK; dORIGMARK; dTARGET;
3756 register SV *cat = TARG;
3759 register char *pat = SvPVx(*++MARK, fromlen);
3760 register char *patend = pat + fromlen;
3765 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3766 static char *space10 = " ";
3768 /* These must not be in registers: */
3777 unsigned Quad_t auquad;
3786 sv_setpvn(cat, "", 0);
3787 while (pat < patend) {
3788 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
3789 datumtype = *pat++ & 0xFF;
3790 if (isSPACE(datumtype))
3793 len = strchr("@Xxu", datumtype) ? 0 : items;
3796 else if (isDIGIT(*pat)) {
3798 while (isDIGIT(*pat))
3799 len = (len * 10) + (*pat++ - '0');
3805 croak("Invalid type in pack: '%c'", (int)datumtype);
3806 case ',': /* grandfather in commas but with a warning */
3807 if (commas++ == 0 && PL_dowarn)
3808 warn("Invalid type in pack: '%c'", (int)datumtype);
3811 DIE("%% may only be used in unpack");
3822 if (SvCUR(cat) < len)
3823 DIE("X outside of string");
3830 sv_catpvn(cat, null10, 10);
3833 sv_catpvn(cat, null10, len);
3838 aptr = SvPV(fromstr, fromlen);
3842 sv_catpvn(cat, aptr, len);
3844 sv_catpvn(cat, aptr, fromlen);
3846 if (datumtype == 'A') {
3848 sv_catpvn(cat, space10, 10);
3851 sv_catpvn(cat, space10, len);
3855 sv_catpvn(cat, null10, 10);
3858 sv_catpvn(cat, null10, len);
3865 char *savepat = pat;
3870 aptr = SvPV(fromstr, fromlen);
3875 SvCUR(cat) += (len+7)/8;
3876 SvGROW(cat, SvCUR(cat) + 1);
3877 aptr = SvPVX(cat) + aint;
3882 if (datumtype == 'B') {
3883 for (len = 0; len++ < aint;) {
3884 items |= *pat++ & 1;
3888 *aptr++ = items & 0xff;
3894 for (len = 0; len++ < aint;) {
3900 *aptr++ = items & 0xff;
3906 if (datumtype == 'B')
3907 items <<= 7 - (aint & 7);
3909 items >>= 7 - (aint & 7);
3910 *aptr++ = items & 0xff;
3912 pat = SvPVX(cat) + SvCUR(cat);
3923 char *savepat = pat;
3928 aptr = SvPV(fromstr, fromlen);
3933 SvCUR(cat) += (len+1)/2;
3934 SvGROW(cat, SvCUR(cat) + 1);
3935 aptr = SvPVX(cat) + aint;
3940 if (datumtype == 'H') {
3941 for (len = 0; len++ < aint;) {
3943 items |= ((*pat++ & 15) + 9) & 15;
3945 items |= *pat++ & 15;
3949 *aptr++ = items & 0xff;
3955 for (len = 0; len++ < aint;) {
3957 items |= (((*pat++ & 15) + 9) & 15) << 4;
3959 items |= (*pat++ & 15) << 4;
3963 *aptr++ = items & 0xff;
3969 *aptr++ = items & 0xff;
3970 pat = SvPVX(cat) + SvCUR(cat);
3982 aint = SvIV(fromstr);
3984 sv_catpvn(cat, &achar, sizeof(char));
3987 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
3992 afloat = (float)SvNV(fromstr);
3993 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4000 adouble = (double)SvNV(fromstr);
4001 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4007 ashort = (I16)SvIV(fromstr);
4009 ashort = PerlSock_htons(ashort);
4011 CAT16(cat, &ashort);
4017 ashort = (I16)SvIV(fromstr);
4019 ashort = htovs(ashort);
4021 CAT16(cat, &ashort);
4028 ashort = (I16)SvIV(fromstr);
4029 CAT16(cat, &ashort);
4035 auint = SvUV(fromstr);
4036 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4042 adouble = floor(SvNV(fromstr));
4045 croak("Cannot compress negative numbers");
4051 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4052 adouble <= UV_MAX_cxux
4059 char buf[1 + sizeof(UV)];
4060 char *in = buf + sizeof(buf);
4061 UV auv = U_V(adouble);;
4064 *--in = (auv & 0x7f) | 0x80;
4067 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4068 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4070 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4071 char *from, *result, *in;
4076 /* Copy string and check for compliance */
4077 from = SvPV(fromstr, len);
4078 if ((norm = is_an_int(from, len)) == NULL)
4079 croak("can compress only unsigned integer");
4081 New('w', result, len, char);
4085 *--in = div128(norm, &done) | 0x80;
4086 result[len - 1] &= 0x7F; /* clear continue bit */
4087 sv_catpvn(cat, in, (result + len) - in);
4089 SvREFCNT_dec(norm); /* free norm */
4091 else if (SvNOKp(fromstr)) {
4092 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4093 char *in = buf + sizeof(buf);
4096 double next = floor(adouble / 128);
4097 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4098 if (--in < buf) /* this cannot happen ;-) */
4099 croak ("Cannot compress integer");
4101 } while (adouble > 0);
4102 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4103 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4106 croak("Cannot compress non integer");
4112 aint = SvIV(fromstr);
4113 sv_catpvn(cat, (char*)&aint, sizeof(int));
4119 aulong = SvUV(fromstr);
4121 aulong = PerlSock_htonl(aulong);
4123 CAT32(cat, &aulong);
4129 aulong = SvUV(fromstr);
4131 aulong = htovl(aulong);
4133 CAT32(cat, &aulong);
4139 aulong = SvUV(fromstr);
4140 CAT32(cat, &aulong);
4146 along = SvIV(fromstr);
4154 auquad = (unsigned Quad_t)SvIV(fromstr);
4155 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4161 aquad = (Quad_t)SvIV(fromstr);
4162 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4165 #endif /* HAS_QUAD */
4167 len = 1; /* assume SV is correct length */
4172 if (fromstr == &PL_sv_undef)
4175 /* XXX better yet, could spirit away the string to
4176 * a safe spot and hang on to it until the result
4177 * of pack() (and all copies of the result) are
4180 if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4181 warn("Attempt to pack pointer to temporary value");
4182 if (SvPOK(fromstr) || SvNIOK(fromstr))
4183 aptr = SvPV(fromstr,PL_na);
4185 aptr = SvPV_force(fromstr,PL_na);
4187 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4192 aptr = SvPV(fromstr, fromlen);
4193 SvGROW(cat, fromlen * 4 / 3);
4198 while (fromlen > 0) {
4205 doencodes(cat, aptr, todo);
4224 register I32 limit = POPi; /* note, negative is forever */
4227 register char *s = SvPV(sv, len);
4228 char *strend = s + len;
4230 register REGEXP *rx;
4234 I32 maxiters = (strend - s) + 10;
4237 I32 origlimit = limit;
4240 AV *oldstack = PL_curstack;
4241 I32 gimme = GIMME_V;
4242 I32 oldsave = PL_savestack_ix;
4243 I32 make_mortal = 1;
4244 MAGIC *mg = (MAGIC *) NULL;
4247 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4252 DIE("panic: do_split");
4253 rx = pm->op_pmregexp;
4255 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4256 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4258 if (pm->op_pmreplroot)
4259 ary = GvAVn((GV*)pm->op_pmreplroot);
4260 else if (gimme != G_ARRAY)
4262 ary = (AV*)PL_curpad[0];
4264 ary = GvAVn(PL_defgv);
4265 #endif /* USE_THREADS */
4268 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4274 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4281 for (i = AvFILLp(ary); i >= 0; i--)
4282 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4284 /* temporarily switch stacks */
4285 SWITCHSTACK(PL_curstack, ary);
4289 base = SP - PL_stack_base;
4291 if (pm->op_pmflags & PMf_SKIPWHITE) {
4292 if (pm->op_pmflags & PMf_LOCALE) {
4293 while (isSPACE_LC(*s))
4301 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4302 SAVEINT(PL_multiline);
4303 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4307 limit = maxiters + 2;
4308 if (pm->op_pmflags & PMf_WHITE) {
4311 while (m < strend &&
4312 !((pm->op_pmflags & PMf_LOCALE)
4313 ? isSPACE_LC(*m) : isSPACE(*m)))
4318 dstr = NEWSV(30, m-s);
4319 sv_setpvn(dstr, s, m-s);
4325 while (s < strend &&
4326 ((pm->op_pmflags & PMf_LOCALE)
4327 ? isSPACE_LC(*s) : isSPACE(*s)))
4331 else if (strEQ("^", rx->precomp)) {
4334 for (m = s; m < strend && *m != '\n'; m++) ;
4338 dstr = NEWSV(30, m-s);
4339 sv_setpvn(dstr, s, m-s);
4346 else if (rx->check_substr && !rx->nparens
4347 && (rx->reganch & ROPT_CHECK_ALL)
4348 && !(rx->reganch & ROPT_ANCH)) {
4349 i = SvCUR(rx->check_substr);
4350 if (i == 1 && !SvTAIL(rx->check_substr)) {
4351 i = *SvPVX(rx->check_substr);
4354 for (m = s; m < strend && *m != i; m++) ;
4357 dstr = NEWSV(30, m-s);
4358 sv_setpvn(dstr, s, m-s);
4367 while (s < strend && --limit &&
4368 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4369 rx->check_substr, 0)) )
4372 dstr = NEWSV(31, m-s);
4373 sv_setpvn(dstr, s, m-s);
4382 maxiters += (strend - s) * rx->nparens;
4383 while (s < strend && --limit &&
4384 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4386 TAINT_IF(RX_MATCH_TAINTED(rx));
4388 && rx->subbase != orig) {
4393 strend = s + (strend - m);
4396 dstr = NEWSV(32, m-s);
4397 sv_setpvn(dstr, s, m-s);
4402 for (i = 1; i <= rx->nparens; i++) {
4406 dstr = NEWSV(33, m-s);
4407 sv_setpvn(dstr, s, m-s);
4410 dstr = NEWSV(33, 0);
4420 LEAVE_SCOPE(oldsave);
4421 iters = (SP - PL_stack_base) - base;
4422 if (iters > maxiters)
4425 /* keep field after final delim? */
4426 if (s < strend || (iters && origlimit)) {
4427 dstr = NEWSV(34, strend-s);
4428 sv_setpvn(dstr, s, strend-s);
4434 else if (!origlimit) {
4435 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4441 SWITCHSTACK(ary, oldstack);
4442 if (SvSMAGICAL(ary)) {
4447 if (gimme == G_ARRAY) {
4449 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4457 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4460 if (gimme == G_ARRAY) {
4461 /* EXTEND should not be needed - we just popped them */
4463 for (i=0; i < iters; i++) {
4464 SV **svp = av_fetch(ary, i, FALSE);
4465 PUSHs((svp) ? *svp : &PL_sv_undef);
4472 if (gimme == G_ARRAY)
4475 if (iters || !pm->op_pmreplroot) {
4485 unlock_condpair(void *svv)
4488 MAGIC *mg = mg_find((SV*)svv, 'm');
4491 croak("panic: unlock_condpair unlocking non-mutex");
4492 MUTEX_LOCK(MgMUTEXP(mg));
4493 if (MgOWNER(mg) != thr)
4494 croak("panic: unlock_condpair unlocking mutex that we don't own");
4496 COND_SIGNAL(MgOWNERCONDP(mg));
4497 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4498 (unsigned long)thr, (unsigned long)svv);)
4499 MUTEX_UNLOCK(MgMUTEXP(mg));
4501 #endif /* USE_THREADS */
4514 mg = condpair_magic(sv);
4515 MUTEX_LOCK(MgMUTEXP(mg));
4516 if (MgOWNER(mg) == thr)
4517 MUTEX_UNLOCK(MgMUTEXP(mg));
4520 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4522 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4523 (unsigned long)thr, (unsigned long)sv);)
4524 MUTEX_UNLOCK(MgMUTEXP(mg));
4525 SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
4526 save_destructor(unlock_condpair, sv);
4528 #endif /* USE_THREADS */
4529 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4530 || SvTYPE(retsv) == SVt_PVCV) {
4531 retsv = refto(retsv);
4542 if (PL_op->op_private & OPpLVAL_INTRO)
4543 PUSHs(*save_threadsv(PL_op->op_targ));
4545 PUSHs(THREADSV(PL_op->op_targ));
4548 DIE("tried to access per-thread data in non-threaded perl");
4549 #endif /* USE_THREADS */