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. */
2916 I32 gimme = GIMME_V;
2920 register char *pat = SvPV(left, llen);
2921 register char *s = SvPV(right, rlen);
2922 char *strend = s + rlen;
2924 register char *patend = pat + llen;
2929 /* These must not be in registers: */
2940 unsigned Quad_t auquad;
2946 register U32 culong;
2948 static char* bitcount = 0;
2951 if (gimme != G_ARRAY) { /* arrange to do first one only */
2953 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
2954 if (strchr("aAbBhHP", *patend) || *pat == '%') {
2956 while (isDIGIT(*patend) || *patend == '*')
2962 while (pat < patend) {
2964 datumtype = *pat++ & 0xFF;
2965 if (isSPACE(datumtype))
2969 else if (*pat == '*') {
2970 len = strend - strbeg; /* long enough */
2973 else if (isDIGIT(*pat)) {
2975 while (isDIGIT(*pat))
2976 len = (len * 10) + (*pat++ - '0');
2979 len = (datumtype != '@');
2982 croak("Invalid type in unpack: '%c'", (int)datumtype);
2983 case ',': /* grandfather in commas but with a warning */
2984 if (commas++ == 0 && PL_dowarn)
2985 warn("Invalid type in unpack: '%c'", (int)datumtype);
2988 if (len == 1 && pat[-1] != '1')
2997 if (len > strend - strbeg)
2998 DIE("@ outside of string");
3002 if (len > s - strbeg)
3003 DIE("X outside of string");
3007 if (len > strend - s)
3008 DIE("x outside of string");
3013 if (len > strend - s)
3016 goto uchar_checksum;
3017 sv = NEWSV(35, len);
3018 sv_setpvn(sv, s, len);
3020 if (datumtype == 'A') {
3021 aptr = s; /* borrow register */
3022 s = SvPVX(sv) + len - 1;
3023 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3026 SvCUR_set(sv, s - SvPVX(sv));
3027 s = aptr; /* unborrow register */
3029 XPUSHs(sv_2mortal(sv));
3033 if (pat[-1] == '*' || len > (strend - s) * 8)
3034 len = (strend - s) * 8;
3037 Newz(601, bitcount, 256, char);
3038 for (bits = 1; bits < 256; bits++) {
3039 if (bits & 1) bitcount[bits]++;
3040 if (bits & 2) bitcount[bits]++;
3041 if (bits & 4) bitcount[bits]++;
3042 if (bits & 8) bitcount[bits]++;
3043 if (bits & 16) bitcount[bits]++;
3044 if (bits & 32) bitcount[bits]++;
3045 if (bits & 64) bitcount[bits]++;
3046 if (bits & 128) bitcount[bits]++;
3050 culong += bitcount[*(unsigned char*)s++];
3055 if (datumtype == 'b') {
3057 if (bits & 1) culong++;
3063 if (bits & 128) culong++;
3070 sv = NEWSV(35, len + 1);
3073 aptr = pat; /* borrow register */
3075 if (datumtype == 'b') {
3077 for (len = 0; len < aint; len++) {
3078 if (len & 7) /*SUPPRESS 595*/
3082 *pat++ = '0' + (bits & 1);
3087 for (len = 0; len < aint; len++) {
3092 *pat++ = '0' + ((bits & 128) != 0);
3096 pat = aptr; /* unborrow register */
3097 XPUSHs(sv_2mortal(sv));
3101 if (pat[-1] == '*' || len > (strend - s) * 2)
3102 len = (strend - s) * 2;
3103 sv = NEWSV(35, len + 1);
3106 aptr = pat; /* borrow register */
3108 if (datumtype == 'h') {
3110 for (len = 0; len < aint; len++) {
3115 *pat++ = PL_hexdigit[bits & 15];
3120 for (len = 0; len < aint; len++) {
3125 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3129 pat = aptr; /* unborrow register */
3130 XPUSHs(sv_2mortal(sv));
3133 if (len > strend - s)
3138 if (aint >= 128) /* fake up signed chars */
3148 if (aint >= 128) /* fake up signed chars */
3151 sv_setiv(sv, (IV)aint);
3152 PUSHs(sv_2mortal(sv));
3157 if (len > strend - s)
3172 sv_setiv(sv, (IV)auint);
3173 PUSHs(sv_2mortal(sv));
3178 along = (strend - s) / SIZE16;
3195 sv_setiv(sv, (IV)ashort);
3196 PUSHs(sv_2mortal(sv));
3203 along = (strend - s) / SIZE16;
3208 COPY16(s, &aushort);
3211 if (datumtype == 'n')
3212 aushort = PerlSock_ntohs(aushort);
3215 if (datumtype == 'v')
3216 aushort = vtohs(aushort);
3225 COPY16(s, &aushort);
3229 if (datumtype == 'n')
3230 aushort = PerlSock_ntohs(aushort);
3233 if (datumtype == 'v')
3234 aushort = vtohs(aushort);
3236 sv_setiv(sv, (IV)aushort);
3237 PUSHs(sv_2mortal(sv));
3242 along = (strend - s) / sizeof(int);
3247 Copy(s, &aint, 1, int);
3250 cdouble += (double)aint;
3259 Copy(s, &aint, 1, int);
3263 /* Without the dummy below unpack("i", pack("i",-1))
3264 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3265 * cc with optimization turned on */
3267 sv_setiv(sv, (IV)aint) :
3269 sv_setiv(sv, (IV)aint);
3270 PUSHs(sv_2mortal(sv));
3275 along = (strend - s) / sizeof(unsigned int);
3280 Copy(s, &auint, 1, unsigned int);
3281 s += sizeof(unsigned int);
3283 cdouble += (double)auint;
3292 Copy(s, &auint, 1, unsigned int);
3293 s += sizeof(unsigned int);
3295 sv_setuv(sv, (UV)auint);
3296 PUSHs(sv_2mortal(sv));
3301 along = (strend - s) / SIZE32;
3309 cdouble += (double)along;
3321 sv_setiv(sv, (IV)along);
3322 PUSHs(sv_2mortal(sv));
3329 along = (strend - s) / SIZE32;
3337 if (datumtype == 'N')
3338 aulong = PerlSock_ntohl(aulong);
3341 if (datumtype == 'V')
3342 aulong = vtohl(aulong);
3345 cdouble += (double)aulong;
3357 if (datumtype == 'N')
3358 aulong = PerlSock_ntohl(aulong);
3361 if (datumtype == 'V')
3362 aulong = vtohl(aulong);
3365 sv_setuv(sv, (UV)aulong);
3366 PUSHs(sv_2mortal(sv));
3371 along = (strend - s) / sizeof(char*);
3377 if (sizeof(char*) > strend - s)
3380 Copy(s, &aptr, 1, char*);
3386 PUSHs(sv_2mortal(sv));
3396 while ((len > 0) && (s < strend)) {
3397 auv = (auv << 7) | (*s & 0x7f);
3398 if (!(*s++ & 0x80)) {
3402 PUSHs(sv_2mortal(sv));
3406 else if (++bytes >= sizeof(UV)) { /* promote to string */
3409 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3410 while (s < strend) {
3411 sv = mul128(sv, *s & 0x7f);
3412 if (!(*s++ & 0x80)) {
3417 t = SvPV(sv, PL_na);
3421 PUSHs(sv_2mortal(sv));
3426 if ((s >= strend) && bytes)
3427 croak("Unterminated compressed integer");
3432 if (sizeof(char*) > strend - s)
3435 Copy(s, &aptr, 1, char*);
3440 sv_setpvn(sv, aptr, len);
3441 PUSHs(sv_2mortal(sv));
3445 along = (strend - s) / sizeof(Quad_t);
3451 if (s + sizeof(Quad_t) > strend)
3454 Copy(s, &aquad, 1, Quad_t);
3455 s += sizeof(Quad_t);
3458 if (aquad >= IV_MIN && aquad <= IV_MAX)
3459 sv_setiv(sv, (IV)aquad);
3461 sv_setnv(sv, (double)aquad);
3462 PUSHs(sv_2mortal(sv));
3466 along = (strend - s) / sizeof(Quad_t);
3472 if (s + sizeof(unsigned Quad_t) > strend)
3475 Copy(s, &auquad, 1, unsigned Quad_t);
3476 s += sizeof(unsigned Quad_t);
3479 if (auquad <= UV_MAX)
3480 sv_setuv(sv, (UV)auquad);
3482 sv_setnv(sv, (double)auquad);
3483 PUSHs(sv_2mortal(sv));
3487 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3490 along = (strend - s) / sizeof(float);
3495 Copy(s, &afloat, 1, float);
3504 Copy(s, &afloat, 1, float);
3507 sv_setnv(sv, (double)afloat);
3508 PUSHs(sv_2mortal(sv));
3514 along = (strend - s) / sizeof(double);
3519 Copy(s, &adouble, 1, double);
3520 s += sizeof(double);
3528 Copy(s, &adouble, 1, double);
3529 s += sizeof(double);
3531 sv_setnv(sv, (double)adouble);
3532 PUSHs(sv_2mortal(sv));
3537 along = (strend - s) * 3 / 4;
3538 sv = NEWSV(42, along);
3541 while (s < strend && *s > ' ' && *s < 'a') {
3546 len = (*s++ - ' ') & 077;
3548 if (s < strend && *s >= ' ')
3549 a = (*s++ - ' ') & 077;
3552 if (s < strend && *s >= ' ')
3553 b = (*s++ - ' ') & 077;
3556 if (s < strend && *s >= ' ')
3557 c = (*s++ - ' ') & 077;
3560 if (s < strend && *s >= ' ')
3561 d = (*s++ - ' ') & 077;
3564 hunk[0] = (a << 2) | (b >> 4);
3565 hunk[1] = (b << 4) | (c >> 2);
3566 hunk[2] = (c << 6) | d;
3567 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3572 else if (s[1] == '\n') /* possible checksum byte */
3575 XPUSHs(sv_2mortal(sv));
3580 if (strchr("fFdD", datumtype) ||
3581 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3585 while (checksum >= 16) {
3589 while (checksum >= 4) {
3595 along = (1 << checksum) - 1;
3596 while (cdouble < 0.0)
3598 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3599 sv_setnv(sv, cdouble);
3602 if (checksum < 32) {
3603 aulong = (1 << checksum) - 1;
3606 sv_setuv(sv, (UV)culong);
3608 XPUSHs(sv_2mortal(sv));
3612 if (SP == oldsp && gimme == G_SCALAR)
3613 PUSHs(&PL_sv_undef);
3618 doencodes(register SV *sv, register char *s, register I32 len)
3623 sv_catpvn(sv, hunk, 1);
3626 hunk[0] = ' ' + (077 & (*s >> 2));
3627 hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
3628 hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
3629 hunk[3] = ' ' + (077 & (s[2] & 077));
3630 sv_catpvn(sv, hunk, 4);
3634 for (s = SvPVX(sv); *s; s++) {
3638 sv_catpvn(sv, "\n", 1);
3642 is_an_int(char *s, STRLEN l)
3644 SV *result = newSVpv("", l);
3645 char *result_c = SvPV(result, PL_na); /* convenience */
3646 char *out = result_c;
3656 SvREFCNT_dec(result);
3679 SvREFCNT_dec(result);
3685 SvCUR_set(result, out - result_c);
3690 div128(SV *pnum, bool *done)
3691 /* must be '\0' terminated */
3695 char *s = SvPV(pnum, len);
3704 i = m * 10 + (*t - '0');
3706 r = (i >> 7); /* r < 10 */
3713 SvCUR_set(pnum, (STRLEN) (t - s));
3720 djSP; dMARK; dORIGMARK; dTARGET;
3721 register SV *cat = TARG;
3724 register char *pat = SvPVx(*++MARK, fromlen);
3725 register char *patend = pat + fromlen;
3730 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3731 static char *space10 = " ";
3733 /* These must not be in registers: */
3742 unsigned Quad_t auquad;
3751 sv_setpvn(cat, "", 0);
3752 while (pat < patend) {
3753 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
3754 datumtype = *pat++ & 0xFF;
3755 if (isSPACE(datumtype))
3758 len = strchr("@Xxu", datumtype) ? 0 : items;
3761 else if (isDIGIT(*pat)) {
3763 while (isDIGIT(*pat))
3764 len = (len * 10) + (*pat++ - '0');
3770 croak("Invalid type in pack: '%c'", (int)datumtype);
3771 case ',': /* grandfather in commas but with a warning */
3772 if (commas++ == 0 && PL_dowarn)
3773 warn("Invalid type in pack: '%c'", (int)datumtype);
3776 DIE("%% may only be used in unpack");
3787 if (SvCUR(cat) < len)
3788 DIE("X outside of string");
3795 sv_catpvn(cat, null10, 10);
3798 sv_catpvn(cat, null10, len);
3803 aptr = SvPV(fromstr, fromlen);
3807 sv_catpvn(cat, aptr, len);
3809 sv_catpvn(cat, aptr, fromlen);
3811 if (datumtype == 'A') {
3813 sv_catpvn(cat, space10, 10);
3816 sv_catpvn(cat, space10, len);
3820 sv_catpvn(cat, null10, 10);
3823 sv_catpvn(cat, null10, len);
3830 char *savepat = pat;
3835 aptr = SvPV(fromstr, fromlen);
3840 SvCUR(cat) += (len+7)/8;
3841 SvGROW(cat, SvCUR(cat) + 1);
3842 aptr = SvPVX(cat) + aint;
3847 if (datumtype == 'B') {
3848 for (len = 0; len++ < aint;) {
3849 items |= *pat++ & 1;
3853 *aptr++ = items & 0xff;
3859 for (len = 0; len++ < aint;) {
3865 *aptr++ = items & 0xff;
3871 if (datumtype == 'B')
3872 items <<= 7 - (aint & 7);
3874 items >>= 7 - (aint & 7);
3875 *aptr++ = items & 0xff;
3877 pat = SvPVX(cat) + SvCUR(cat);
3888 char *savepat = pat;
3893 aptr = SvPV(fromstr, fromlen);
3898 SvCUR(cat) += (len+1)/2;
3899 SvGROW(cat, SvCUR(cat) + 1);
3900 aptr = SvPVX(cat) + aint;
3905 if (datumtype == 'H') {
3906 for (len = 0; len++ < aint;) {
3908 items |= ((*pat++ & 15) + 9) & 15;
3910 items |= *pat++ & 15;
3914 *aptr++ = items & 0xff;
3920 for (len = 0; len++ < aint;) {
3922 items |= (((*pat++ & 15) + 9) & 15) << 4;
3924 items |= (*pat++ & 15) << 4;
3928 *aptr++ = items & 0xff;
3934 *aptr++ = items & 0xff;
3935 pat = SvPVX(cat) + SvCUR(cat);
3947 aint = SvIV(fromstr);
3949 sv_catpvn(cat, &achar, sizeof(char));
3952 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
3957 afloat = (float)SvNV(fromstr);
3958 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3965 adouble = (double)SvNV(fromstr);
3966 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3972 ashort = (I16)SvIV(fromstr);
3974 ashort = PerlSock_htons(ashort);
3976 CAT16(cat, &ashort);
3982 ashort = (I16)SvIV(fromstr);
3984 ashort = htovs(ashort);
3986 CAT16(cat, &ashort);
3993 ashort = (I16)SvIV(fromstr);
3994 CAT16(cat, &ashort);
4000 auint = SvUV(fromstr);
4001 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4007 adouble = floor(SvNV(fromstr));
4010 croak("Cannot compress negative numbers");
4016 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4017 adouble <= UV_MAX_cxux
4024 char buf[1 + sizeof(UV)];
4025 char *in = buf + sizeof(buf);
4026 UV auv = U_V(adouble);;
4029 *--in = (auv & 0x7f) | 0x80;
4032 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4033 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4035 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4036 char *from, *result, *in;
4041 /* Copy string and check for compliance */
4042 from = SvPV(fromstr, len);
4043 if ((norm = is_an_int(from, len)) == NULL)
4044 croak("can compress only unsigned integer");
4046 New('w', result, len, char);
4050 *--in = div128(norm, &done) | 0x80;
4051 result[len - 1] &= 0x7F; /* clear continue bit */
4052 sv_catpvn(cat, in, (result + len) - in);
4054 SvREFCNT_dec(norm); /* free norm */
4056 else if (SvNOKp(fromstr)) {
4057 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4058 char *in = buf + sizeof(buf);
4061 double next = floor(adouble / 128);
4062 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4063 if (--in < buf) /* this cannot happen ;-) */
4064 croak ("Cannot compress integer");
4066 } while (adouble > 0);
4067 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4068 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4071 croak("Cannot compress non integer");
4077 aint = SvIV(fromstr);
4078 sv_catpvn(cat, (char*)&aint, sizeof(int));
4084 aulong = SvUV(fromstr);
4086 aulong = PerlSock_htonl(aulong);
4088 CAT32(cat, &aulong);
4094 aulong = SvUV(fromstr);
4096 aulong = htovl(aulong);
4098 CAT32(cat, &aulong);
4104 aulong = SvUV(fromstr);
4105 CAT32(cat, &aulong);
4111 along = SvIV(fromstr);
4119 auquad = (unsigned Quad_t)SvIV(fromstr);
4120 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4126 aquad = (Quad_t)SvIV(fromstr);
4127 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4130 #endif /* HAS_QUAD */
4132 len = 1; /* assume SV is correct length */
4137 if (fromstr == &PL_sv_undef)
4140 /* XXX better yet, could spirit away the string to
4141 * a safe spot and hang on to it until the result
4142 * of pack() (and all copies of the result) are
4145 if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4146 warn("Attempt to pack pointer to temporary value");
4147 if (SvPOK(fromstr) || SvNIOK(fromstr))
4148 aptr = SvPV(fromstr,PL_na);
4150 aptr = SvPV_force(fromstr,PL_na);
4152 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4157 aptr = SvPV(fromstr, fromlen);
4158 SvGROW(cat, fromlen * 4 / 3);
4163 while (fromlen > 0) {
4170 doencodes(cat, aptr, todo);
4189 register I32 limit = POPi; /* note, negative is forever */
4192 register char *s = SvPV(sv, len);
4193 char *strend = s + len;
4195 register REGEXP *rx;
4199 I32 maxiters = (strend - s) + 10;
4202 I32 origlimit = limit;
4205 AV *oldstack = PL_curstack;
4206 I32 gimme = GIMME_V;
4207 I32 oldsave = PL_savestack_ix;
4208 I32 make_mortal = 1;
4209 MAGIC *mg = (MAGIC *) NULL;
4212 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4217 DIE("panic: do_split");
4218 rx = pm->op_pmregexp;
4220 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4221 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4223 if (pm->op_pmreplroot)
4224 ary = GvAVn((GV*)pm->op_pmreplroot);
4225 else if (gimme != G_ARRAY)
4227 ary = (AV*)PL_curpad[0];
4229 ary = GvAVn(PL_defgv);
4230 #endif /* USE_THREADS */
4233 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4239 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4246 for (i = AvFILLp(ary); i >= 0; i--)
4247 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4249 /* temporarily switch stacks */
4250 SWITCHSTACK(PL_curstack, ary);
4254 base = SP - PL_stack_base;
4256 if (pm->op_pmflags & PMf_SKIPWHITE) {
4257 if (pm->op_pmflags & PMf_LOCALE) {
4258 while (isSPACE_LC(*s))
4266 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4267 SAVEINT(PL_multiline);
4268 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4272 limit = maxiters + 2;
4273 if (pm->op_pmflags & PMf_WHITE) {
4276 while (m < strend &&
4277 !((pm->op_pmflags & PMf_LOCALE)
4278 ? isSPACE_LC(*m) : isSPACE(*m)))
4283 dstr = NEWSV(30, m-s);
4284 sv_setpvn(dstr, s, m-s);
4290 while (s < strend &&
4291 ((pm->op_pmflags & PMf_LOCALE)
4292 ? isSPACE_LC(*s) : isSPACE(*s)))
4296 else if (strEQ("^", rx->precomp)) {
4299 for (m = s; m < strend && *m != '\n'; m++) ;
4303 dstr = NEWSV(30, m-s);
4304 sv_setpvn(dstr, s, m-s);
4311 else if (rx->check_substr && !rx->nparens
4312 && (rx->reganch & ROPT_CHECK_ALL)
4313 && !(rx->reganch & ROPT_ANCH)) {
4314 i = SvCUR(rx->check_substr);
4315 if (i == 1 && !SvTAIL(rx->check_substr)) {
4316 i = *SvPVX(rx->check_substr);
4319 for (m = s; m < strend && *m != i; m++) ;
4322 dstr = NEWSV(30, m-s);
4323 sv_setpvn(dstr, s, m-s);
4332 while (s < strend && --limit &&
4333 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4334 rx->check_substr, 0)) )
4337 dstr = NEWSV(31, m-s);
4338 sv_setpvn(dstr, s, m-s);
4347 maxiters += (strend - s) * rx->nparens;
4348 while (s < strend && --limit &&
4349 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4351 TAINT_IF(RX_MATCH_TAINTED(rx));
4353 && rx->subbase != orig) {
4358 strend = s + (strend - m);
4361 dstr = NEWSV(32, m-s);
4362 sv_setpvn(dstr, s, m-s);
4367 for (i = 1; i <= rx->nparens; i++) {
4371 dstr = NEWSV(33, m-s);
4372 sv_setpvn(dstr, s, m-s);
4375 dstr = NEWSV(33, 0);
4385 LEAVE_SCOPE(oldsave);
4386 iters = (SP - PL_stack_base) - base;
4387 if (iters > maxiters)
4390 /* keep field after final delim? */
4391 if (s < strend || (iters && origlimit)) {
4392 dstr = NEWSV(34, strend-s);
4393 sv_setpvn(dstr, s, strend-s);
4399 else if (!origlimit) {
4400 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4406 SWITCHSTACK(ary, oldstack);
4407 if (SvSMAGICAL(ary)) {
4412 if (gimme == G_ARRAY) {
4414 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4422 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4425 if (gimme == G_ARRAY) {
4426 /* EXTEND should not be needed - we just popped them */
4428 for (i=0; i < iters; i++) {
4429 SV **svp = av_fetch(ary, i, FALSE);
4430 PUSHs((svp) ? *svp : &PL_sv_undef);
4437 if (gimme == G_ARRAY)
4440 if (iters || !pm->op_pmreplroot) {
4450 unlock_condpair(void *svv)
4453 MAGIC *mg = mg_find((SV*)svv, 'm');
4456 croak("panic: unlock_condpair unlocking non-mutex");
4457 MUTEX_LOCK(MgMUTEXP(mg));
4458 if (MgOWNER(mg) != thr)
4459 croak("panic: unlock_condpair unlocking mutex that we don't own");
4461 COND_SIGNAL(MgOWNERCONDP(mg));
4462 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4463 (unsigned long)thr, (unsigned long)svv);)
4464 MUTEX_UNLOCK(MgMUTEXP(mg));
4466 #endif /* USE_THREADS */
4479 mg = condpair_magic(sv);
4480 MUTEX_LOCK(MgMUTEXP(mg));
4481 if (MgOWNER(mg) == thr)
4482 MUTEX_UNLOCK(MgMUTEXP(mg));
4485 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4487 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4488 (unsigned long)thr, (unsigned long)sv);)
4489 MUTEX_UNLOCK(MgMUTEXP(mg));
4490 SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
4491 save_destructor(unlock_condpair, sv);
4493 #endif /* USE_THREADS */
4494 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4495 || SvTYPE(retsv) == SVt_PVCV) {
4496 retsv = refto(retsv);
4507 if (PL_op->op_private & OPpLVAL_INTRO)
4508 PUSHs(*save_threadsv(PL_op->op_targ));
4510 PUSHs(THREADSV(PL_op->op_targ));
4513 DIE("tried to access per-thread data in non-threaded perl");
4514 #endif /* USE_THREADS */