3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
8 * $FreeBSD: src/contrib/perl5/pp.c,v 1.2 1999/12/13 19:11:53 ache Exp $
9 * $DragonFly: src/contrib/perl5/Attic/pp.c,v 1.2 2003/06/17 04:24:05 dillon Exp $
13 * "It's a big house this, and very peculiar. Always a bit more to discover,
14 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
21 * The compiler on Concurrent CX/UX systems has a subtle bug which only
22 * seems to show up when compiling pp.c - it generates the wrong double
23 * precision constant value for (double)UV_MAX when used inline in the body
24 * of the code below, so this makes a static variable up front (which the
25 * compiler seems to get correct) and uses it in place of UV_MAX below.
27 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
28 static double UV_MAX_cxux = ((double)UV_MAX);
32 * Types used in bitwise operations.
34 * Normally we'd just use IV and UV. However, some hardware and
35 * software combinations (e.g. Alpha and current OSF/1) don't have a
36 * floating-point type to use for NV that has adequate bits to fully
37 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
39 * It just so happens that "int" is the right size almost everywhere.
45 * Mask used after bitwise operations.
47 * There is at least one realm (Cray word machines) that doesn't
48 * have an integral type (except char) small enough to be represented
49 * in a double without loss; that is, it has no 32-bit type.
51 #if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
53 # define BW_MASK ((1 << BW_BITS) - 1)
54 # define BW_SIGN (1 << (BW_BITS - 1))
55 # define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
56 # define BWu(u) ((u) & BW_MASK)
63 * Offset for integer pack/unpack.
65 * On architectures where I16 and I32 aren't really 16 and 32 bits,
66 * which for now are all Crays, pack and unpack have to play games.
70 * These values are required for portability of pack() output.
71 * If they're not right on your machine, then pack() and unpack()
72 * wouldn't work right anyway; you'll need to apply the Cray hack.
73 * (I'd like to check them with #if, but you can't use sizeof() in
74 * the preprocessor.) --???
77 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
78 defines are now in config.h. --Andy Dougherty April 1998
83 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
84 # if BYTEORDER == 0x12345678
85 # define OFF16(p) (char*)(p)
86 # define OFF32(p) (char*)(p)
88 # if BYTEORDER == 0x87654321
89 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
90 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
92 }}}} bad cray byte order
95 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
96 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
97 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
98 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
100 # define COPY16(s,p) Copy(s, p, SIZE16, char)
101 # define COPY32(s,p) Copy(s, p, SIZE32, char)
102 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
103 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
107 static void doencodes _((SV* sv, char* s, I32 len));
108 static SV* refto _((SV* sv));
109 static U32 seed _((void));
110 static bool srand_called = FALSE;
114 /* variations on pp_null */
120 /* XXX I can't imagine anyone who doesn't have this actually _needs_
121 it, since pid_t is an integral type.
124 #ifdef NEED_GETPID_PROTO
125 extern Pid_t getpid (void);
131 if (GIMME_V == G_SCALAR)
132 XPUSHs(&PL_sv_undef);
146 if (PL_op->op_private & OPpLVAL_INTRO)
147 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
149 if (PL_op->op_flags & OPf_REF) {
153 if (GIMME == G_ARRAY) {
154 I32 maxarg = AvFILL((AV*)TARG) + 1;
156 if (SvMAGICAL(TARG)) {
158 for (i=0; i < maxarg; i++) {
159 SV **svp = av_fetch((AV*)TARG, i, FALSE);
160 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
164 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
169 SV* sv = sv_newmortal();
170 I32 maxarg = AvFILL((AV*)TARG) + 1;
171 sv_setiv(sv, maxarg);
183 if (PL_op->op_private & OPpLVAL_INTRO)
184 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
185 if (PL_op->op_flags & OPf_REF)
188 if (gimme == G_ARRAY) {
189 RETURNOP(do_kv(ARGS));
191 else if (gimme == G_SCALAR) {
192 SV* sv = sv_newmortal();
193 if (HvFILL((HV*)TARG))
194 sv_setpvf(sv, "%ld/%ld",
195 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
205 DIE("NOT IMPL LINE %d",__LINE__);
217 if (SvTYPE(sv) == SVt_PVIO) {
218 GV *gv = (GV*) sv_newmortal();
219 gv_init(gv, 0, "", 0, 0);
220 GvIOp(gv) = (IO *)sv;
221 (void)SvREFCNT_inc(sv);
223 } else if (SvTYPE(sv) != SVt_PVGV)
224 DIE("Not a GLOB reference");
227 if (SvTYPE(sv) != SVt_PVGV) {
231 if (SvGMAGICAL(sv)) {
237 if (PL_op->op_flags & OPf_REF ||
238 PL_op->op_private & HINT_STRICT_REFS)
239 DIE(no_usym, "a symbol");
245 if (PL_op->op_private & HINT_STRICT_REFS)
246 DIE(no_symref, sym, "a symbol");
247 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
250 if (PL_op->op_private & OPpLVAL_INTRO)
251 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
263 switch (SvTYPE(sv)) {
267 DIE("Not a SCALAR reference");
275 if (SvTYPE(gv) != SVt_PVGV) {
276 if (SvGMAGICAL(sv)) {
282 if (PL_op->op_flags & OPf_REF ||
283 PL_op->op_private & HINT_STRICT_REFS)
284 DIE(no_usym, "a SCALAR");
290 if (PL_op->op_private & HINT_STRICT_REFS)
291 DIE(no_symref, sym, "a SCALAR");
292 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
296 if (PL_op->op_flags & OPf_MOD) {
297 if (PL_op->op_private & OPpLVAL_INTRO)
298 sv = save_scalar((GV*)TOPs);
299 else if (PL_op->op_private & OPpDEREF)
300 vivify_ref(sv, PL_op->op_private & OPpDEREF);
310 SV *sv = AvARYLEN(av);
312 AvARYLEN(av) = sv = NEWSV(0,0);
313 sv_upgrade(sv, SVt_IV);
314 sv_magic(sv, (SV*)av, '#', Nullch, 0);
322 djSP; dTARGET; dPOPss;
324 if (PL_op->op_flags & OPf_MOD) {
325 if (SvTYPE(TARG) < SVt_PVLV) {
326 sv_upgrade(TARG, SVt_PVLV);
327 sv_magic(TARG, Nullsv, '.', Nullch, 0);
331 if (LvTARG(TARG) != sv) {
333 SvREFCNT_dec(LvTARG(TARG));
334 LvTARG(TARG) = SvREFCNT_inc(sv);
336 PUSHs(TARG); /* no SvSETMAGIC */
342 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
343 mg = mg_find(sv, 'g');
344 if (mg && mg->mg_len >= 0) {
345 PUSHi(mg->mg_len + PL_curcop->cop_arybase);
359 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
360 /* (But not in defined().) */
361 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
364 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
367 cv = (CV*)&PL_sv_undef;
381 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
382 char *s = SvPVX(TOPs);
383 if (strnEQ(s, "CORE::", 6)) {
386 code = keyword(s + 6, SvCUR(TOPs) - 6);
387 if (code < 0) { /* Overridable. */
388 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
389 int i = 0, n = 0, seen_question = 0;
391 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
393 while (i < MAXO) { /* The slow way. */
394 if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
398 goto nonesuch; /* Should not happen... */
400 oa = opargs[i] >> OASHIFT;
402 if (oa & OA_OPTIONAL) {
405 } else if (seen_question)
406 goto set; /* XXXX system, exec */
407 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
408 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
411 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
412 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
416 ret = sv_2mortal(newSVpv(str, n - 1));
417 } else if (code) /* Non-Overridable */
419 else { /* None such */
421 croak("Cannot find an opnumber for \"%s\"", s+6);
425 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
427 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
436 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
438 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
454 if (GIMME != G_ARRAY) {
458 *MARK = &PL_sv_undef;
459 *MARK = refto(*MARK);
463 EXTEND_MORTAL(SP - MARK);
465 *MARK = refto(*MARK);
474 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
477 if (!(sv = LvTARG(sv)))
480 else if (SvPADTMP(sv))
484 (void)SvREFCNT_inc(sv);
487 sv_upgrade(rv, SVt_RV);
501 if (sv && SvGMAGICAL(sv))
504 if (!sv || !SvROK(sv))
508 pv = sv_reftype(sv,TRUE);
509 PUSHp(pv, strlen(pv));
519 stash = PL_curcop->cop_stash;
523 char *ptr = SvPV(ssv,len);
524 if (PL_dowarn && len == 0)
525 warn("Explicit blessing to '' (assuming package main)");
526 stash = gv_stashpvn(ptr, len, TRUE);
529 (void)sv_bless(TOPs, stash);
543 elem = SvPV(sv, n_a);
547 switch (elem ? *elem : '\0')
550 if (strEQ(elem, "ARRAY"))
551 tmpRef = (SV*)GvAV(gv);
554 if (strEQ(elem, "CODE"))
555 tmpRef = (SV*)GvCVu(gv);
558 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
559 tmpRef = (SV*)GvIOp(gv);
562 if (strEQ(elem, "GLOB"))
566 if (strEQ(elem, "HASH"))
567 tmpRef = (SV*)GvHV(gv);
570 if (strEQ(elem, "IO"))
571 tmpRef = (SV*)GvIOp(gv);
574 if (strEQ(elem, "NAME"))
575 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
578 if (strEQ(elem, "PACKAGE"))
579 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
582 if (strEQ(elem, "SCALAR"))
596 /* Pattern matching */
601 register UNOP *unop = cUNOP;
602 register unsigned char *s;
605 register I32 *sfirst;
609 if (sv == PL_lastscream) {
615 SvSCREAM_off(PL_lastscream);
616 SvREFCNT_dec(PL_lastscream);
618 PL_lastscream = SvREFCNT_inc(sv);
621 s = (unsigned char*)(SvPV(sv, len));
625 if (pos > PL_maxscream) {
626 if (PL_maxscream < 0) {
627 PL_maxscream = pos + 80;
628 New(301, PL_screamfirst, 256, I32);
629 New(302, PL_screamnext, PL_maxscream, I32);
632 PL_maxscream = pos + pos / 4;
633 Renew(PL_screamnext, PL_maxscream, I32);
637 sfirst = PL_screamfirst;
638 snext = PL_screamnext;
640 if (!sfirst || !snext)
641 DIE("do_study: out of memory");
643 for (ch = 256; ch; --ch)
650 snext[pos] = sfirst[ch] - pos;
657 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
666 if (PL_op->op_flags & OPf_STACKED)
672 TARG = sv_newmortal();
673 PUSHi(do_trans(sv, PL_op));
677 /* Lvalue operators. */
689 djSP; dMARK; dTARGET;
699 SETi(do_chomp(TOPs));
705 djSP; dMARK; dTARGET;
706 register I32 count = 0;
709 count += do_chomp(POPs);
720 if (!sv || !SvANY(sv))
722 switch (SvTYPE(sv)) {
724 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
728 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
732 if (CvROOT(sv) || CvXSUB(sv))
749 if (!PL_op->op_private) {
758 if (SvTHINKFIRST(sv)) {
759 if (SvREADONLY(sv)) {
761 if (PL_curcop != &PL_compiling)
768 switch (SvTYPE(sv)) {
778 if (PL_dowarn && cv_const_sv((CV*)sv))
779 warn("Constant subroutine %s undefined",
780 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
783 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
785 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
789 SvSetMagicSV(sv, &PL_sv_undef);
793 Newz(602, gp, 1, GP);
794 GvGP(sv) = gp_ref(gp);
795 GvSV(sv) = NEWSV(72,0);
796 GvLINE(sv) = PL_curcop->cop_line;
802 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
805 SvPV_set(sv, Nullch);
818 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
820 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
821 SvIVX(TOPs) != IV_MIN)
824 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
835 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
837 sv_setsv(TARG, TOPs);
838 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
839 SvIVX(TOPs) != IV_MAX)
842 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
856 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
858 sv_setsv(TARG, TOPs);
859 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
860 SvIVX(TOPs) != IV_MIN)
863 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 /* Ordinary operators. */
876 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
879 SETn( pow( left, right) );
886 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
889 SETn( left * right );
896 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
901 DIE("Illegal division by zero");
903 /* insure that 20./5. == 4. */
906 if ((double)I_V(left) == left &&
907 (double)I_V(right) == right &&
908 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
911 value = left / right;
915 value = left / right;
924 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
932 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
934 right = (right_neg = (i < 0)) ? -i : i;
938 right = U_V((right_neg = (n < 0)) ? -n : n);
941 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
943 left = (left_neg = (i < 0)) ? -i : i;
947 left = U_V((left_neg = (n < 0)) ? -n : n);
951 DIE("Illegal modulus zero");
954 if ((left_neg != right_neg) && ans)
957 /* XXX may warn: unary minus operator applied to unsigned type */
958 /* could change -foo to be (~foo)+1 instead */
959 if (ans <= ~((UV)IV_MAX)+1)
960 sv_setiv(TARG, ~ans+1);
962 sv_setnv(TARG, -(double)ans);
973 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
975 register I32 count = POPi;
976 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
978 I32 items = SP - MARK;
990 repeatcpy((char*)(MARK + items), (char*)MARK,
991 items * sizeof(SV*), count - 1);
997 else { /* Note: mark already snarfed by pp_list */
1002 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1003 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1004 DIE("Can't x= to readonly value");
1008 SvSetSV(TARG, tmpstr);
1009 SvPV_force(TARG, len);
1014 SvGROW(TARG, (count * len) + 1);
1015 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1016 SvCUR(TARG) *= count;
1018 *SvEND(TARG) = '\0';
1020 (void)SvPOK_only(TARG);
1029 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1032 SETn( left - right );
1039 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1042 if (PL_op->op_private & HINT_INTEGER) {
1044 i = BWi(i) << shift;
1058 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1061 if (PL_op->op_private & HINT_INTEGER) {
1063 i = BWi(i) >> shift;
1077 djSP; tryAMAGICbinSET(lt,0);
1080 SETs(boolSV(TOPn < value));
1087 djSP; tryAMAGICbinSET(gt,0);
1090 SETs(boolSV(TOPn > value));
1097 djSP; tryAMAGICbinSET(le,0);
1100 SETs(boolSV(TOPn <= value));
1107 djSP; tryAMAGICbinSET(ge,0);
1110 SETs(boolSV(TOPn >= value));
1117 djSP; tryAMAGICbinSET(ne,0);
1120 SETs(boolSV(TOPn != value));
1127 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1134 else if (left < right)
1136 else if (left > right)
1149 djSP; tryAMAGICbinSET(slt,0);
1152 int cmp = ((PL_op->op_private & OPpLOCALE)
1153 ? sv_cmp_locale(left, right)
1154 : sv_cmp(left, right));
1155 SETs(boolSV(cmp < 0));
1162 djSP; tryAMAGICbinSET(sgt,0);
1165 int cmp = ((PL_op->op_private & OPpLOCALE)
1166 ? sv_cmp_locale(left, right)
1167 : sv_cmp(left, right));
1168 SETs(boolSV(cmp > 0));
1175 djSP; tryAMAGICbinSET(sle,0);
1178 int cmp = ((PL_op->op_private & OPpLOCALE)
1179 ? sv_cmp_locale(left, right)
1180 : sv_cmp(left, right));
1181 SETs(boolSV(cmp <= 0));
1188 djSP; tryAMAGICbinSET(sge,0);
1191 int cmp = ((PL_op->op_private & OPpLOCALE)
1192 ? sv_cmp_locale(left, right)
1193 : sv_cmp(left, right));
1194 SETs(boolSV(cmp >= 0));
1201 djSP; tryAMAGICbinSET(seq,0);
1204 SETs(boolSV(sv_eq(left, right)));
1211 djSP; tryAMAGICbinSET(sne,0);
1214 SETs(boolSV(!sv_eq(left, right)));
1221 djSP; dTARGET; tryAMAGICbin(scmp,0);
1224 int cmp = ((PL_op->op_private & OPpLOCALE)
1225 ? sv_cmp_locale(left, right)
1226 : sv_cmp(left, right));
1234 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1237 if (SvNIOKp(left) || SvNIOKp(right)) {
1238 if (PL_op->op_private & HINT_INTEGER) {
1239 IBW value = SvIV(left) & SvIV(right);
1243 UBW value = SvUV(left) & SvUV(right);
1248 do_vop(PL_op->op_type, TARG, left, right);
1257 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1260 if (SvNIOKp(left) || SvNIOKp(right)) {
1261 if (PL_op->op_private & HINT_INTEGER) {
1262 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1266 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1271 do_vop(PL_op->op_type, TARG, left, right);
1280 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1283 if (SvNIOKp(left) || SvNIOKp(right)) {
1284 if (PL_op->op_private & HINT_INTEGER) {
1285 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1289 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1294 do_vop(PL_op->op_type, TARG, left, right);
1303 djSP; dTARGET; tryAMAGICun(neg);
1308 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1310 else if (SvNIOKp(sv))
1312 else if (SvPOKp(sv)) {
1314 char *s = SvPV(sv, len);
1315 if (isIDFIRST(*s)) {
1316 sv_setpvn(TARG, "-", 1);
1319 else if (*s == '+' || *s == '-') {
1321 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1324 sv_setnv(TARG, -SvNV(sv));
1336 djSP; tryAMAGICunSET(not);
1337 #endif /* OVERLOAD */
1338 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1344 djSP; dTARGET; tryAMAGICun(compl);
1348 if (PL_op->op_private & HINT_INTEGER) {
1349 IBW value = ~SvIV(sv);
1353 UBW value = ~SvUV(sv);
1358 register char *tmps;
1359 register long *tmpl;
1364 tmps = SvPV_force(TARG, len);
1367 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1370 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1374 for ( ; anum > 0; anum--, tmps++)
1383 /* integer versions of some of the above */
1387 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1390 SETi( left * right );
1397 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1401 DIE("Illegal division by zero");
1402 value = POPi / value;
1410 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1414 DIE("Illegal modulus zero");
1415 SETi( left % right );
1422 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1425 SETi( left + right );
1432 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1435 SETi( left - right );
1442 djSP; tryAMAGICbinSET(lt,0);
1445 SETs(boolSV(left < right));
1452 djSP; tryAMAGICbinSET(gt,0);
1455 SETs(boolSV(left > right));
1462 djSP; tryAMAGICbinSET(le,0);
1465 SETs(boolSV(left <= right));
1472 djSP; tryAMAGICbinSET(ge,0);
1475 SETs(boolSV(left >= right));
1482 djSP; tryAMAGICbinSET(eq,0);
1485 SETs(boolSV(left == right));
1492 djSP; tryAMAGICbinSET(ne,0);
1495 SETs(boolSV(left != right));
1502 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1509 else if (left < right)
1520 djSP; dTARGET; tryAMAGICun(neg);
1525 /* High falutin' math. */
1529 djSP; dTARGET; tryAMAGICbin(atan2,0);
1532 SETn(atan2(left, right));
1539 djSP; dTARGET; tryAMAGICun(sin);
1551 djSP; dTARGET; tryAMAGICun(cos);
1561 /* Support Configure command-line overrides for rand() functions.
1562 After 5.005, perhaps we should replace this by Configure support
1563 for drand48(), random(), or rand(). For 5.005, though, maintain
1564 compatibility by calling rand() but allow the user to override it.
1565 See INSTALL for details. --Andy Dougherty 15 July 1998
1568 # define my_rand rand
1571 # define my_srand srand
1584 if (!srand_called) {
1585 (void)my_srand((unsigned)seed());
1586 srand_called = TRUE;
1589 value = my_rand() * value / 2147483648.0;
1592 value = my_rand() * value / 65536.0;
1595 value = my_rand() * value / 32768.0;
1597 value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
1613 (void)my_srand((unsigned)anum);
1614 srand_called = TRUE;
1623 * This is really just a quick hack which grabs various garbage
1624 * values. It really should be a real hash algorithm which
1625 * spreads the effect of every input bit onto every output bit,
1626 * if someone who knows about such tings would bother to write it.
1627 * Might be a good idea to add that function to CORE as well.
1628 * No numbers below come from careful analysis or anyting here,
1629 * except they are primes and SEED_C1 > 1E6 to get a full-width
1630 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1631 * probably be bigger too.
1634 # define SEED_C1 1000003
1635 #define SEED_C4 73819
1637 # define SEED_C1 25747
1638 #define SEED_C4 20639
1642 #define SEED_C5 26107
1645 #ifndef PERL_NO_DEV_RANDOM
1650 # include <starlet.h>
1651 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1652 * in 100-ns units, typically incremented ever 10 ms. */
1653 unsigned int when[2];
1655 # ifdef HAS_GETTIMEOFDAY
1656 struct timeval when;
1662 /* This test is an escape hatch, this symbol isn't set by Configure. */
1663 #ifndef PERL_NO_DEV_RANDOM
1664 #ifndef PERL_RANDOM_DEVICE
1665 /* /dev/random isn't used by default because reads from it will block
1666 * if there isn't enough entropy available. You can compile with
1667 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1668 * is enough real entropy to fill the seed. */
1669 # define PERL_RANDOM_DEVICE "/dev/urandom"
1671 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1673 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1682 _ckvmssts(sys$gettim(when));
1683 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1685 # ifdef HAS_GETTIMEOFDAY
1686 gettimeofday(&when,(struct timezone *) 0);
1687 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1690 u = (U32)SEED_C1 * when;
1693 u += SEED_C3 * (U32)getpid();
1694 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1695 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1696 u += SEED_C5 * (U32)(UV)&when;
1703 djSP; dTARGET; tryAMAGICun(exp);
1715 djSP; dTARGET; tryAMAGICun(log);
1720 SET_NUMERIC_STANDARD();
1721 DIE("Can't take log of %g", value);
1731 djSP; dTARGET; tryAMAGICun(sqrt);
1736 SET_NUMERIC_STANDARD();
1737 DIE("Can't take sqrt of %g", value);
1739 value = sqrt(value);
1749 double value = TOPn;
1752 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1758 (void)modf(value, &value);
1760 (void)modf(-value, &value);
1775 djSP; dTARGET; tryAMAGICun(abs);
1777 double value = TOPn;
1780 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1781 (iv = SvIVX(TOPs)) != IV_MIN) {
1803 XPUSHu(scan_hex(tmps, 99, &argtype));
1816 while (*tmps && isSPACE(*tmps))
1821 value = scan_hex(++tmps, 99, &argtype);
1823 value = scan_oct(tmps, 99, &argtype);
1833 SETi( sv_len(TOPs) );
1846 I32 lvalue = PL_op->op_flags & OPf_MOD;
1848 I32 arybase = PL_curcop->cop_arybase;
1852 SvTAINTED_off(TARG); /* decontaminate */
1856 repl = SvPV(sv, repl_len);
1863 tmps = SvPV(sv, curlen);
1864 if (pos >= arybase) {
1882 else if (len >= 0) {
1884 if (rem > (I32)curlen)
1898 if (PL_dowarn || lvalue || repl)
1899 warn("substr outside of string");
1904 sv_setpvn(TARG, tmps, rem);
1905 if (lvalue) { /* it's an lvalue! */
1906 if (!SvGMAGICAL(sv)) {
1911 warn("Attempt to use reference as lvalue in substr");
1913 if (SvOK(sv)) /* is it defined ? */
1914 (void)SvPOK_only(sv);
1916 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1919 if (SvTYPE(TARG) < SVt_PVLV) {
1920 sv_upgrade(TARG, SVt_PVLV);
1921 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1925 if (LvTARG(TARG) != sv) {
1927 SvREFCNT_dec(LvTARG(TARG));
1928 LvTARG(TARG) = SvREFCNT_inc(sv);
1930 LvTARGOFF(TARG) = pos;
1931 LvTARGLEN(TARG) = rem;
1934 sv_insert(sv, pos, rem, repl, repl_len);
1937 PUSHs(TARG); /* avoid SvSETMAGIC here */
1944 register I32 size = POPi;
1945 register I32 offset = POPi;
1946 register SV *src = POPs;
1947 I32 lvalue = PL_op->op_flags & OPf_MOD;
1949 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1950 unsigned long retnum;
1953 SvTAINTED_off(TARG); /* decontaminate */
1954 offset *= size; /* turn into bit offset */
1955 len = (offset + size + 7) / 8;
1956 if (offset < 0 || size < 1)
1959 if (lvalue) { /* it's an lvalue! */
1960 if (SvTYPE(TARG) < SVt_PVLV) {
1961 sv_upgrade(TARG, SVt_PVLV);
1962 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1966 if (LvTARG(TARG) != src) {
1968 SvREFCNT_dec(LvTARG(TARG));
1969 LvTARG(TARG) = SvREFCNT_inc(src);
1971 LvTARGOFF(TARG) = offset;
1972 LvTARGLEN(TARG) = size;
1980 if (offset >= srclen)
1983 retnum = (unsigned long) s[offset] << 8;
1985 else if (size == 32) {
1986 if (offset >= srclen)
1988 else if (offset + 1 >= srclen)
1989 retnum = (unsigned long) s[offset] << 24;
1990 else if (offset + 2 >= srclen)
1991 retnum = ((unsigned long) s[offset] << 24) +
1992 ((unsigned long) s[offset + 1] << 16);
1994 retnum = ((unsigned long) s[offset] << 24) +
1995 ((unsigned long) s[offset + 1] << 16) +
1996 (s[offset + 2] << 8);
2001 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2006 else if (size == 16)
2007 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2008 else if (size == 32)
2009 retnum = ((unsigned long) s[offset] << 24) +
2010 ((unsigned long) s[offset + 1] << 16) +
2011 (s[offset + 2] << 8) + s[offset+3];
2015 sv_setuv(TARG, (UV)retnum);
2030 I32 arybase = PL_curcop->cop_arybase;
2035 offset = POPi - arybase;
2038 tmps = SvPV(big, biglen);
2041 else if (offset > biglen)
2043 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2044 (unsigned char*)tmps + biglen, little, 0)))
2045 retval = -1 + arybase;
2047 retval = tmps2 - tmps + arybase;
2064 I32 arybase = PL_curcop->cop_arybase;
2070 tmps2 = SvPV(little, llen);
2071 tmps = SvPV(big, blen);
2075 offset = SvIV(offstr) - arybase + llen;
2078 else if (offset > blen)
2080 if (!(tmps2 = rninstr(tmps, tmps + offset,
2081 tmps2, tmps2 + llen)))
2082 retval = -1 + arybase;
2084 retval = tmps2 - tmps + arybase;
2091 djSP; dMARK; dORIGMARK; dTARGET;
2092 #ifdef USE_LOCALE_NUMERIC
2093 if (PL_op->op_private & OPpLOCALE)
2094 SET_NUMERIC_LOCAL();
2096 SET_NUMERIC_STANDARD();
2098 do_sprintf(TARG, SP-MARK, MARK+1);
2099 TAINT_IF(SvTAINTED(TARG));
2114 value = (I32) (*tmps & 255);
2119 value = (I32) (anum & 255);
2130 (void)SvUPGRADE(TARG,SVt_PV);
2136 (void)SvPOK_only(TARG);
2143 djSP; dTARGET; dPOPTOPssrl;
2146 char *tmps = SvPV(left, n_a);
2148 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2150 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2154 "The crypt() function is unimplemented due to excessive paranoia.");
2167 if (!SvPADTMP(sv)) {
2173 s = SvPV_force(sv, n_a);
2175 if (PL_op->op_private & OPpLOCALE) {
2178 *s = toUPPER_LC(*s);
2195 if (!SvPADTMP(sv)) {
2201 s = SvPV_force(sv, n_a);
2203 if (PL_op->op_private & OPpLOCALE) {
2206 *s = toLOWER_LC(*s);
2225 if (!SvPADTMP(sv)) {
2232 s = SvPV_force(sv, len);
2234 register char *send = s + len;
2236 if (PL_op->op_private & OPpLOCALE) {
2239 for (; s < send; s++)
2240 *s = toUPPER_LC(*s);
2243 for (; s < send; s++)
2259 if (!SvPADTMP(sv)) {
2266 s = SvPV_force(sv, len);
2268 register char *send = s + len;
2270 if (PL_op->op_private & OPpLOCALE) {
2273 for (; s < send; s++)
2274 *s = toLOWER_LC(*s);
2277 for (; s < send; s++)
2291 register char *s = SvPV(sv,len);
2295 (void)SvUPGRADE(TARG, SVt_PV);
2296 SvGROW(TARG, (len * 2) + 1);
2304 SvCUR_set(TARG, d - SvPVX(TARG));
2305 (void)SvPOK_only(TARG);
2308 sv_setpvn(TARG, s, len);
2310 if (SvSMAGICAL(TARG))
2319 djSP; dMARK; dORIGMARK;
2321 register AV* av = (AV*)POPs;
2322 register I32 lval = PL_op->op_flags & OPf_MOD;
2323 I32 arybase = PL_curcop->cop_arybase;
2326 if (SvTYPE(av) == SVt_PVAV) {
2327 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2329 for (svp = MARK + 1; svp <= SP; svp++) {
2334 if (max > AvMAX(av))
2337 while (++MARK <= SP) {
2338 elem = SvIVx(*MARK);
2342 svp = av_fetch(av, elem, lval);
2344 if (!svp || *svp == &PL_sv_undef)
2345 DIE(no_aelem, elem);
2346 if (PL_op->op_private & OPpLVAL_INTRO)
2347 save_aelem(av, elem, svp);
2349 *MARK = svp ? *svp : &PL_sv_undef;
2352 if (GIMME != G_ARRAY) {
2360 /* Associative arrays. */
2365 HV *hash = (HV*)POPs;
2367 I32 gimme = GIMME_V;
2368 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2371 /* might clobber stack_sp */
2372 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2377 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2378 if (gimme == G_ARRAY) {
2380 /* might clobber stack_sp */
2381 sv_setsv(TARG, realhv ?
2382 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2387 else if (gimme == G_SCALAR)
2406 I32 gimme = GIMME_V;
2407 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2411 if (PL_op->op_private & OPpSLICE) {
2415 hvtype = SvTYPE(hv);
2416 while (++MARK <= SP) {
2417 if (hvtype == SVt_PVHV)
2418 sv = hv_delete_ent(hv, *MARK, discard, 0);
2420 DIE("Not a HASH reference");
2421 *MARK = sv ? sv : &PL_sv_undef;
2425 else if (gimme == G_SCALAR) {
2434 if (SvTYPE(hv) == SVt_PVHV)
2435 sv = hv_delete_ent(hv, keysv, discard, 0);
2437 DIE("Not a HASH reference");
2451 if (SvTYPE(hv) == SVt_PVHV) {
2452 if (hv_exists_ent(hv, tmpsv, 0))
2454 } else if (SvTYPE(hv) == SVt_PVAV) {
2455 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2458 DIE("Not a HASH reference");
2465 djSP; dMARK; dORIGMARK;
2466 register HV *hv = (HV*)POPs;
2467 register I32 lval = PL_op->op_flags & OPf_MOD;
2468 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2470 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2471 DIE("Can't localize pseudo-hash element");
2473 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2474 while (++MARK <= SP) {
2478 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2479 svp = he ? &HeVAL(he) : 0;
2481 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2484 if (!svp || *svp == &PL_sv_undef) {
2486 DIE(no_helem, SvPV(keysv, n_a));
2488 if (PL_op->op_private & OPpLVAL_INTRO)
2489 save_helem(hv, keysv, svp);
2491 *MARK = svp ? *svp : &PL_sv_undef;
2494 if (GIMME != G_ARRAY) {
2502 /* List operators. */
2507 if (GIMME != G_ARRAY) {
2509 *MARK = *SP; /* unwanted list, return last item */
2511 *MARK = &PL_sv_undef;
2520 SV **lastrelem = PL_stack_sp;
2521 SV **lastlelem = PL_stack_base + POPMARK;
2522 SV **firstlelem = PL_stack_base + POPMARK + 1;
2523 register SV **firstrelem = lastlelem + 1;
2524 I32 arybase = PL_curcop->cop_arybase;
2525 I32 lval = PL_op->op_flags & OPf_MOD;
2526 I32 is_something_there = lval;
2528 register I32 max = lastrelem - lastlelem;
2529 register SV **lelem;
2532 if (GIMME != G_ARRAY) {
2533 ix = SvIVx(*lastlelem);
2538 if (ix < 0 || ix >= max)
2539 *firstlelem = &PL_sv_undef;
2541 *firstlelem = firstrelem[ix];
2547 SP = firstlelem - 1;
2551 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2556 *lelem = &PL_sv_undef;
2557 else if (!(*lelem = firstrelem[ix]))
2558 *lelem = &PL_sv_undef;
2562 if (ix >= max || !(*lelem = firstrelem[ix]))
2563 *lelem = &PL_sv_undef;
2565 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2566 is_something_there = TRUE;
2568 if (is_something_there)
2571 SP = firstlelem - 1;
2577 djSP; dMARK; dORIGMARK;
2578 I32 items = SP - MARK;
2579 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2580 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2587 djSP; dMARK; dORIGMARK;
2588 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2592 SV *val = NEWSV(46, 0);
2594 sv_setsv(val, *++MARK);
2596 warn("Odd number of elements in hash assignment");
2597 (void)hv_store_ent(hv,key,val,0);
2606 djSP; dMARK; dORIGMARK;
2607 register AV *ary = (AV*)*++MARK;
2611 register I32 offset;
2612 register I32 length;
2619 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2620 *MARK-- = SvTIED_obj((SV*)ary, mg);
2624 perl_call_method("SPLICE",GIMME_V);
2633 offset = i = SvIVx(*MARK);
2635 offset += AvFILLp(ary) + 1;
2637 offset -= PL_curcop->cop_arybase;
2641 length = SvIVx(*MARK++);
2643 length += AvFILLp(ary) - offset + 1;
2649 length = AvMAX(ary) + 1; /* close enough to infinity */
2653 length = AvMAX(ary) + 1;
2655 if (offset > AvFILLp(ary) + 1)
2656 offset = AvFILLp(ary) + 1;
2657 after = AvFILLp(ary) + 1 - (offset + length);
2658 if (after < 0) { /* not that much array */
2659 length += after; /* offset+length now in array */
2665 /* At this point, MARK .. SP-1 is our new LIST */
2668 diff = newlen - length;
2669 if (newlen && !AvREAL(ary)) {
2673 assert(AvREAL(ary)); /* would leak, so croak */
2676 if (diff < 0) { /* shrinking the area */
2678 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2679 Copy(MARK, tmparyval, newlen, SV*);
2682 MARK = ORIGMARK + 1;
2683 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2684 MEXTEND(MARK, length);
2685 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2687 EXTEND_MORTAL(length);
2688 for (i = length, dst = MARK; i; i--) {
2689 sv_2mortal(*dst); /* free them eventualy */
2696 *MARK = AvARRAY(ary)[offset+length-1];
2699 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2700 SvREFCNT_dec(*dst++); /* free them now */
2703 AvFILLp(ary) += diff;
2705 /* pull up or down? */
2707 if (offset < after) { /* easier to pull up */
2708 if (offset) { /* esp. if nothing to pull */
2709 src = &AvARRAY(ary)[offset-1];
2710 dst = src - diff; /* diff is negative */
2711 for (i = offset; i > 0; i--) /* can't trust Copy */
2715 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2719 if (after) { /* anything to pull down? */
2720 src = AvARRAY(ary) + offset + length;
2721 dst = src + diff; /* diff is negative */
2722 Move(src, dst, after, SV*);
2724 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2725 /* avoid later double free */
2729 dst[--i] = &PL_sv_undef;
2732 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2734 *dst = NEWSV(46, 0);
2735 sv_setsv(*dst++, *src++);
2737 Safefree(tmparyval);
2740 else { /* no, expanding (or same) */
2742 New(452, tmparyval, length, SV*); /* so remember deletion */
2743 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2746 if (diff > 0) { /* expanding */
2748 /* push up or down? */
2750 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2754 Move(src, dst, offset, SV*);
2756 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2758 AvFILLp(ary) += diff;
2761 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2762 av_extend(ary, AvFILLp(ary) + diff);
2763 AvFILLp(ary) += diff;
2766 dst = AvARRAY(ary) + AvFILLp(ary);
2768 for (i = after; i; i--) {
2775 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2776 *dst = NEWSV(46, 0);
2777 sv_setsv(*dst++, *src++);
2779 MARK = ORIGMARK + 1;
2780 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2782 Copy(tmparyval, MARK, length, SV*);
2784 EXTEND_MORTAL(length);
2785 for (i = length, dst = MARK; i; i--) {
2786 sv_2mortal(*dst); /* free them eventualy */
2790 Safefree(tmparyval);
2794 else if (length--) {
2795 *MARK = tmparyval[length];
2798 while (length-- > 0)
2799 SvREFCNT_dec(tmparyval[length]);
2801 Safefree(tmparyval);
2804 *MARK = &PL_sv_undef;
2812 djSP; dMARK; dORIGMARK; dTARGET;
2813 register AV *ary = (AV*)*++MARK;
2814 register SV *sv = &PL_sv_undef;
2817 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2818 *MARK-- = SvTIED_obj((SV*)ary, mg);
2822 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2827 /* Why no pre-extend of ary here ? */
2828 for (++MARK; MARK <= SP; MARK++) {
2831 sv_setsv(sv, *MARK);
2836 PUSHi( AvFILL(ary) + 1 );
2844 SV *sv = av_pop(av);
2846 (void)sv_2mortal(sv);
2855 SV *sv = av_shift(av);
2860 (void)sv_2mortal(sv);
2867 djSP; dMARK; dORIGMARK; dTARGET;
2868 register AV *ary = (AV*)*++MARK;
2873 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2874 *MARK-- = SvTIED_obj((SV*)ary, mg);
2878 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2883 av_unshift(ary, SP - MARK);
2886 sv_setsv(sv, *++MARK);
2887 (void)av_store(ary, i++, sv);
2891 PUSHi( AvFILL(ary) + 1 );
2901 if (GIMME == G_ARRAY) {
2912 register char *down;
2918 do_join(TARG, &PL_sv_no, MARK, SP);
2920 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
2921 up = SvPV_force(TARG, len);
2923 down = SvPVX(TARG) + len - 1;
2929 (void)SvPOK_only(TARG);
2938 mul128(SV *sv, U8 m)
2941 char *s = SvPV(sv, len);
2945 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
2946 SV *tmpNew = newSVpv("0000000000", 10);
2948 sv_catsv(tmpNew, sv);
2949 SvREFCNT_dec(sv); /* free old sv */
2954 while (!*t) /* trailing '\0'? */
2957 i = ((*t - '0') << 7) + m;
2958 *(t--) = '0' + (i % 10);
2964 /* Explosives and implosives. */
2966 static const char uuemap[] =
2967 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
2969 static char uudmap[256]; /* Initialised on first use */
2971 #if 'I' == 73 && 'J' == 74
2972 /* On an ASCII/ISO kind of system */
2973 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
2976 Some other sort of character set - use memchr() so we don't match
2979 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
2987 I32 gimme = GIMME_V;
2991 register char *pat = SvPV(left, llen);
2992 register char *s = SvPV(right, rlen);
2993 char *strend = s + rlen;
2995 register char *patend = pat + llen;
3000 /* These must not be in registers: */
3011 unsigned Quad_t auquad;
3017 register U32 culong;
3020 static char* bitcount = 0;
3024 if (gimme != G_ARRAY) { /* arrange to do first one only */
3026 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3027 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3029 while (isDIGIT(*patend) || *patend == '*')
3035 while (pat < patend) {
3037 datumtype = *pat++ & 0xFF;
3038 if (isSPACE(datumtype))
3042 else if (*pat == '*') {
3043 len = strend - strbeg; /* long enough */
3046 else if (isDIGIT(*pat)) {
3048 while (isDIGIT(*pat))
3049 len = (len * 10) + (*pat++ - '0');
3052 len = (datumtype != '@');
3055 croak("Invalid type in unpack: '%c'", (int)datumtype);
3056 case ',': /* grandfather in commas but with a warning */
3057 if (commas++ == 0 && PL_dowarn)
3058 warn("Invalid type in unpack: '%c'", (int)datumtype);
3061 if (len == 1 && pat[-1] != '1')
3070 if (len > strend - strbeg)
3071 DIE("@ outside of string");
3075 if (len > s - strbeg)
3076 DIE("X outside of string");
3080 if (len > strend - s)
3081 DIE("x outside of string");
3087 if (len > strend - s)
3090 goto uchar_checksum;
3091 sv = NEWSV(35, len);
3092 sv_setpvn(sv, s, len);
3094 if (datumtype == 'A' || datumtype == 'Z') {
3095 aptr = s; /* borrow register */
3096 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3101 else { /* 'A' strips both nulls and spaces */
3102 s = SvPVX(sv) + len - 1;
3103 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3107 SvCUR_set(sv, s - SvPVX(sv));
3108 s = aptr; /* unborrow register */
3110 XPUSHs(sv_2mortal(sv));
3114 if (pat[-1] == '*' || len > (strend - s) * 8)
3115 len = (strend - s) * 8;
3118 Newz(601, bitcount, 256, char);
3119 for (bits = 1; bits < 256; bits++) {
3120 if (bits & 1) bitcount[bits]++;
3121 if (bits & 2) bitcount[bits]++;
3122 if (bits & 4) bitcount[bits]++;
3123 if (bits & 8) bitcount[bits]++;
3124 if (bits & 16) bitcount[bits]++;
3125 if (bits & 32) bitcount[bits]++;
3126 if (bits & 64) bitcount[bits]++;
3127 if (bits & 128) bitcount[bits]++;
3131 culong += bitcount[*(unsigned char*)s++];
3136 if (datumtype == 'b') {
3138 if (bits & 1) culong++;
3144 if (bits & 128) culong++;
3151 sv = NEWSV(35, len + 1);
3154 aptr = pat; /* borrow register */
3156 if (datumtype == 'b') {
3158 for (len = 0; len < aint; len++) {
3159 if (len & 7) /*SUPPRESS 595*/
3163 *pat++ = '0' + (bits & 1);
3168 for (len = 0; len < aint; len++) {
3173 *pat++ = '0' + ((bits & 128) != 0);
3177 pat = aptr; /* unborrow register */
3178 XPUSHs(sv_2mortal(sv));
3182 if (pat[-1] == '*' || len > (strend - s) * 2)
3183 len = (strend - s) * 2;
3184 sv = NEWSV(35, len + 1);
3187 aptr = pat; /* borrow register */
3189 if (datumtype == 'h') {
3191 for (len = 0; len < aint; len++) {
3196 *pat++ = PL_hexdigit[bits & 15];
3201 for (len = 0; len < aint; len++) {
3206 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3210 pat = aptr; /* unborrow register */
3211 XPUSHs(sv_2mortal(sv));
3214 if (len > strend - s)
3219 if (aint >= 128) /* fake up signed chars */
3229 if (aint >= 128) /* fake up signed chars */
3232 sv_setiv(sv, (IV)aint);
3233 PUSHs(sv_2mortal(sv));
3238 if (len > strend - s)
3253 sv_setiv(sv, (IV)auint);
3254 PUSHs(sv_2mortal(sv));
3259 along = (strend - s) / SIZE16;
3265 #if SHORTSIZE > SIZE16
3278 #if SHORTSIZE > SIZE16
3284 sv_setiv(sv, (IV)ashort);
3285 PUSHs(sv_2mortal(sv));
3292 along = (strend - s) / SIZE16;
3297 COPY16(s, &aushort);
3300 if (datumtype == 'n')
3301 aushort = PerlSock_ntohs(aushort);
3304 if (datumtype == 'v')
3305 aushort = vtohs(aushort);
3314 COPY16(s, &aushort);
3318 if (datumtype == 'n')
3319 aushort = PerlSock_ntohs(aushort);
3322 if (datumtype == 'v')
3323 aushort = vtohs(aushort);
3325 sv_setiv(sv, (IV)aushort);
3326 PUSHs(sv_2mortal(sv));
3331 along = (strend - s) / sizeof(int);
3336 Copy(s, &aint, 1, int);
3339 cdouble += (double)aint;
3348 Copy(s, &aint, 1, int);
3352 /* Without the dummy below unpack("i", pack("i",-1))
3353 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3354 * cc with optimization turned on */
3356 sv_setiv(sv, (IV)aint) :
3358 sv_setiv(sv, (IV)aint);
3359 PUSHs(sv_2mortal(sv));
3364 along = (strend - s) / sizeof(unsigned int);
3369 Copy(s, &auint, 1, unsigned int);
3370 s += sizeof(unsigned int);
3372 cdouble += (double)auint;
3381 Copy(s, &auint, 1, unsigned int);
3382 s += sizeof(unsigned int);
3385 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3386 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3387 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3388 * with optimization turned on.
3389 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3390 * does not have this problem even with -O4)
3393 sv_setuv(sv, (UV)auint) :
3395 sv_setuv(sv, (UV)auint);
3396 PUSHs(sv_2mortal(sv));
3401 along = (strend - s) / SIZE32;
3407 #if LONGSIZE > SIZE32
3408 if (along > 2147483647)
3409 along -= 4294967296;
3413 cdouble += (double)along;
3423 #if LONGSIZE > SIZE32
3424 if (along > 2147483647)
3425 along -= 4294967296;
3429 sv_setiv(sv, (IV)along);
3430 PUSHs(sv_2mortal(sv));
3437 along = (strend - s) / SIZE32;
3445 if (datumtype == 'N')
3446 aulong = PerlSock_ntohl(aulong);
3449 if (datumtype == 'V')
3450 aulong = vtohl(aulong);
3453 cdouble += (double)aulong;
3465 if (datumtype == 'N')
3466 aulong = PerlSock_ntohl(aulong);
3469 if (datumtype == 'V')
3470 aulong = vtohl(aulong);
3473 sv_setuv(sv, (UV)aulong);
3474 PUSHs(sv_2mortal(sv));
3479 along = (strend - s) / sizeof(char*);
3485 if (sizeof(char*) > strend - s)
3488 Copy(s, &aptr, 1, char*);
3494 PUSHs(sv_2mortal(sv));
3504 while ((len > 0) && (s < strend)) {
3505 auv = (auv << 7) | (*s & 0x7f);
3506 if (!(*s++ & 0x80)) {
3510 PUSHs(sv_2mortal(sv));
3514 else if (++bytes >= sizeof(UV)) { /* promote to string */
3518 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3519 while (s < strend) {
3520 sv = mul128(sv, *s & 0x7f);
3521 if (!(*s++ & 0x80)) {
3530 PUSHs(sv_2mortal(sv));
3535 if ((s >= strend) && bytes)
3536 croak("Unterminated compressed integer");
3541 if (sizeof(char*) > strend - s)
3544 Copy(s, &aptr, 1, char*);
3549 sv_setpvn(sv, aptr, len);
3550 PUSHs(sv_2mortal(sv));
3554 along = (strend - s) / sizeof(Quad_t);
3560 if (s + sizeof(Quad_t) > strend)
3563 Copy(s, &aquad, 1, Quad_t);
3564 s += sizeof(Quad_t);
3567 if (aquad >= IV_MIN && aquad <= IV_MAX)
3568 sv_setiv(sv, (IV)aquad);
3570 sv_setnv(sv, (double)aquad);
3571 PUSHs(sv_2mortal(sv));
3575 along = (strend - s) / sizeof(Quad_t);
3581 if (s + sizeof(unsigned Quad_t) > strend)
3584 Copy(s, &auquad, 1, unsigned Quad_t);
3585 s += sizeof(unsigned Quad_t);
3588 if (auquad <= UV_MAX)
3589 sv_setuv(sv, (UV)auquad);
3591 sv_setnv(sv, (double)auquad);
3592 PUSHs(sv_2mortal(sv));
3596 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3599 along = (strend - s) / sizeof(float);
3604 Copy(s, &afloat, 1, float);
3613 Copy(s, &afloat, 1, float);
3616 sv_setnv(sv, (double)afloat);
3617 PUSHs(sv_2mortal(sv));
3623 along = (strend - s) / sizeof(double);
3628 Copy(s, &adouble, 1, double);
3629 s += sizeof(double);
3637 Copy(s, &adouble, 1, double);
3638 s += sizeof(double);
3640 sv_setnv(sv, (double)adouble);
3641 PUSHs(sv_2mortal(sv));
3647 * Initialise the decode mapping. By using a table driven
3648 * algorithm, the code will be character-set independent
3649 * (and just as fast as doing character arithmetic)
3651 if (uudmap['M'] == 0) {
3654 for (i = 0; i < sizeof(uuemap); i += 1)
3655 uudmap[uuemap[i]] = i;
3657 * Because ' ' and '`' map to the same value,
3658 * we need to decode them both the same.
3663 along = (strend - s) * 3 / 4;
3664 sv = NEWSV(42, along);
3667 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3672 len = uudmap[*s++] & 077;
3674 if (s < strend && ISUUCHAR(*s))
3675 a = uudmap[*s++] & 077;
3678 if (s < strend && ISUUCHAR(*s))
3679 b = uudmap[*s++] & 077;
3682 if (s < strend && ISUUCHAR(*s))
3683 c = uudmap[*s++] & 077;
3686 if (s < strend && ISUUCHAR(*s))
3687 d = uudmap[*s++] & 077;
3690 hunk[0] = (a << 2) | (b >> 4);
3691 hunk[1] = (b << 4) | (c >> 2);
3692 hunk[2] = (c << 6) | d;
3693 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3698 else if (s[1] == '\n') /* possible checksum byte */
3701 XPUSHs(sv_2mortal(sv));
3706 if (strchr("fFdD", datumtype) ||
3707 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3711 while (checksum >= 16) {
3715 while (checksum >= 4) {
3721 along = (1 << checksum) - 1;
3722 while (cdouble < 0.0)
3724 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3725 sv_setnv(sv, cdouble);
3728 if (checksum < 32) {
3729 aulong = (1 << checksum) - 1;
3732 sv_setuv(sv, (UV)culong);
3734 XPUSHs(sv_2mortal(sv));
3738 if (SP == oldsp && gimme == G_SCALAR)
3739 PUSHs(&PL_sv_undef);
3744 doencodes(register SV *sv, register char *s, register I32 len)
3748 *hunk = uuemap[len];
3749 sv_catpvn(sv, hunk, 1);
3752 hunk[0] = uuemap[(077 & (*s >> 2))];
3753 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3754 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3755 hunk[3] = uuemap[(077 & (s[2] & 077))];
3756 sv_catpvn(sv, hunk, 4);
3761 char r = (len > 1 ? s[1] : '\0');
3762 hunk[0] = uuemap[(077 & (*s >> 2))];
3763 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3764 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3765 hunk[3] = uuemap[0];
3766 sv_catpvn(sv, hunk, 4);
3768 sv_catpvn(sv, "\n", 1);
3772 is_an_int(char *s, STRLEN l)
3775 SV *result = newSVpv("", l);
3776 char *result_c = SvPV(result, n_a); /* convenience */
3777 char *out = result_c;
3787 SvREFCNT_dec(result);
3810 SvREFCNT_dec(result);
3816 SvCUR_set(result, out - result_c);
3821 div128(SV *pnum, bool *done)
3822 /* must be '\0' terminated */
3826 char *s = SvPV(pnum, len);
3835 i = m * 10 + (*t - '0');
3837 r = (i >> 7); /* r < 10 */
3844 SvCUR_set(pnum, (STRLEN) (t - s));
3851 djSP; dMARK; dORIGMARK; dTARGET;
3852 register SV *cat = TARG;
3855 register char *pat = SvPVx(*++MARK, fromlen);
3856 register char *patend = pat + fromlen;
3861 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3862 static char *space10 = " ";
3864 /* These must not be in registers: */
3873 unsigned Quad_t auquad;
3882 sv_setpvn(cat, "", 0);
3883 while (pat < patend) {
3884 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
3885 datumtype = *pat++ & 0xFF;
3886 if (isSPACE(datumtype))
3889 len = strchr("@Xxu", datumtype) ? 0 : items;
3892 else if (isDIGIT(*pat)) {
3894 while (isDIGIT(*pat))
3895 len = (len * 10) + (*pat++ - '0');
3901 croak("Invalid type in pack: '%c'", (int)datumtype);
3902 case ',': /* grandfather in commas but with a warning */
3903 if (commas++ == 0 && PL_dowarn)
3904 warn("Invalid type in pack: '%c'", (int)datumtype);
3907 DIE("%% may only be used in unpack");
3918 if (SvCUR(cat) < len)
3919 DIE("X outside of string");
3926 sv_catpvn(cat, null10, 10);
3929 sv_catpvn(cat, null10, len);
3935 aptr = SvPV(fromstr, fromlen);
3939 sv_catpvn(cat, aptr, len);
3941 sv_catpvn(cat, aptr, fromlen);
3943 if (datumtype == 'A') {
3945 sv_catpvn(cat, space10, 10);
3948 sv_catpvn(cat, space10, len);
3952 sv_catpvn(cat, null10, 10);
3955 sv_catpvn(cat, null10, len);
3962 char *savepat = pat;
3967 aptr = SvPV(fromstr, fromlen);
3972 SvCUR(cat) += (len+7)/8;
3973 SvGROW(cat, SvCUR(cat) + 1);
3974 aptr = SvPVX(cat) + aint;
3979 if (datumtype == 'B') {
3980 for (len = 0; len++ < aint;) {
3981 items |= *pat++ & 1;
3985 *aptr++ = items & 0xff;
3991 for (len = 0; len++ < aint;) {
3997 *aptr++ = items & 0xff;
4003 if (datumtype == 'B')
4004 items <<= 7 - (aint & 7);
4006 items >>= 7 - (aint & 7);
4007 *aptr++ = items & 0xff;
4009 pat = SvPVX(cat) + SvCUR(cat);
4020 char *savepat = pat;
4025 aptr = SvPV(fromstr, fromlen);
4030 SvCUR(cat) += (len+1)/2;
4031 SvGROW(cat, SvCUR(cat) + 1);
4032 aptr = SvPVX(cat) + aint;
4037 if (datumtype == 'H') {
4038 for (len = 0; len++ < aint;) {
4040 items |= ((*pat++ & 15) + 9) & 15;
4042 items |= *pat++ & 15;
4046 *aptr++ = items & 0xff;
4052 for (len = 0; len++ < aint;) {
4054 items |= (((*pat++ & 15) + 9) & 15) << 4;
4056 items |= (*pat++ & 15) << 4;
4060 *aptr++ = items & 0xff;
4066 *aptr++ = items & 0xff;
4067 pat = SvPVX(cat) + SvCUR(cat);
4079 aint = SvIV(fromstr);
4081 sv_catpvn(cat, &achar, sizeof(char));
4084 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4089 afloat = (float)SvNV(fromstr);
4090 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4097 adouble = (double)SvNV(fromstr);
4098 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4104 ashort = (I16)SvIV(fromstr);
4106 ashort = PerlSock_htons(ashort);
4108 CAT16(cat, &ashort);
4114 ashort = (I16)SvIV(fromstr);
4116 ashort = htovs(ashort);
4118 CAT16(cat, &ashort);
4125 ashort = (I16)SvIV(fromstr);
4126 CAT16(cat, &ashort);
4132 auint = SvUV(fromstr);
4133 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4139 adouble = floor(SvNV(fromstr));
4142 croak("Cannot compress negative numbers");
4148 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4149 adouble <= UV_MAX_cxux
4156 char buf[1 + sizeof(UV)];
4157 char *in = buf + sizeof(buf);
4158 UV auv = U_V(adouble);;
4161 *--in = (auv & 0x7f) | 0x80;
4164 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4165 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4167 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4168 char *from, *result, *in;
4173 /* Copy string and check for compliance */
4174 from = SvPV(fromstr, len);
4175 if ((norm = is_an_int(from, len)) == NULL)
4176 croak("can compress only unsigned integer");
4178 New('w', result, len, char);
4182 *--in = div128(norm, &done) | 0x80;
4183 result[len - 1] &= 0x7F; /* clear continue bit */
4184 sv_catpvn(cat, in, (result + len) - in);
4186 SvREFCNT_dec(norm); /* free norm */
4188 else if (SvNOKp(fromstr)) {
4189 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4190 char *in = buf + sizeof(buf);
4193 double next = floor(adouble / 128);
4194 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4195 if (--in < buf) /* this cannot happen ;-) */
4196 croak ("Cannot compress integer");
4198 } while (adouble > 0);
4199 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4200 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4203 croak("Cannot compress non integer");
4209 aint = SvIV(fromstr);
4210 sv_catpvn(cat, (char*)&aint, sizeof(int));
4216 aulong = SvUV(fromstr);
4218 aulong = PerlSock_htonl(aulong);
4220 CAT32(cat, &aulong);
4226 aulong = SvUV(fromstr);
4228 aulong = htovl(aulong);
4230 CAT32(cat, &aulong);
4236 aulong = SvUV(fromstr);
4237 CAT32(cat, &aulong);
4243 along = SvIV(fromstr);
4251 auquad = (unsigned Quad_t)SvIV(fromstr);
4252 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4258 aquad = (Quad_t)SvIV(fromstr);
4259 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4262 #endif /* HAS_QUAD */
4264 len = 1; /* assume SV is correct length */
4269 if (fromstr == &PL_sv_undef)
4273 /* XXX better yet, could spirit away the string to
4274 * a safe spot and hang on to it until the result
4275 * of pack() (and all copies of the result) are
4278 if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4279 warn("Attempt to pack pointer to temporary value");
4280 if (SvPOK(fromstr) || SvNIOK(fromstr))
4281 aptr = SvPV(fromstr,n_a);
4283 aptr = SvPV_force(fromstr,n_a);
4285 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4290 aptr = SvPV(fromstr, fromlen);
4291 SvGROW(cat, fromlen * 4 / 3);
4296 while (fromlen > 0) {
4303 doencodes(cat, aptr, todo);
4322 register I32 limit = POPi; /* note, negative is forever */
4325 register char *s = SvPV(sv, len);
4326 char *strend = s + len;
4328 register REGEXP *rx;
4332 I32 maxiters = (strend - s) + 10;
4335 I32 origlimit = limit;
4338 AV *oldstack = PL_curstack;
4339 I32 gimme = GIMME_V;
4340 I32 oldsave = PL_savestack_ix;
4341 I32 make_mortal = 1;
4342 MAGIC *mg = (MAGIC *) NULL;
4345 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4350 DIE("panic: do_split");
4351 rx = pm->op_pmregexp;
4353 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4354 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4356 if (pm->op_pmreplroot)
4357 ary = GvAVn((GV*)pm->op_pmreplroot);
4358 else if (gimme != G_ARRAY)
4360 ary = (AV*)PL_curpad[0];
4362 ary = GvAVn(PL_defgv);
4363 #endif /* USE_THREADS */
4366 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4372 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4374 XPUSHs(SvTIED_obj((SV*)ary, mg));
4379 for (i = AvFILLp(ary); i >= 0; i--)
4380 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4382 /* temporarily switch stacks */
4383 SWITCHSTACK(PL_curstack, ary);
4387 base = SP - PL_stack_base;
4389 if (pm->op_pmflags & PMf_SKIPWHITE) {
4390 if (pm->op_pmflags & PMf_LOCALE) {
4391 while (isSPACE_LC(*s))
4399 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4400 SAVEINT(PL_multiline);
4401 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4405 limit = maxiters + 2;
4406 if (pm->op_pmflags & PMf_WHITE) {
4409 while (m < strend &&
4410 !((pm->op_pmflags & PMf_LOCALE)
4411 ? isSPACE_LC(*m) : isSPACE(*m)))
4416 dstr = NEWSV(30, m-s);
4417 sv_setpvn(dstr, s, m-s);
4423 while (s < strend &&
4424 ((pm->op_pmflags & PMf_LOCALE)
4425 ? isSPACE_LC(*s) : isSPACE(*s)))
4429 else if (strEQ("^", rx->precomp)) {
4432 for (m = s; m < strend && *m != '\n'; m++) ;
4436 dstr = NEWSV(30, m-s);
4437 sv_setpvn(dstr, s, m-s);
4444 else if (rx->check_substr && !rx->nparens
4445 && (rx->reganch & ROPT_CHECK_ALL)
4446 && !(rx->reganch & ROPT_ANCH)) {
4447 i = SvCUR(rx->check_substr);
4448 if (i == 1 && !SvTAIL(rx->check_substr)) {
4449 i = *SvPVX(rx->check_substr);
4452 for (m = s; m < strend && *m != i; m++) ;
4455 dstr = NEWSV(30, m-s);
4456 sv_setpvn(dstr, s, m-s);
4465 while (s < strend && --limit &&
4466 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4467 rx->check_substr, 0)) )
4470 dstr = NEWSV(31, m-s);
4471 sv_setpvn(dstr, s, m-s);
4480 maxiters += (strend - s) * rx->nparens;
4481 while (s < strend && --limit &&
4482 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4484 TAINT_IF(RX_MATCH_TAINTED(rx));
4486 && rx->subbase != orig) {
4491 strend = s + (strend - m);
4494 dstr = NEWSV(32, m-s);
4495 sv_setpvn(dstr, s, m-s);
4500 for (i = 1; i <= rx->nparens; i++) {
4504 dstr = NEWSV(33, m-s);
4505 sv_setpvn(dstr, s, m-s);
4508 dstr = NEWSV(33, 0);
4518 LEAVE_SCOPE(oldsave);
4519 iters = (SP - PL_stack_base) - base;
4520 if (iters > maxiters)
4523 /* keep field after final delim? */
4524 if (s < strend || (iters && origlimit)) {
4525 dstr = NEWSV(34, strend-s);
4526 sv_setpvn(dstr, s, strend-s);
4532 else if (!origlimit) {
4533 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4539 SWITCHSTACK(ary, oldstack);
4540 if (SvSMAGICAL(ary)) {
4545 if (gimme == G_ARRAY) {
4547 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4555 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4558 if (gimme == G_ARRAY) {
4559 /* EXTEND should not be needed - we just popped them */
4561 for (i=0; i < iters; i++) {
4562 SV **svp = av_fetch(ary, i, FALSE);
4563 PUSHs((svp) ? *svp : &PL_sv_undef);
4570 if (gimme == G_ARRAY)
4573 if (iters || !pm->op_pmreplroot) {
4583 unlock_condpair(void *svv)
4586 MAGIC *mg = mg_find((SV*)svv, 'm');
4589 croak("panic: unlock_condpair unlocking non-mutex");
4590 MUTEX_LOCK(MgMUTEXP(mg));
4591 if (MgOWNER(mg) != thr)
4592 croak("panic: unlock_condpair unlocking mutex that we don't own");
4594 COND_SIGNAL(MgOWNERCONDP(mg));
4595 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4596 (unsigned long)thr, (unsigned long)svv);)
4597 MUTEX_UNLOCK(MgMUTEXP(mg));
4599 #endif /* USE_THREADS */
4612 mg = condpair_magic(sv);
4613 MUTEX_LOCK(MgMUTEXP(mg));
4614 if (MgOWNER(mg) == thr)
4615 MUTEX_UNLOCK(MgMUTEXP(mg));
4618 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4620 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4621 (unsigned long)thr, (unsigned long)sv);)
4622 MUTEX_UNLOCK(MgMUTEXP(mg));
4623 save_destructor(unlock_condpair, sv);
4625 #endif /* USE_THREADS */
4626 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4627 || SvTYPE(retsv) == SVt_PVCV) {
4628 retsv = refto(retsv);
4639 if (PL_op->op_private & OPpLVAL_INTRO)
4640 PUSHs(*save_threadsv(PL_op->op_targ));
4642 PUSHs(THREADSV(PL_op->op_targ));
4645 DIE("tried to access per-thread data in non-threaded perl");
4646 #endif /* USE_THREADS */