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))
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);
3665 sv_catpvn(sv, "\n", 1);
3669 is_an_int(char *s, STRLEN l)
3671 SV *result = newSVpv("", l);
3672 char *result_c = SvPV(result, PL_na); /* convenience */
3673 char *out = result_c;
3683 SvREFCNT_dec(result);
3706 SvREFCNT_dec(result);
3712 SvCUR_set(result, out - result_c);
3717 div128(SV *pnum, bool *done)
3718 /* must be '\0' terminated */
3722 char *s = SvPV(pnum, len);
3731 i = m * 10 + (*t - '0');
3733 r = (i >> 7); /* r < 10 */
3740 SvCUR_set(pnum, (STRLEN) (t - s));
3747 djSP; dMARK; dORIGMARK; dTARGET;
3748 register SV *cat = TARG;
3751 register char *pat = SvPVx(*++MARK, fromlen);
3752 register char *patend = pat + fromlen;
3757 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3758 static char *space10 = " ";
3760 /* These must not be in registers: */
3769 unsigned Quad_t auquad;
3778 sv_setpvn(cat, "", 0);
3779 while (pat < patend) {
3780 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
3781 datumtype = *pat++ & 0xFF;
3782 if (isSPACE(datumtype))
3785 len = strchr("@Xxu", datumtype) ? 0 : items;
3788 else if (isDIGIT(*pat)) {
3790 while (isDIGIT(*pat))
3791 len = (len * 10) + (*pat++ - '0');
3797 croak("Invalid type in pack: '%c'", (int)datumtype);
3798 case ',': /* grandfather in commas but with a warning */
3799 if (commas++ == 0 && PL_dowarn)
3800 warn("Invalid type in pack: '%c'", (int)datumtype);
3803 DIE("%% may only be used in unpack");
3814 if (SvCUR(cat) < len)
3815 DIE("X outside of string");
3822 sv_catpvn(cat, null10, 10);
3825 sv_catpvn(cat, null10, len);
3830 aptr = SvPV(fromstr, fromlen);
3834 sv_catpvn(cat, aptr, len);
3836 sv_catpvn(cat, aptr, fromlen);
3838 if (datumtype == 'A') {
3840 sv_catpvn(cat, space10, 10);
3843 sv_catpvn(cat, space10, len);
3847 sv_catpvn(cat, null10, 10);
3850 sv_catpvn(cat, null10, len);
3857 char *savepat = pat;
3862 aptr = SvPV(fromstr, fromlen);
3867 SvCUR(cat) += (len+7)/8;
3868 SvGROW(cat, SvCUR(cat) + 1);
3869 aptr = SvPVX(cat) + aint;
3874 if (datumtype == 'B') {
3875 for (len = 0; len++ < aint;) {
3876 items |= *pat++ & 1;
3880 *aptr++ = items & 0xff;
3886 for (len = 0; len++ < aint;) {
3892 *aptr++ = items & 0xff;
3898 if (datumtype == 'B')
3899 items <<= 7 - (aint & 7);
3901 items >>= 7 - (aint & 7);
3902 *aptr++ = items & 0xff;
3904 pat = SvPVX(cat) + SvCUR(cat);
3915 char *savepat = pat;
3920 aptr = SvPV(fromstr, fromlen);
3925 SvCUR(cat) += (len+1)/2;
3926 SvGROW(cat, SvCUR(cat) + 1);
3927 aptr = SvPVX(cat) + aint;
3932 if (datumtype == 'H') {
3933 for (len = 0; len++ < aint;) {
3935 items |= ((*pat++ & 15) + 9) & 15;
3937 items |= *pat++ & 15;
3941 *aptr++ = items & 0xff;
3947 for (len = 0; len++ < aint;) {
3949 items |= (((*pat++ & 15) + 9) & 15) << 4;
3951 items |= (*pat++ & 15) << 4;
3955 *aptr++ = items & 0xff;
3961 *aptr++ = items & 0xff;
3962 pat = SvPVX(cat) + SvCUR(cat);
3974 aint = SvIV(fromstr);
3976 sv_catpvn(cat, &achar, sizeof(char));
3979 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
3984 afloat = (float)SvNV(fromstr);
3985 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3992 adouble = (double)SvNV(fromstr);
3993 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3999 ashort = (I16)SvIV(fromstr);
4001 ashort = PerlSock_htons(ashort);
4003 CAT16(cat, &ashort);
4009 ashort = (I16)SvIV(fromstr);
4011 ashort = htovs(ashort);
4013 CAT16(cat, &ashort);
4020 ashort = (I16)SvIV(fromstr);
4021 CAT16(cat, &ashort);
4027 auint = SvUV(fromstr);
4028 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4034 adouble = floor(SvNV(fromstr));
4037 croak("Cannot compress negative numbers");
4043 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4044 adouble <= UV_MAX_cxux
4051 char buf[1 + sizeof(UV)];
4052 char *in = buf + sizeof(buf);
4053 UV auv = U_V(adouble);;
4056 *--in = (auv & 0x7f) | 0x80;
4059 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4060 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4062 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4063 char *from, *result, *in;
4068 /* Copy string and check for compliance */
4069 from = SvPV(fromstr, len);
4070 if ((norm = is_an_int(from, len)) == NULL)
4071 croak("can compress only unsigned integer");
4073 New('w', result, len, char);
4077 *--in = div128(norm, &done) | 0x80;
4078 result[len - 1] &= 0x7F; /* clear continue bit */
4079 sv_catpvn(cat, in, (result + len) - in);
4081 SvREFCNT_dec(norm); /* free norm */
4083 else if (SvNOKp(fromstr)) {
4084 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4085 char *in = buf + sizeof(buf);
4088 double next = floor(adouble / 128);
4089 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4090 if (--in < buf) /* this cannot happen ;-) */
4091 croak ("Cannot compress integer");
4093 } while (adouble > 0);
4094 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4095 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4098 croak("Cannot compress non integer");
4104 aint = SvIV(fromstr);
4105 sv_catpvn(cat, (char*)&aint, sizeof(int));
4111 aulong = SvUV(fromstr);
4113 aulong = PerlSock_htonl(aulong);
4115 CAT32(cat, &aulong);
4121 aulong = SvUV(fromstr);
4123 aulong = htovl(aulong);
4125 CAT32(cat, &aulong);
4131 aulong = SvUV(fromstr);
4132 CAT32(cat, &aulong);
4138 along = SvIV(fromstr);
4146 auquad = (unsigned Quad_t)SvIV(fromstr);
4147 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4153 aquad = (Quad_t)SvIV(fromstr);
4154 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4157 #endif /* HAS_QUAD */
4159 len = 1; /* assume SV is correct length */
4164 if (fromstr == &PL_sv_undef)
4167 /* XXX better yet, could spirit away the string to
4168 * a safe spot and hang on to it until the result
4169 * of pack() (and all copies of the result) are
4172 if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4173 warn("Attempt to pack pointer to temporary value");
4174 if (SvPOK(fromstr) || SvNIOK(fromstr))
4175 aptr = SvPV(fromstr,PL_na);
4177 aptr = SvPV_force(fromstr,PL_na);
4179 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4184 aptr = SvPV(fromstr, fromlen);
4185 SvGROW(cat, fromlen * 4 / 3);
4190 while (fromlen > 0) {
4197 doencodes(cat, aptr, todo);
4216 register I32 limit = POPi; /* note, negative is forever */
4219 register char *s = SvPV(sv, len);
4220 char *strend = s + len;
4222 register REGEXP *rx;
4226 I32 maxiters = (strend - s) + 10;
4229 I32 origlimit = limit;
4232 AV *oldstack = PL_curstack;
4233 I32 gimme = GIMME_V;
4234 I32 oldsave = PL_savestack_ix;
4235 I32 make_mortal = 1;
4236 MAGIC *mg = (MAGIC *) NULL;
4239 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4244 DIE("panic: do_split");
4245 rx = pm->op_pmregexp;
4247 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4248 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4250 if (pm->op_pmreplroot)
4251 ary = GvAVn((GV*)pm->op_pmreplroot);
4252 else if (gimme != G_ARRAY)
4254 ary = (AV*)PL_curpad[0];
4256 ary = GvAVn(PL_defgv);
4257 #endif /* USE_THREADS */
4260 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4266 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4273 for (i = AvFILLp(ary); i >= 0; i--)
4274 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4276 /* temporarily switch stacks */
4277 SWITCHSTACK(PL_curstack, ary);
4281 base = SP - PL_stack_base;
4283 if (pm->op_pmflags & PMf_SKIPWHITE) {
4284 if (pm->op_pmflags & PMf_LOCALE) {
4285 while (isSPACE_LC(*s))
4293 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4294 SAVEINT(PL_multiline);
4295 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4299 limit = maxiters + 2;
4300 if (pm->op_pmflags & PMf_WHITE) {
4303 while (m < strend &&
4304 !((pm->op_pmflags & PMf_LOCALE)
4305 ? isSPACE_LC(*m) : isSPACE(*m)))
4310 dstr = NEWSV(30, m-s);
4311 sv_setpvn(dstr, s, m-s);
4317 while (s < strend &&
4318 ((pm->op_pmflags & PMf_LOCALE)
4319 ? isSPACE_LC(*s) : isSPACE(*s)))
4323 else if (strEQ("^", rx->precomp)) {
4326 for (m = s; m < strend && *m != '\n'; m++) ;
4330 dstr = NEWSV(30, m-s);
4331 sv_setpvn(dstr, s, m-s);
4338 else if (rx->check_substr && !rx->nparens
4339 && (rx->reganch & ROPT_CHECK_ALL)
4340 && !(rx->reganch & ROPT_ANCH)) {
4341 i = SvCUR(rx->check_substr);
4342 if (i == 1 && !SvTAIL(rx->check_substr)) {
4343 i = *SvPVX(rx->check_substr);
4346 for (m = s; m < strend && *m != i; m++) ;
4349 dstr = NEWSV(30, m-s);
4350 sv_setpvn(dstr, s, m-s);
4359 while (s < strend && --limit &&
4360 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4361 rx->check_substr, 0)) )
4364 dstr = NEWSV(31, m-s);
4365 sv_setpvn(dstr, s, m-s);
4374 maxiters += (strend - s) * rx->nparens;
4375 while (s < strend && --limit &&
4376 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4378 TAINT_IF(RX_MATCH_TAINTED(rx));
4380 && rx->subbase != orig) {
4385 strend = s + (strend - m);
4388 dstr = NEWSV(32, m-s);
4389 sv_setpvn(dstr, s, m-s);
4394 for (i = 1; i <= rx->nparens; i++) {
4398 dstr = NEWSV(33, m-s);
4399 sv_setpvn(dstr, s, m-s);
4402 dstr = NEWSV(33, 0);
4412 LEAVE_SCOPE(oldsave);
4413 iters = (SP - PL_stack_base) - base;
4414 if (iters > maxiters)
4417 /* keep field after final delim? */
4418 if (s < strend || (iters && origlimit)) {
4419 dstr = NEWSV(34, strend-s);
4420 sv_setpvn(dstr, s, strend-s);
4426 else if (!origlimit) {
4427 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4433 SWITCHSTACK(ary, oldstack);
4434 if (SvSMAGICAL(ary)) {
4439 if (gimme == G_ARRAY) {
4441 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4449 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4452 if (gimme == G_ARRAY) {
4453 /* EXTEND should not be needed - we just popped them */
4455 for (i=0; i < iters; i++) {
4456 SV **svp = av_fetch(ary, i, FALSE);
4457 PUSHs((svp) ? *svp : &PL_sv_undef);
4464 if (gimme == G_ARRAY)
4467 if (iters || !pm->op_pmreplroot) {
4477 unlock_condpair(void *svv)
4480 MAGIC *mg = mg_find((SV*)svv, 'm');
4483 croak("panic: unlock_condpair unlocking non-mutex");
4484 MUTEX_LOCK(MgMUTEXP(mg));
4485 if (MgOWNER(mg) != thr)
4486 croak("panic: unlock_condpair unlocking mutex that we don't own");
4488 COND_SIGNAL(MgOWNERCONDP(mg));
4489 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4490 (unsigned long)thr, (unsigned long)svv);)
4491 MUTEX_UNLOCK(MgMUTEXP(mg));
4493 #endif /* USE_THREADS */
4506 mg = condpair_magic(sv);
4507 MUTEX_LOCK(MgMUTEXP(mg));
4508 if (MgOWNER(mg) == thr)
4509 MUTEX_UNLOCK(MgMUTEXP(mg));
4512 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4514 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4515 (unsigned long)thr, (unsigned long)sv);)
4516 MUTEX_UNLOCK(MgMUTEXP(mg));
4517 SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
4518 save_destructor(unlock_condpair, sv);
4520 #endif /* USE_THREADS */
4521 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4522 || SvTYPE(retsv) == SVt_PVCV) {
4523 retsv = refto(retsv);
4534 if (PL_op->op_private & OPpLVAL_INTRO)
4535 PUSHs(*save_threadsv(PL_op->op_targ));
4537 PUSHs(THREADSV(PL_op->op_targ));
4540 DIE("tried to access per-thread data in non-threaded perl");
4541 #endif /* USE_THREADS */