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) {
344 PUSHi(i + PL_curcop->cop_arybase);
358 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
359 /* (But not in defined().) */
360 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
363 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
366 cv = (CV*)&PL_sv_undef;
380 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
381 char *s = SvPVX(TOPs);
382 if (strnEQ(s, "CORE::", 6)) {
385 code = keyword(s + 6, SvCUR(TOPs) - 6);
386 if (code < 0) { /* Overridable. */
387 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
388 int i = 0, n = 0, seen_question = 0;
390 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
392 while (i < MAXO) { /* The slow way. */
393 if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
397 goto nonesuch; /* Should not happen... */
399 oa = opargs[i] >> OASHIFT;
401 if (oa & OA_OPTIONAL) {
404 } else if (seen_question)
405 goto set; /* XXXX system, exec */
406 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
407 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
410 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
411 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
415 ret = sv_2mortal(newSVpv(str, n - 1));
416 } else if (code) /* Non-Overridable */
418 else { /* None such */
420 croak("Cannot find an opnumber for \"%s\"", s+6);
424 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
426 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
435 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
437 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
453 if (GIMME != G_ARRAY) {
457 *MARK = &PL_sv_undef;
458 *MARK = refto(*MARK);
462 EXTEND_MORTAL(SP - MARK);
464 *MARK = refto(*MARK);
473 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
476 if (!(sv = LvTARG(sv)))
479 else if (SvPADTMP(sv))
483 (void)SvREFCNT_inc(sv);
486 sv_upgrade(rv, SVt_RV);
500 if (sv && SvGMAGICAL(sv))
503 if (!sv || !SvROK(sv))
507 pv = sv_reftype(sv,TRUE);
508 PUSHp(pv, strlen(pv));
518 stash = PL_curcop->cop_stash;
522 char *ptr = SvPV(ssv,len);
523 if (PL_dowarn && len == 0)
524 warn("Explicit blessing to '' (assuming package main)");
525 stash = gv_stashpvn(ptr, len, TRUE);
528 (void)sv_bless(TOPs, stash);
541 elem = SvPV(sv, PL_na);
545 switch (elem ? *elem : '\0')
548 if (strEQ(elem, "ARRAY"))
549 tmpRef = (SV*)GvAV(gv);
552 if (strEQ(elem, "CODE"))
553 tmpRef = (SV*)GvCVu(gv);
556 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
557 tmpRef = (SV*)GvIOp(gv);
560 if (strEQ(elem, "GLOB"))
564 if (strEQ(elem, "HASH"))
565 tmpRef = (SV*)GvHV(gv);
568 if (strEQ(elem, "IO"))
569 tmpRef = (SV*)GvIOp(gv);
572 if (strEQ(elem, "NAME"))
573 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
576 if (strEQ(elem, "PACKAGE"))
577 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
580 if (strEQ(elem, "SCALAR"))
594 /* Pattern matching */
599 register UNOP *unop = cUNOP;
600 register unsigned char *s;
603 register I32 *sfirst;
607 if (sv == PL_lastscream) {
613 SvSCREAM_off(PL_lastscream);
614 SvREFCNT_dec(PL_lastscream);
616 PL_lastscream = SvREFCNT_inc(sv);
619 s = (unsigned char*)(SvPV(sv, len));
623 if (pos > PL_maxscream) {
624 if (PL_maxscream < 0) {
625 PL_maxscream = pos + 80;
626 New(301, PL_screamfirst, 256, I32);
627 New(302, PL_screamnext, PL_maxscream, I32);
630 PL_maxscream = pos + pos / 4;
631 Renew(PL_screamnext, PL_maxscream, I32);
635 sfirst = PL_screamfirst;
636 snext = PL_screamnext;
638 if (!sfirst || !snext)
639 DIE("do_study: out of memory");
641 for (ch = 256; ch; --ch)
648 snext[pos] = sfirst[ch] - pos;
655 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
664 if (PL_op->op_flags & OPf_STACKED)
670 TARG = sv_newmortal();
671 PUSHi(do_trans(sv, PL_op));
675 /* Lvalue operators. */
687 djSP; dMARK; dTARGET;
697 SETi(do_chomp(TOPs));
703 djSP; dMARK; dTARGET;
704 register I32 count = 0;
707 count += do_chomp(POPs);
718 if (!sv || !SvANY(sv))
720 switch (SvTYPE(sv)) {
722 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
726 if (HvARRAY(sv) || SvGMAGICAL(sv))
730 if (CvROOT(sv) || CvXSUB(sv))
747 if (!PL_op->op_private) {
756 if (SvTHINKFIRST(sv)) {
763 switch (SvTYPE(sv)) {
773 if (PL_dowarn && cv_const_sv((CV*)sv))
774 warn("Constant subroutine %s undefined",
775 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
778 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
780 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
784 SvSetMagicSV(sv, &PL_sv_undef);
788 Newz(602, gp, 1, GP);
789 GvGP(sv) = gp_ref(gp);
790 GvSV(sv) = NEWSV(72,0);
791 GvLINE(sv) = PL_curcop->cop_line;
797 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
800 SvPV_set(sv, Nullch);
813 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
815 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
816 SvIVX(TOPs) != IV_MIN)
819 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
830 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
832 sv_setsv(TARG, TOPs);
833 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
834 SvIVX(TOPs) != IV_MAX)
837 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
851 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
853 sv_setsv(TARG, TOPs);
854 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
855 SvIVX(TOPs) != IV_MIN)
858 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
867 /* Ordinary operators. */
871 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
874 SETn( pow( left, right) );
881 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
884 SETn( left * right );
891 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
896 DIE("Illegal division by zero");
898 /* insure that 20./5. == 4. */
901 if ((double)I_V(left) == left &&
902 (double)I_V(right) == right &&
903 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
906 value = left / right;
910 value = left / right;
919 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
927 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
929 right = (right_neg = (i < 0)) ? -i : i;
933 right = U_V((right_neg = (n < 0)) ? -n : n);
936 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
938 left = (left_neg = (i < 0)) ? -i : i;
942 left = U_V((left_neg = (n < 0)) ? -n : n);
946 DIE("Illegal modulus zero");
949 if ((left_neg != right_neg) && ans)
952 /* XXX may warn: unary minus operator applied to unsigned type */
953 /* could change -foo to be (~foo)+1 instead */
954 if (ans <= ~((UV)IV_MAX)+1)
955 sv_setiv(TARG, ~ans+1);
957 sv_setnv(TARG, -(double)ans);
968 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
970 register I32 count = POPi;
971 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
973 I32 items = SP - MARK;
985 repeatcpy((char*)(MARK + items), (char*)MARK,
986 items * sizeof(SV*), count - 1);
992 else { /* Note: mark already snarfed by pp_list */
997 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
998 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
999 DIE("Can't x= to readonly value");
1003 SvSetSV(TARG, tmpstr);
1004 SvPV_force(TARG, len);
1009 SvGROW(TARG, (count * len) + 1);
1010 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1011 SvCUR(TARG) *= count;
1013 *SvEND(TARG) = '\0';
1015 (void)SvPOK_only(TARG);
1024 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1027 SETn( left - right );
1034 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1037 if (PL_op->op_private & HINT_INTEGER) {
1039 i = BWi(i) << shift;
1053 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1056 if (PL_op->op_private & HINT_INTEGER) {
1058 i = BWi(i) >> shift;
1072 djSP; tryAMAGICbinSET(lt,0);
1075 SETs(boolSV(TOPn < value));
1082 djSP; tryAMAGICbinSET(gt,0);
1085 SETs(boolSV(TOPn > value));
1092 djSP; tryAMAGICbinSET(le,0);
1095 SETs(boolSV(TOPn <= value));
1102 djSP; tryAMAGICbinSET(ge,0);
1105 SETs(boolSV(TOPn >= value));
1112 djSP; tryAMAGICbinSET(ne,0);
1115 SETs(boolSV(TOPn != value));
1122 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1129 else if (left < right)
1131 else if (left > right)
1144 djSP; tryAMAGICbinSET(slt,0);
1147 int cmp = ((PL_op->op_private & OPpLOCALE)
1148 ? sv_cmp_locale(left, right)
1149 : sv_cmp(left, right));
1150 SETs(boolSV(cmp < 0));
1157 djSP; tryAMAGICbinSET(sgt,0);
1160 int cmp = ((PL_op->op_private & OPpLOCALE)
1161 ? sv_cmp_locale(left, right)
1162 : sv_cmp(left, right));
1163 SETs(boolSV(cmp > 0));
1170 djSP; tryAMAGICbinSET(sle,0);
1173 int cmp = ((PL_op->op_private & OPpLOCALE)
1174 ? sv_cmp_locale(left, right)
1175 : sv_cmp(left, right));
1176 SETs(boolSV(cmp <= 0));
1183 djSP; tryAMAGICbinSET(sge,0);
1186 int cmp = ((PL_op->op_private & OPpLOCALE)
1187 ? sv_cmp_locale(left, right)
1188 : sv_cmp(left, right));
1189 SETs(boolSV(cmp >= 0));
1196 djSP; tryAMAGICbinSET(seq,0);
1199 SETs(boolSV(sv_eq(left, right)));
1206 djSP; tryAMAGICbinSET(sne,0);
1209 SETs(boolSV(!sv_eq(left, right)));
1216 djSP; dTARGET; tryAMAGICbin(scmp,0);
1219 int cmp = ((PL_op->op_private & OPpLOCALE)
1220 ? sv_cmp_locale(left, right)
1221 : sv_cmp(left, right));
1229 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1232 if (SvNIOKp(left) || SvNIOKp(right)) {
1233 if (PL_op->op_private & HINT_INTEGER) {
1234 IBW value = SvIV(left) & SvIV(right);
1238 UBW value = SvUV(left) & SvUV(right);
1243 do_vop(PL_op->op_type, TARG, left, right);
1252 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1255 if (SvNIOKp(left) || SvNIOKp(right)) {
1256 if (PL_op->op_private & HINT_INTEGER) {
1257 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1261 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1266 do_vop(PL_op->op_type, TARG, left, right);
1275 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1278 if (SvNIOKp(left) || SvNIOKp(right)) {
1279 if (PL_op->op_private & HINT_INTEGER) {
1280 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1284 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1289 do_vop(PL_op->op_type, TARG, left, right);
1298 djSP; dTARGET; tryAMAGICun(neg);
1303 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1305 else if (SvNIOKp(sv))
1307 else if (SvPOKp(sv)) {
1309 char *s = SvPV(sv, len);
1310 if (isIDFIRST(*s)) {
1311 sv_setpvn(TARG, "-", 1);
1314 else if (*s == '+' || *s == '-') {
1316 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1319 sv_setnv(TARG, -SvNV(sv));
1331 djSP; tryAMAGICunSET(not);
1332 #endif /* OVERLOAD */
1333 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1339 djSP; dTARGET; tryAMAGICun(compl);
1343 if (PL_op->op_private & HINT_INTEGER) {
1344 IBW value = ~SvIV(sv);
1348 UBW value = ~SvUV(sv);
1353 register char *tmps;
1354 register long *tmpl;
1359 tmps = SvPV_force(TARG, len);
1362 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1365 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1369 for ( ; anum > 0; anum--, tmps++)
1378 /* integer versions of some of the above */
1382 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1385 SETi( left * right );
1392 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1396 DIE("Illegal division by zero");
1397 value = POPi / value;
1405 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1409 DIE("Illegal modulus zero");
1410 SETi( left % right );
1417 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1420 SETi( left + right );
1427 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1430 SETi( left - right );
1437 djSP; tryAMAGICbinSET(lt,0);
1440 SETs(boolSV(left < right));
1447 djSP; tryAMAGICbinSET(gt,0);
1450 SETs(boolSV(left > right));
1457 djSP; tryAMAGICbinSET(le,0);
1460 SETs(boolSV(left <= right));
1467 djSP; tryAMAGICbinSET(ge,0);
1470 SETs(boolSV(left >= right));
1477 djSP; tryAMAGICbinSET(eq,0);
1480 SETs(boolSV(left == right));
1487 djSP; tryAMAGICbinSET(ne,0);
1490 SETs(boolSV(left != right));
1497 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1504 else if (left < right)
1515 djSP; dTARGET; tryAMAGICun(neg);
1520 /* High falutin' math. */
1524 djSP; dTARGET; tryAMAGICbin(atan2,0);
1527 SETn(atan2(left, right));
1534 djSP; dTARGET; tryAMAGICun(sin);
1546 djSP; dTARGET; tryAMAGICun(cos);
1556 /* Support Configure command-line overrides for rand() functions.
1557 After 5.005, perhaps we should replace this by Configure support
1558 for drand48(), random(), or rand(). For 5.005, though, maintain
1559 compatibility by calling rand() but allow the user to override it.
1560 See INSTALL for details. --Andy Dougherty 15 July 1998
1563 # define my_rand rand
1566 # define my_srand srand
1579 if (!srand_called) {
1580 (void)my_srand((unsigned)seed());
1581 srand_called = TRUE;
1584 value = my_rand() * value / 2147483648.0;
1587 value = my_rand() * value / 65536.0;
1590 value = my_rand() * value / 32768.0;
1592 value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
1608 (void)my_srand((unsigned)anum);
1609 srand_called = TRUE;
1618 * This is really just a quick hack which grabs various garbage
1619 * values. It really should be a real hash algorithm which
1620 * spreads the effect of every input bit onto every output bit,
1621 * if someone who knows about such tings would bother to write it.
1622 * Might be a good idea to add that function to CORE as well.
1623 * No numbers below come from careful analysis or anyting here,
1624 * except they are primes and SEED_C1 > 1E6 to get a full-width
1625 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1626 * probably be bigger too.
1629 # define SEED_C1 1000003
1630 #define SEED_C4 73819
1632 # define SEED_C1 25747
1633 #define SEED_C4 20639
1637 #define SEED_C5 26107
1642 # include <starlet.h>
1643 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1644 * in 100-ns units, typically incremented ever 10 ms. */
1645 unsigned int when[2];
1646 _ckvmssts(sys$gettim(when));
1647 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1649 # ifdef HAS_GETTIMEOFDAY
1650 struct timeval when;
1651 gettimeofday(&when,(struct timezone *) 0);
1652 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1656 u = (U32)SEED_C1 * when;
1659 u += SEED_C3 * (U32)getpid();
1660 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1661 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1662 u += SEED_C5 * (U32)(UV)&when;
1669 djSP; dTARGET; tryAMAGICun(exp);
1681 djSP; dTARGET; tryAMAGICun(log);
1686 SET_NUMERIC_STANDARD();
1687 DIE("Can't take log of %g", value);
1697 djSP; dTARGET; tryAMAGICun(sqrt);
1702 SET_NUMERIC_STANDARD();
1703 DIE("Can't take sqrt of %g", value);
1705 value = sqrt(value);
1715 double value = TOPn;
1718 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1724 (void)modf(value, &value);
1726 (void)modf(-value, &value);
1741 djSP; dTARGET; tryAMAGICun(abs);
1743 double value = TOPn;
1746 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1747 (iv = SvIVX(TOPs)) != IV_MIN) {
1768 XPUSHu(scan_hex(tmps, 99, &argtype));
1780 while (*tmps && isSPACE(*tmps))
1785 value = scan_hex(++tmps, 99, &argtype);
1787 value = scan_oct(tmps, 99, &argtype);
1799 SETi( sv_len_utf8(TOPs) );
1803 SETi( sv_len(TOPs) );
1817 I32 lvalue = PL_op->op_flags & OPf_MOD;
1819 I32 arybase = PL_curcop->cop_arybase;
1823 SvTAINTED_off(TARG); /* decontaminate */
1827 repl = SvPV(sv, repl_len);
1834 tmps = SvPV(sv, curlen);
1836 utfcurlen = sv_len_utf8(sv);
1837 if (utfcurlen == curlen)
1843 if (pos >= arybase) {
1861 else if (len >= 0) {
1863 if (rem > (I32)curlen)
1877 if (PL_dowarn || lvalue || repl)
1878 warn("substr outside of string");
1883 sv_pos_u2b(sv, &pos, &rem);
1885 sv_setpvn(TARG, tmps, rem);
1886 if (lvalue) { /* it's an lvalue! */
1887 if (!SvGMAGICAL(sv)) {
1889 SvPV_force(sv,PL_na);
1891 warn("Attempt to use reference as lvalue in substr");
1893 if (SvOK(sv)) /* is it defined ? */
1894 (void)SvPOK_only(sv);
1896 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1899 if (SvTYPE(TARG) < SVt_PVLV) {
1900 sv_upgrade(TARG, SVt_PVLV);
1901 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1905 if (LvTARG(TARG) != sv) {
1907 SvREFCNT_dec(LvTARG(TARG));
1908 LvTARG(TARG) = SvREFCNT_inc(sv);
1910 LvTARGOFF(TARG) = pos;
1911 LvTARGLEN(TARG) = rem;
1914 sv_insert(sv, pos, rem, repl, repl_len);
1917 PUSHs(TARG); /* avoid SvSETMAGIC here */
1924 register I32 size = POPi;
1925 register I32 offset = POPi;
1926 register SV *src = POPs;
1927 I32 lvalue = PL_op->op_flags & OPf_MOD;
1929 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1930 unsigned long retnum;
1933 SvTAINTED_off(TARG); /* decontaminate */
1934 offset *= size; /* turn into bit offset */
1935 len = (offset + size + 7) / 8;
1936 if (offset < 0 || size < 1)
1939 if (lvalue) { /* it's an lvalue! */
1940 if (SvTYPE(TARG) < SVt_PVLV) {
1941 sv_upgrade(TARG, SVt_PVLV);
1942 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1946 if (LvTARG(TARG) != src) {
1948 SvREFCNT_dec(LvTARG(TARG));
1949 LvTARG(TARG) = SvREFCNT_inc(src);
1951 LvTARGOFF(TARG) = offset;
1952 LvTARGLEN(TARG) = size;
1960 if (offset >= srclen)
1963 retnum = (unsigned long) s[offset] << 8;
1965 else if (size == 32) {
1966 if (offset >= srclen)
1968 else if (offset + 1 >= srclen)
1969 retnum = (unsigned long) s[offset] << 24;
1970 else if (offset + 2 >= srclen)
1971 retnum = ((unsigned long) s[offset] << 24) +
1972 ((unsigned long) s[offset + 1] << 16);
1974 retnum = ((unsigned long) s[offset] << 24) +
1975 ((unsigned long) s[offset + 1] << 16) +
1976 (s[offset + 2] << 8);
1981 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1986 else if (size == 16)
1987 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1988 else if (size == 32)
1989 retnum = ((unsigned long) s[offset] << 24) +
1990 ((unsigned long) s[offset + 1] << 16) +
1991 (s[offset + 2] << 8) + s[offset+3];
1995 sv_setuv(TARG, (UV)retnum);
2010 I32 arybase = PL_curcop->cop_arybase;
2015 offset = POPi - arybase;
2018 tmps = SvPV(big, biglen);
2019 if (IN_UTF8 && offset > 0)
2020 sv_pos_u2b(big, &offset, 0);
2023 else if (offset > biglen)
2025 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2026 (unsigned char*)tmps + biglen, little, 0)))
2029 retval = tmps2 - tmps;
2030 if (IN_UTF8 && retval > 0)
2031 sv_pos_b2u(big, &retval);
2032 PUSHi(retval + arybase);
2047 I32 arybase = PL_curcop->cop_arybase;
2053 tmps2 = SvPV(little, llen);
2054 tmps = SvPV(big, blen);
2058 if (IN_UTF8 && offset > 0)
2059 sv_pos_u2b(big, &offset, 0);
2060 offset = offset - arybase + llen;
2064 else if (offset > blen)
2066 if (!(tmps2 = rninstr(tmps, tmps + offset,
2067 tmps2, tmps2 + llen)))
2070 retval = tmps2 - tmps;
2071 if (IN_UTF8 && retval > 0)
2072 sv_pos_b2u(big, &retval);
2073 PUSHi(retval + arybase);
2079 djSP; dMARK; dORIGMARK; dTARGET;
2080 #ifdef USE_LOCALE_NUMERIC
2081 if (PL_op->op_private & OPpLOCALE)
2082 SET_NUMERIC_LOCAL();
2084 SET_NUMERIC_STANDARD();
2086 do_sprintf(TARG, SP-MARK, MARK+1);
2087 TAINT_IF(SvTAINTED(TARG));
2100 if (IN_UTF8 && (*tmps & 0x80))
2101 value = (I32) utf8_to_uv(tmps, &retlen);
2103 value = (I32) (*tmps & 255);
2114 (void)SvUPGRADE(TARG,SVt_PV);
2116 if (IN_UTF8 && value >= 128) {
2119 tmps = uv_to_utf8(tmps, (UV)value);
2120 SvCUR_set(TARG, tmps - SvPVX(TARG));
2122 (void)SvPOK_only(TARG);
2132 (void)SvPOK_only(TARG);
2139 djSP; dTARGET; dPOPTOPssrl;
2141 char *tmps = SvPV(left, PL_na);
2143 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2145 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2149 "The crypt() function is unimplemented due to excessive paranoia.");
2162 if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2166 UV uv = utf8_to_uv(s, &ulen);
2168 if (PL_op->op_private & OPpLOCALE) {
2171 uv = toTITLE_LC_uni(uv);
2174 uv = toTITLE_utf8(s);
2176 tend = uv_to_utf8(tmpbuf, uv);
2178 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2180 sv_setpvn(TARG, tmpbuf, tend - tmpbuf);
2181 sv_catpvn(TARG, s + ulen, slen - ulen);
2185 s = SvPV_force(sv, slen);
2186 Copy(tmpbuf, s, ulen, U8);
2191 if (!SvPADTMP(sv)) {
2197 s = SvPV_force(sv, PL_na);
2199 if (PL_op->op_private & OPpLOCALE) {
2202 *s = toUPPER_LC(*s);
2218 if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2222 UV uv = utf8_to_uv(s, &ulen);
2224 if (PL_op->op_private & OPpLOCALE) {
2227 uv = toLOWER_LC_uni(uv);
2230 uv = toLOWER_utf8(s);
2232 tend = uv_to_utf8(tmpbuf, uv);
2234 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2236 sv_setpvn(TARG, tmpbuf, tend - tmpbuf);
2237 sv_catpvn(TARG, s + ulen, slen - ulen);
2241 s = SvPV_force(sv, slen);
2242 Copy(tmpbuf, s, ulen, U8);
2247 if (!SvPADTMP(sv)) {
2253 s = SvPV_force(sv, PL_na);
2255 if (PL_op->op_private & OPpLOCALE) {
2258 *s = toLOWER_LC(*s);
2285 (void)SvUPGRADE(TARG, SVt_PV);
2286 SvGROW(TARG, (len * 2) + 1);
2287 (void)SvPOK_only(TARG);
2290 if (PL_op->op_private & OPpLOCALE) {
2294 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2300 d = uv_to_utf8(d, toUPPER_utf8( s ));
2305 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2310 if (!SvPADTMP(sv)) {
2317 s = SvPV_force(sv, len);
2319 register U8 *send = s + len;
2321 if (PL_op->op_private & OPpLOCALE) {
2324 for (; s < send; s++)
2325 *s = toUPPER_LC(*s);
2328 for (; s < send; s++)
2352 (void)SvUPGRADE(TARG, SVt_PV);
2353 SvGROW(TARG, (len * 2) + 1);
2354 (void)SvPOK_only(TARG);
2357 if (PL_op->op_private & OPpLOCALE) {
2361 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2367 d = uv_to_utf8(d, toLOWER_utf8(s));
2372 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2377 if (!SvPADTMP(sv)) {
2384 s = SvPV_force(sv, len);
2386 register U8 *send = s + len;
2388 if (PL_op->op_private & OPpLOCALE) {
2391 for (; s < send; s++)
2392 *s = toLOWER_LC(*s);
2395 for (; s < send; s++)
2407 register char *s = SvPV(sv,len);
2411 (void)SvUPGRADE(TARG, SVt_PV);
2412 SvGROW(TARG, (len * 2) + 1);
2415 if (!(*s & 0x80) && !isALNUM(*s))
2420 SvCUR_set(TARG, d - SvPVX(TARG));
2421 (void)SvPOK_only(TARG);
2424 sv_setpvn(TARG, s, len);
2433 djSP; dMARK; dORIGMARK;
2435 register AV* av = (AV*)POPs;
2436 register I32 lval = PL_op->op_flags & OPf_MOD;
2437 I32 arybase = PL_curcop->cop_arybase;
2440 if (SvTYPE(av) == SVt_PVAV) {
2441 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2443 for (svp = MARK + 1; svp <= SP; svp++) {
2448 if (max > AvMAX(av))
2451 while (++MARK <= SP) {
2452 elem = SvIVx(*MARK);
2456 svp = av_fetch(av, elem, lval);
2458 if (!svp || *svp == &PL_sv_undef)
2459 DIE(no_aelem, elem);
2460 if (PL_op->op_private & OPpLVAL_INTRO)
2461 save_aelem(av, elem, svp);
2463 *MARK = svp ? *svp : &PL_sv_undef;
2466 if (GIMME != G_ARRAY) {
2474 /* Associative arrays. */
2479 HV *hash = (HV*)POPs;
2481 I32 gimme = GIMME_V;
2482 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2485 /* might clobber stack_sp */
2486 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2491 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2492 if (gimme == G_ARRAY) {
2494 /* might clobber stack_sp */
2495 sv_setsv(TARG, realhv ?
2496 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2501 else if (gimme == G_SCALAR)
2520 I32 gimme = GIMME_V;
2521 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2525 if (PL_op->op_private & OPpSLICE) {
2529 hvtype = SvTYPE(hv);
2530 while (++MARK <= SP) {
2531 if (hvtype == SVt_PVHV)
2532 sv = hv_delete_ent(hv, *MARK, discard, 0);
2534 DIE("Not a HASH reference");
2535 *MARK = sv ? sv : &PL_sv_undef;
2539 else if (gimme == G_SCALAR) {
2548 if (SvTYPE(hv) == SVt_PVHV)
2549 sv = hv_delete_ent(hv, keysv, discard, 0);
2551 DIE("Not a HASH reference");
2565 if (SvTYPE(hv) == SVt_PVHV) {
2566 if (hv_exists_ent(hv, tmpsv, 0))
2568 } else if (SvTYPE(hv) == SVt_PVAV) {
2569 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2572 DIE("Not a HASH reference");
2579 djSP; dMARK; dORIGMARK;
2580 register HV *hv = (HV*)POPs;
2581 register I32 lval = PL_op->op_flags & OPf_MOD;
2582 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2584 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2585 DIE("Can't localize pseudo-hash element");
2587 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2588 while (++MARK <= SP) {
2592 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2593 svp = he ? &HeVAL(he) : 0;
2595 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2598 if (!svp || *svp == &PL_sv_undef)
2599 DIE(no_helem, SvPV(keysv, PL_na));
2600 if (PL_op->op_private & OPpLVAL_INTRO)
2601 save_helem(hv, keysv, svp);
2603 *MARK = svp ? *svp : &PL_sv_undef;
2606 if (GIMME != G_ARRAY) {
2614 /* List operators. */
2619 if (GIMME != G_ARRAY) {
2621 *MARK = *SP; /* unwanted list, return last item */
2623 *MARK = &PL_sv_undef;
2632 SV **lastrelem = PL_stack_sp;
2633 SV **lastlelem = PL_stack_base + POPMARK;
2634 SV **firstlelem = PL_stack_base + POPMARK + 1;
2635 register SV **firstrelem = lastlelem + 1;
2636 I32 arybase = PL_curcop->cop_arybase;
2637 I32 lval = PL_op->op_flags & OPf_MOD;
2638 I32 is_something_there = lval;
2640 register I32 max = lastrelem - lastlelem;
2641 register SV **lelem;
2644 if (GIMME != G_ARRAY) {
2645 ix = SvIVx(*lastlelem);
2650 if (ix < 0 || ix >= max)
2651 *firstlelem = &PL_sv_undef;
2653 *firstlelem = firstrelem[ix];
2659 SP = firstlelem - 1;
2663 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2668 *lelem = &PL_sv_undef;
2669 else if (!(*lelem = firstrelem[ix]))
2670 *lelem = &PL_sv_undef;
2674 if (ix >= max || !(*lelem = firstrelem[ix]))
2675 *lelem = &PL_sv_undef;
2677 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2678 is_something_there = TRUE;
2680 if (is_something_there)
2683 SP = firstlelem - 1;
2689 djSP; dMARK; dORIGMARK;
2690 I32 items = SP - MARK;
2691 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2692 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2699 djSP; dMARK; dORIGMARK;
2700 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2704 SV *val = NEWSV(46, 0);
2706 sv_setsv(val, *++MARK);
2708 warn("Odd number of elements in hash assignment");
2709 (void)hv_store_ent(hv,key,val,0);
2718 djSP; dMARK; dORIGMARK;
2719 register AV *ary = (AV*)*++MARK;
2723 register I32 offset;
2724 register I32 length;
2731 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2732 *MARK-- = mg->mg_obj;
2736 perl_call_method("SPLICE",GIMME_V);
2745 offset = i = SvIVx(*MARK);
2747 offset += AvFILLp(ary) + 1;
2749 offset -= PL_curcop->cop_arybase;
2753 length = SvIVx(*MARK++);
2755 length += AvFILLp(ary) - offset + 1;
2761 length = AvMAX(ary) + 1; /* close enough to infinity */
2765 length = AvMAX(ary) + 1;
2767 if (offset > AvFILLp(ary) + 1)
2768 offset = AvFILLp(ary) + 1;
2769 after = AvFILLp(ary) + 1 - (offset + length);
2770 if (after < 0) { /* not that much array */
2771 length += after; /* offset+length now in array */
2777 /* At this point, MARK .. SP-1 is our new LIST */
2780 diff = newlen - length;
2781 if (newlen && !AvREAL(ary)) {
2785 assert(AvREAL(ary)); /* would leak, so croak */
2788 if (diff < 0) { /* shrinking the area */
2790 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2791 Copy(MARK, tmparyval, newlen, SV*);
2794 MARK = ORIGMARK + 1;
2795 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2796 MEXTEND(MARK, length);
2797 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2799 EXTEND_MORTAL(length);
2800 for (i = length, dst = MARK; i; i--) {
2801 sv_2mortal(*dst); /* free them eventualy */
2808 *MARK = AvARRAY(ary)[offset+length-1];
2811 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2812 SvREFCNT_dec(*dst++); /* free them now */
2815 AvFILLp(ary) += diff;
2817 /* pull up or down? */
2819 if (offset < after) { /* easier to pull up */
2820 if (offset) { /* esp. if nothing to pull */
2821 src = &AvARRAY(ary)[offset-1];
2822 dst = src - diff; /* diff is negative */
2823 for (i = offset; i > 0; i--) /* can't trust Copy */
2827 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2831 if (after) { /* anything to pull down? */
2832 src = AvARRAY(ary) + offset + length;
2833 dst = src + diff; /* diff is negative */
2834 Move(src, dst, after, SV*);
2836 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2837 /* avoid later double free */
2841 dst[--i] = &PL_sv_undef;
2844 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2846 *dst = NEWSV(46, 0);
2847 sv_setsv(*dst++, *src++);
2849 Safefree(tmparyval);
2852 else { /* no, expanding (or same) */
2854 New(452, tmparyval, length, SV*); /* so remember deletion */
2855 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2858 if (diff > 0) { /* expanding */
2860 /* push up or down? */
2862 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2866 Move(src, dst, offset, SV*);
2868 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2870 AvFILLp(ary) += diff;
2873 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2874 av_extend(ary, AvFILLp(ary) + diff);
2875 AvFILLp(ary) += diff;
2878 dst = AvARRAY(ary) + AvFILLp(ary);
2880 for (i = after; i; i--) {
2887 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2888 *dst = NEWSV(46, 0);
2889 sv_setsv(*dst++, *src++);
2891 MARK = ORIGMARK + 1;
2892 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2894 Copy(tmparyval, MARK, length, SV*);
2896 EXTEND_MORTAL(length);
2897 for (i = length, dst = MARK; i; i--) {
2898 sv_2mortal(*dst); /* free them eventualy */
2902 Safefree(tmparyval);
2906 else if (length--) {
2907 *MARK = tmparyval[length];
2910 while (length-- > 0)
2911 SvREFCNT_dec(tmparyval[length]);
2913 Safefree(tmparyval);
2916 *MARK = &PL_sv_undef;
2924 djSP; dMARK; dORIGMARK; dTARGET;
2925 register AV *ary = (AV*)*++MARK;
2926 register SV *sv = &PL_sv_undef;
2929 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2930 *MARK-- = mg->mg_obj;
2934 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2939 /* Why no pre-extend of ary here ? */
2940 for (++MARK; MARK <= SP; MARK++) {
2943 sv_setsv(sv, *MARK);
2948 PUSHi( AvFILL(ary) + 1 );
2956 SV *sv = av_pop(av);
2958 (void)sv_2mortal(sv);
2967 SV *sv = av_shift(av);
2972 (void)sv_2mortal(sv);
2979 djSP; dMARK; dORIGMARK; dTARGET;
2980 register AV *ary = (AV*)*++MARK;
2985 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2986 *MARK-- = mg->mg_obj;
2990 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2995 av_unshift(ary, SP - MARK);
2998 sv_setsv(sv, *++MARK);
2999 (void)av_store(ary, i++, sv);
3003 PUSHi( AvFILL(ary) + 1 );
3013 if (GIMME == G_ARRAY) {
3024 register char *down;
3030 do_join(TARG, &PL_sv_no, MARK, SP);
3032 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3033 up = SvPV_force(TARG, len);
3035 if (IN_UTF8) { /* first reverse each character */
3036 unsigned char* s = SvPVX(TARG);
3037 unsigned char* send = s + len;
3047 if (s > send || !((*down & 0xc0) == 0x80)) {
3048 warn("Malformed UTF-8 character");
3060 down = SvPVX(TARG) + len - 1;
3066 (void)SvPOK_only(TARG);
3075 mul128(SV *sv, U8 m)
3078 char *s = SvPV(sv, len);
3082 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3083 SV *tmpNew = newSVpv("0000000000", 10);
3085 sv_catsv(tmpNew, sv);
3086 SvREFCNT_dec(sv); /* free old sv */
3091 while (!*t) /* trailing '\0'? */
3094 i = ((*t - '0') << 7) + m;
3095 *(t--) = '0' + (i % 10);
3101 /* Explosives and implosives. */
3108 I32 gimme = GIMME_V;
3112 register char *pat = SvPV(left, llen);
3113 register char *s = SvPV(right, rlen);
3114 char *strend = s + rlen;
3116 register char *patend = pat + llen;
3121 /* These must not be in registers: */
3132 unsigned Quad_t auquad;
3138 register U32 culong;
3140 static char* bitcount = 0;
3143 if (gimme != G_ARRAY) { /* arrange to do first one only */
3145 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3146 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3148 while (isDIGIT(*patend) || *patend == '*')
3154 while (pat < patend) {
3156 datumtype = *pat++ & 0xFF;
3157 if (isSPACE(datumtype))
3161 else if (*pat == '*') {
3162 len = strend - strbeg; /* long enough */
3165 else if (isDIGIT(*pat)) {
3167 while (isDIGIT(*pat))
3168 len = (len * 10) + (*pat++ - '0');
3171 len = (datumtype != '@');
3174 croak("Invalid type in unpack: '%c'", (int)datumtype);
3175 case ',': /* grandfather in commas but with a warning */
3176 if (commas++ == 0 && PL_dowarn)
3177 warn("Invalid type in unpack: '%c'", (int)datumtype);
3180 if (len == 1 && pat[-1] != '1')
3189 if (len > strend - strbeg)
3190 DIE("@ outside of string");
3194 if (len > s - strbeg)
3195 DIE("X outside of string");
3199 if (len > strend - s)
3200 DIE("x outside of string");
3205 if (len > strend - s)
3208 goto uchar_checksum;
3209 sv = NEWSV(35, len);
3210 sv_setpvn(sv, s, len);
3212 if (datumtype == 'A') {
3213 aptr = s; /* borrow register */
3214 s = SvPVX(sv) + len - 1;
3215 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3218 SvCUR_set(sv, s - SvPVX(sv));
3219 s = aptr; /* unborrow register */
3221 XPUSHs(sv_2mortal(sv));
3225 if (pat[-1] == '*' || len > (strend - s) * 8)
3226 len = (strend - s) * 8;
3229 Newz(601, bitcount, 256, char);
3230 for (bits = 1; bits < 256; bits++) {
3231 if (bits & 1) bitcount[bits]++;
3232 if (bits & 2) bitcount[bits]++;
3233 if (bits & 4) bitcount[bits]++;
3234 if (bits & 8) bitcount[bits]++;
3235 if (bits & 16) bitcount[bits]++;
3236 if (bits & 32) bitcount[bits]++;
3237 if (bits & 64) bitcount[bits]++;
3238 if (bits & 128) bitcount[bits]++;
3242 culong += bitcount[*(unsigned char*)s++];
3247 if (datumtype == 'b') {
3249 if (bits & 1) culong++;
3255 if (bits & 128) culong++;
3262 sv = NEWSV(35, len + 1);
3265 aptr = pat; /* borrow register */
3267 if (datumtype == 'b') {
3269 for (len = 0; len < aint; len++) {
3270 if (len & 7) /*SUPPRESS 595*/
3274 *pat++ = '0' + (bits & 1);
3279 for (len = 0; len < aint; len++) {
3284 *pat++ = '0' + ((bits & 128) != 0);
3288 pat = aptr; /* unborrow register */
3289 XPUSHs(sv_2mortal(sv));
3293 if (pat[-1] == '*' || len > (strend - s) * 2)
3294 len = (strend - s) * 2;
3295 sv = NEWSV(35, len + 1);
3298 aptr = pat; /* borrow register */
3300 if (datumtype == 'h') {
3302 for (len = 0; len < aint; len++) {
3307 *pat++ = PL_hexdigit[bits & 15];
3312 for (len = 0; len < aint; len++) {
3317 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3321 pat = aptr; /* unborrow register */
3322 XPUSHs(sv_2mortal(sv));
3325 if (len > strend - s)
3330 if (aint >= 128) /* fake up signed chars */
3340 if (aint >= 128) /* fake up signed chars */
3343 sv_setiv(sv, (IV)aint);
3344 PUSHs(sv_2mortal(sv));
3349 if (len > strend - s)
3364 sv_setiv(sv, (IV)auint);
3365 PUSHs(sv_2mortal(sv));
3370 if (len > strend - s)
3373 while (len-- > 0 && s < strend) {
3374 auint = utf8_to_uv(s, &along);
3382 while (len-- > 0 && s < strend) {
3383 auint = utf8_to_uv(s, &along);
3386 sv_setiv(sv, (IV)auint);
3387 PUSHs(sv_2mortal(sv));
3392 along = (strend - s) / SIZE16;
3409 sv_setiv(sv, (IV)ashort);
3410 PUSHs(sv_2mortal(sv));
3417 along = (strend - s) / SIZE16;
3422 COPY16(s, &aushort);
3425 if (datumtype == 'n')
3426 aushort = PerlSock_ntohs(aushort);
3429 if (datumtype == 'v')
3430 aushort = vtohs(aushort);
3439 COPY16(s, &aushort);
3443 if (datumtype == 'n')
3444 aushort = PerlSock_ntohs(aushort);
3447 if (datumtype == 'v')
3448 aushort = vtohs(aushort);
3450 sv_setiv(sv, (IV)aushort);
3451 PUSHs(sv_2mortal(sv));
3456 along = (strend - s) / sizeof(int);
3461 Copy(s, &aint, 1, int);
3464 cdouble += (double)aint;
3473 Copy(s, &aint, 1, int);
3477 /* Without the dummy below unpack("i", pack("i",-1))
3478 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3479 * cc with optimization turned on */
3481 sv_setiv(sv, (IV)aint) :
3483 sv_setiv(sv, (IV)aint);
3484 PUSHs(sv_2mortal(sv));
3489 along = (strend - s) / sizeof(unsigned int);
3494 Copy(s, &auint, 1, unsigned int);
3495 s += sizeof(unsigned int);
3497 cdouble += (double)auint;
3506 Copy(s, &auint, 1, unsigned int);
3507 s += sizeof(unsigned int);
3509 sv_setuv(sv, (UV)auint);
3510 PUSHs(sv_2mortal(sv));
3515 along = (strend - s) / SIZE32;
3523 cdouble += (double)along;
3535 sv_setiv(sv, (IV)along);
3536 PUSHs(sv_2mortal(sv));
3543 along = (strend - s) / SIZE32;
3551 if (datumtype == 'N')
3552 aulong = PerlSock_ntohl(aulong);
3555 if (datumtype == 'V')
3556 aulong = vtohl(aulong);
3559 cdouble += (double)aulong;
3571 if (datumtype == 'N')
3572 aulong = PerlSock_ntohl(aulong);
3575 if (datumtype == 'V')
3576 aulong = vtohl(aulong);
3579 sv_setuv(sv, (UV)aulong);
3580 PUSHs(sv_2mortal(sv));
3585 along = (strend - s) / sizeof(char*);
3591 if (sizeof(char*) > strend - s)
3594 Copy(s, &aptr, 1, char*);
3600 PUSHs(sv_2mortal(sv));
3610 while ((len > 0) && (s < strend)) {
3611 auv = (auv << 7) | (*s & 0x7f);
3612 if (!(*s++ & 0x80)) {
3616 PUSHs(sv_2mortal(sv));
3620 else if (++bytes >= sizeof(UV)) { /* promote to string */
3623 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3624 while (s < strend) {
3625 sv = mul128(sv, *s & 0x7f);
3626 if (!(*s++ & 0x80)) {
3631 t = SvPV(sv, PL_na);
3635 PUSHs(sv_2mortal(sv));
3640 if ((s >= strend) && bytes)
3641 croak("Unterminated compressed integer");
3646 if (sizeof(char*) > strend - s)
3649 Copy(s, &aptr, 1, char*);
3654 sv_setpvn(sv, aptr, len);
3655 PUSHs(sv_2mortal(sv));
3659 along = (strend - s) / sizeof(Quad_t);
3665 if (s + sizeof(Quad_t) > strend)
3668 Copy(s, &aquad, 1, Quad_t);
3669 s += sizeof(Quad_t);
3672 if (aquad >= IV_MIN && aquad <= IV_MAX)
3673 sv_setiv(sv, (IV)aquad);
3675 sv_setnv(sv, (double)aquad);
3676 PUSHs(sv_2mortal(sv));
3680 along = (strend - s) / sizeof(Quad_t);
3686 if (s + sizeof(unsigned Quad_t) > strend)
3689 Copy(s, &auquad, 1, unsigned Quad_t);
3690 s += sizeof(unsigned Quad_t);
3693 if (auquad <= UV_MAX)
3694 sv_setuv(sv, (UV)auquad);
3696 sv_setnv(sv, (double)auquad);
3697 PUSHs(sv_2mortal(sv));
3701 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3704 along = (strend - s) / sizeof(float);
3709 Copy(s, &afloat, 1, float);
3718 Copy(s, &afloat, 1, float);
3721 sv_setnv(sv, (double)afloat);
3722 PUSHs(sv_2mortal(sv));
3728 along = (strend - s) / sizeof(double);
3733 Copy(s, &adouble, 1, double);
3734 s += sizeof(double);
3742 Copy(s, &adouble, 1, double);
3743 s += sizeof(double);
3745 sv_setnv(sv, (double)adouble);
3746 PUSHs(sv_2mortal(sv));
3751 along = (strend - s) * 3 / 4;
3752 sv = NEWSV(42, along);
3755 while (s < strend && *s > ' ' && *s < 'a') {
3760 len = (*s++ - ' ') & 077;
3762 if (s < strend && *s >= ' ')
3763 a = (*s++ - ' ') & 077;
3766 if (s < strend && *s >= ' ')
3767 b = (*s++ - ' ') & 077;
3770 if (s < strend && *s >= ' ')
3771 c = (*s++ - ' ') & 077;
3774 if (s < strend && *s >= ' ')
3775 d = (*s++ - ' ') & 077;
3778 hunk[0] = (a << 2) | (b >> 4);
3779 hunk[1] = (b << 4) | (c >> 2);
3780 hunk[2] = (c << 6) | d;
3781 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3786 else if (s[1] == '\n') /* possible checksum byte */
3789 XPUSHs(sv_2mortal(sv));
3794 if (strchr("fFdD", datumtype) ||
3795 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3799 while (checksum >= 16) {
3803 while (checksum >= 4) {
3809 along = (1 << checksum) - 1;
3810 while (cdouble < 0.0)
3812 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3813 sv_setnv(sv, cdouble);
3816 if (checksum < 32) {
3817 aulong = (1 << checksum) - 1;
3820 sv_setuv(sv, (UV)culong);
3822 XPUSHs(sv_2mortal(sv));
3826 if (SP == oldsp && gimme == G_SCALAR)
3827 PUSHs(&PL_sv_undef);
3832 doencodes(register SV *sv, register char *s, register I32 len)
3837 sv_catpvn(sv, hunk, 1);
3840 hunk[0] = ' ' + (077 & (*s >> 2));
3841 hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
3842 hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
3843 hunk[3] = ' ' + (077 & (s[2] & 077));
3844 sv_catpvn(sv, hunk, 4);
3848 for (s = SvPVX(sv); *s; s++) {
3852 sv_catpvn(sv, "\n", 1);
3856 is_an_int(char *s, STRLEN l)
3858 SV *result = newSVpv("", l);
3859 char *result_c = SvPV(result, PL_na); /* convenience */
3860 char *out = result_c;
3870 SvREFCNT_dec(result);
3893 SvREFCNT_dec(result);
3899 SvCUR_set(result, out - result_c);
3904 div128(SV *pnum, bool *done)
3905 /* must be '\0' terminated */
3909 char *s = SvPV(pnum, len);
3918 i = m * 10 + (*t - '0');
3920 r = (i >> 7); /* r < 10 */
3927 SvCUR_set(pnum, (STRLEN) (t - s));
3934 djSP; dMARK; dORIGMARK; dTARGET;
3935 register SV *cat = TARG;
3938 register char *pat = SvPVx(*++MARK, fromlen);
3939 register char *patend = pat + fromlen;
3944 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3945 static char *space10 = " ";
3947 /* These must not be in registers: */
3956 unsigned Quad_t auquad;
3965 sv_setpvn(cat, "", 0);
3966 while (pat < patend) {
3967 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
3968 datumtype = *pat++ & 0xFF;
3969 if (isSPACE(datumtype))
3972 len = strchr("@Xxu", datumtype) ? 0 : items;
3975 else if (isDIGIT(*pat)) {
3977 while (isDIGIT(*pat))
3978 len = (len * 10) + (*pat++ - '0');
3984 croak("Invalid type in pack: '%c'", (int)datumtype);
3985 case ',': /* grandfather in commas but with a warning */
3986 if (commas++ == 0 && PL_dowarn)
3987 warn("Invalid type in pack: '%c'", (int)datumtype);
3990 DIE("%% may only be used in unpack");
4001 if (SvCUR(cat) < len)
4002 DIE("X outside of string");
4009 sv_catpvn(cat, null10, 10);
4012 sv_catpvn(cat, null10, len);
4017 aptr = SvPV(fromstr, fromlen);
4021 sv_catpvn(cat, aptr, len);
4023 sv_catpvn(cat, aptr, fromlen);
4025 if (datumtype == 'A') {
4027 sv_catpvn(cat, space10, 10);
4030 sv_catpvn(cat, space10, len);
4034 sv_catpvn(cat, null10, 10);
4037 sv_catpvn(cat, null10, len);
4044 char *savepat = pat;
4049 aptr = SvPV(fromstr, fromlen);
4054 SvCUR(cat) += (len+7)/8;
4055 SvGROW(cat, SvCUR(cat) + 1);
4056 aptr = SvPVX(cat) + aint;
4061 if (datumtype == 'B') {
4062 for (len = 0; len++ < aint;) {
4063 items |= *pat++ & 1;
4067 *aptr++ = items & 0xff;
4073 for (len = 0; len++ < aint;) {
4079 *aptr++ = items & 0xff;
4085 if (datumtype == 'B')
4086 items <<= 7 - (aint & 7);
4088 items >>= 7 - (aint & 7);
4089 *aptr++ = items & 0xff;
4091 pat = SvPVX(cat) + SvCUR(cat);
4102 char *savepat = pat;
4107 aptr = SvPV(fromstr, fromlen);
4112 SvCUR(cat) += (len+1)/2;
4113 SvGROW(cat, SvCUR(cat) + 1);
4114 aptr = SvPVX(cat) + aint;
4119 if (datumtype == 'H') {
4120 for (len = 0; len++ < aint;) {
4122 items |= ((*pat++ & 15) + 9) & 15;
4124 items |= *pat++ & 15;
4128 *aptr++ = items & 0xff;
4134 for (len = 0; len++ < aint;) {
4136 items |= (((*pat++ & 15) + 9) & 15) << 4;
4138 items |= (*pat++ & 15) << 4;
4142 *aptr++ = items & 0xff;
4148 *aptr++ = items & 0xff;
4149 pat = SvPVX(cat) + SvCUR(cat);
4161 aint = SvIV(fromstr);
4163 sv_catpvn(cat, &achar, sizeof(char));
4169 auint = SvUV(fromstr);
4170 SvGROW(cat, SvCUR(cat) + 10);
4171 SvCUR_set(cat, uv_to_utf8(SvEND(cat), auint) - SvPVX(cat));
4175 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4180 afloat = (float)SvNV(fromstr);
4181 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4188 adouble = (double)SvNV(fromstr);
4189 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4195 ashort = (I16)SvIV(fromstr);
4197 ashort = PerlSock_htons(ashort);
4199 CAT16(cat, &ashort);
4205 ashort = (I16)SvIV(fromstr);
4207 ashort = htovs(ashort);
4209 CAT16(cat, &ashort);
4216 ashort = (I16)SvIV(fromstr);
4217 CAT16(cat, &ashort);
4223 auint = SvUV(fromstr);
4224 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4230 adouble = floor(SvNV(fromstr));
4233 croak("Cannot compress negative numbers");
4239 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4240 adouble <= UV_MAX_cxux
4247 char buf[1 + sizeof(UV)];
4248 char *in = buf + sizeof(buf);
4249 UV auv = U_V(adouble);;
4252 *--in = (auv & 0x7f) | 0x80;
4255 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4256 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4258 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4259 char *from, *result, *in;
4264 /* Copy string and check for compliance */
4265 from = SvPV(fromstr, len);
4266 if ((norm = is_an_int(from, len)) == NULL)
4267 croak("can compress only unsigned integer");
4269 New('w', result, len, char);
4273 *--in = div128(norm, &done) | 0x80;
4274 result[len - 1] &= 0x7F; /* clear continue bit */
4275 sv_catpvn(cat, in, (result + len) - in);
4277 SvREFCNT_dec(norm); /* free norm */
4279 else if (SvNOKp(fromstr)) {
4280 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4281 char *in = buf + sizeof(buf);
4284 double next = floor(adouble / 128);
4285 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4286 if (--in < buf) /* this cannot happen ;-) */
4287 croak ("Cannot compress integer");
4289 } while (adouble > 0);
4290 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4291 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4294 croak("Cannot compress non integer");
4300 aint = SvIV(fromstr);
4301 sv_catpvn(cat, (char*)&aint, sizeof(int));
4307 aulong = SvUV(fromstr);
4309 aulong = PerlSock_htonl(aulong);
4311 CAT32(cat, &aulong);
4317 aulong = SvUV(fromstr);
4319 aulong = htovl(aulong);
4321 CAT32(cat, &aulong);
4327 aulong = SvUV(fromstr);
4328 CAT32(cat, &aulong);
4334 along = SvIV(fromstr);
4342 auquad = (unsigned Quad_t)SvIV(fromstr);
4343 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4349 aquad = (Quad_t)SvIV(fromstr);
4350 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4353 #endif /* HAS_QUAD */
4355 len = 1; /* assume SV is correct length */
4360 if (fromstr == &PL_sv_undef)
4363 /* XXX better yet, could spirit away the string to
4364 * a safe spot and hang on to it until the result
4365 * of pack() (and all copies of the result) are
4368 if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4369 warn("Attempt to pack pointer to temporary value");
4370 if (SvPOK(fromstr) || SvNIOK(fromstr))
4371 aptr = SvPV(fromstr,PL_na);
4373 aptr = SvPV_force(fromstr,PL_na);
4375 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4380 aptr = SvPV(fromstr, fromlen);
4381 SvGROW(cat, fromlen * 4 / 3);
4386 while (fromlen > 0) {
4393 doencodes(cat, aptr, todo);
4412 register I32 limit = POPi; /* note, negative is forever */
4415 register char *s = SvPV(sv, len);
4416 char *strend = s + len;
4418 register REGEXP *rx;
4422 I32 maxiters = (strend - s) + 10;
4425 I32 origlimit = limit;
4428 AV *oldstack = PL_curstack;
4429 I32 gimme = GIMME_V;
4430 I32 oldsave = PL_savestack_ix;
4431 I32 make_mortal = 1;
4432 MAGIC *mg = (MAGIC *) NULL;
4435 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4440 DIE("panic: do_split");
4441 rx = pm->op_pmregexp;
4443 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4444 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4446 if (pm->op_pmreplroot)
4447 ary = GvAVn((GV*)pm->op_pmreplroot);
4448 else if (gimme != G_ARRAY)
4450 ary = (AV*)PL_curpad[0];
4452 ary = GvAVn(PL_defgv);
4453 #endif /* USE_THREADS */
4456 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4462 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4469 for (i = AvFILLp(ary); i >= 0; i--)
4470 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4472 /* temporarily switch stacks */
4473 SWITCHSTACK(PL_curstack, ary);
4477 base = SP - PL_stack_base;
4479 if (pm->op_pmflags & PMf_SKIPWHITE) {
4480 if (pm->op_pmflags & PMf_LOCALE) {
4481 while (isSPACE_LC(*s))
4489 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4490 SAVEINT(PL_multiline);
4491 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4495 limit = maxiters + 2;
4496 if (pm->op_pmflags & PMf_WHITE) {
4499 while (m < strend &&
4500 !((pm->op_pmflags & PMf_LOCALE)
4501 ? isSPACE_LC(*m) : isSPACE(*m)))
4506 dstr = NEWSV(30, m-s);
4507 sv_setpvn(dstr, s, m-s);
4513 while (s < strend &&
4514 ((pm->op_pmflags & PMf_LOCALE)
4515 ? isSPACE_LC(*s) : isSPACE(*s)))
4519 else if (strEQ("^", rx->precomp)) {
4522 for (m = s; m < strend && *m != '\n'; m++) ;
4526 dstr = NEWSV(30, m-s);
4527 sv_setpvn(dstr, s, m-s);
4534 else if (rx->check_substr && !rx->nparens
4535 && (rx->reganch & ROPT_CHECK_ALL)
4536 && !(rx->reganch & ROPT_ANCH)) {
4537 i = SvCUR(rx->check_substr);
4538 if (i == 1 && !SvTAIL(rx->check_substr)) {
4539 i = *SvPVX(rx->check_substr);
4542 for (m = s; m < strend && *m != i; m++) ;
4545 dstr = NEWSV(30, m-s);
4546 sv_setpvn(dstr, s, m-s);
4555 while (s < strend && --limit &&
4556 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4557 rx->check_substr, 0)) )
4560 dstr = NEWSV(31, m-s);
4561 sv_setpvn(dstr, s, m-s);
4570 maxiters += (strend - s) * rx->nparens;
4571 while (s < strend && --limit &&
4572 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4574 TAINT_IF(RX_MATCH_TAINTED(rx));
4576 && rx->subbase != orig) {
4581 strend = s + (strend - m);
4584 dstr = NEWSV(32, m-s);
4585 sv_setpvn(dstr, s, m-s);
4590 for (i = 1; i <= rx->nparens; i++) {
4594 dstr = NEWSV(33, m-s);
4595 sv_setpvn(dstr, s, m-s);
4598 dstr = NEWSV(33, 0);
4608 LEAVE_SCOPE(oldsave);
4609 iters = (SP - PL_stack_base) - base;
4610 if (iters > maxiters)
4613 /* keep field after final delim? */
4614 if (s < strend || (iters && origlimit)) {
4615 dstr = NEWSV(34, strend-s);
4616 sv_setpvn(dstr, s, strend-s);
4622 else if (!origlimit) {
4623 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4629 SWITCHSTACK(ary, oldstack);
4630 if (SvSMAGICAL(ary)) {
4635 if (gimme == G_ARRAY) {
4637 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4645 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4648 if (gimme == G_ARRAY) {
4649 /* EXTEND should not be needed - we just popped them */
4651 for (i=0; i < iters; i++) {
4652 SV **svp = av_fetch(ary, i, FALSE);
4653 PUSHs((svp) ? *svp : &PL_sv_undef);
4660 if (gimme == G_ARRAY)
4663 if (iters || !pm->op_pmreplroot) {
4673 unlock_condpair(void *svv)
4676 MAGIC *mg = mg_find((SV*)svv, 'm');
4679 croak("panic: unlock_condpair unlocking non-mutex");
4680 MUTEX_LOCK(MgMUTEXP(mg));
4681 if (MgOWNER(mg) != thr)
4682 croak("panic: unlock_condpair unlocking mutex that we don't own");
4684 COND_SIGNAL(MgOWNERCONDP(mg));
4685 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4686 (unsigned long)thr, (unsigned long)svv);)
4687 MUTEX_UNLOCK(MgMUTEXP(mg));
4689 #endif /* USE_THREADS */
4702 mg = condpair_magic(sv);
4703 MUTEX_LOCK(MgMUTEXP(mg));
4704 if (MgOWNER(mg) == thr)
4705 MUTEX_UNLOCK(MgMUTEXP(mg));
4708 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4710 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4711 (unsigned long)thr, (unsigned long)sv);)
4712 MUTEX_UNLOCK(MgMUTEXP(mg));
4713 SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
4714 save_destructor(unlock_condpair, sv);
4716 #endif /* USE_THREADS */
4717 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4718 || SvTYPE(retsv) == SVt_PVCV) {
4719 retsv = refto(retsv);
4730 if (PL_op->op_private & OPpLVAL_INTRO)
4731 PUSHs(*save_threadsv(PL_op->op_targ));
4733 PUSHs(THREADSV(PL_op->op_targ));
4736 DIE("tried to access per-thread data in non-threaded perl");
4737 #endif /* USE_THREADS */