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)
1845 if (pos >= arybase) {
1863 else if (len >= 0) {
1865 if (rem > (I32)curlen)
1879 if (PL_dowarn || lvalue || repl)
1880 warn("substr outside of string");
1885 sv_pos_u2b(sv, &pos, &rem);
1887 sv_setpvn(TARG, tmps, rem);
1888 if (lvalue) { /* it's an lvalue! */
1889 if (!SvGMAGICAL(sv)) {
1891 SvPV_force(sv,PL_na);
1893 warn("Attempt to use reference as lvalue in substr");
1895 if (SvOK(sv)) /* is it defined ? */
1896 (void)SvPOK_only(sv);
1898 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1901 if (SvTYPE(TARG) < SVt_PVLV) {
1902 sv_upgrade(TARG, SVt_PVLV);
1903 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1907 if (LvTARG(TARG) != sv) {
1909 SvREFCNT_dec(LvTARG(TARG));
1910 LvTARG(TARG) = SvREFCNT_inc(sv);
1912 LvTARGOFF(TARG) = pos;
1913 LvTARGLEN(TARG) = rem;
1916 sv_insert(sv, pos, rem, repl, repl_len);
1919 PUSHs(TARG); /* avoid SvSETMAGIC here */
1926 register I32 size = POPi;
1927 register I32 offset = POPi;
1928 register SV *src = POPs;
1929 I32 lvalue = PL_op->op_flags & OPf_MOD;
1931 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1932 unsigned long retnum;
1935 SvTAINTED_off(TARG); /* decontaminate */
1936 offset *= size; /* turn into bit offset */
1937 len = (offset + size + 7) / 8;
1938 if (offset < 0 || size < 1)
1941 if (lvalue) { /* it's an lvalue! */
1942 if (SvTYPE(TARG) < SVt_PVLV) {
1943 sv_upgrade(TARG, SVt_PVLV);
1944 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1948 if (LvTARG(TARG) != src) {
1950 SvREFCNT_dec(LvTARG(TARG));
1951 LvTARG(TARG) = SvREFCNT_inc(src);
1953 LvTARGOFF(TARG) = offset;
1954 LvTARGLEN(TARG) = size;
1962 if (offset >= srclen)
1965 retnum = (unsigned long) s[offset] << 8;
1967 else if (size == 32) {
1968 if (offset >= srclen)
1970 else if (offset + 1 >= srclen)
1971 retnum = (unsigned long) s[offset] << 24;
1972 else if (offset + 2 >= srclen)
1973 retnum = ((unsigned long) s[offset] << 24) +
1974 ((unsigned long) s[offset + 1] << 16);
1976 retnum = ((unsigned long) s[offset] << 24) +
1977 ((unsigned long) s[offset + 1] << 16) +
1978 (s[offset + 2] << 8);
1983 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1988 else if (size == 16)
1989 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1990 else if (size == 32)
1991 retnum = ((unsigned long) s[offset] << 24) +
1992 ((unsigned long) s[offset + 1] << 16) +
1993 (s[offset + 2] << 8) + s[offset+3];
1997 sv_setuv(TARG, (UV)retnum);
2012 I32 arybase = PL_curcop->cop_arybase;
2017 offset = POPi - arybase;
2020 tmps = SvPV(big, biglen);
2021 if (IN_UTF8 && offset > 0)
2022 sv_pos_u2b(big, &offset, 0);
2025 else if (offset > biglen)
2027 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2028 (unsigned char*)tmps + biglen, little, 0)))
2031 retval = tmps2 - tmps;
2032 if (IN_UTF8 && retval > 0)
2033 sv_pos_b2u(big, &retval);
2034 PUSHi(retval + arybase);
2049 I32 arybase = PL_curcop->cop_arybase;
2055 tmps2 = SvPV(little, llen);
2056 tmps = SvPV(big, blen);
2060 if (IN_UTF8 && offset > 0)
2061 sv_pos_u2b(big, &offset, 0);
2062 offset = offset - arybase + llen;
2066 else if (offset > blen)
2068 if (!(tmps2 = rninstr(tmps, tmps + offset,
2069 tmps2, tmps2 + llen)))
2072 retval = tmps2 - tmps;
2073 if (IN_UTF8 && retval > 0)
2074 sv_pos_b2u(big, &retval);
2075 PUSHi(retval + arybase);
2081 djSP; dMARK; dORIGMARK; dTARGET;
2082 #ifdef USE_LOCALE_NUMERIC
2083 if (PL_op->op_private & OPpLOCALE)
2084 SET_NUMERIC_LOCAL();
2086 SET_NUMERIC_STANDARD();
2088 do_sprintf(TARG, SP-MARK, MARK+1);
2089 TAINT_IF(SvTAINTED(TARG));
2102 if (IN_UTF8 && (*tmps & 0x80))
2103 value = (I32) utf8_to_uv(tmps, &retlen);
2105 value = (I32) (*tmps & 255);
2116 (void)SvUPGRADE(TARG,SVt_PV);
2118 if (IN_UTF8 && value >= 128) {
2121 tmps = uv_to_utf8(tmps, (UV)value);
2122 SvCUR_set(TARG, tmps - SvPVX(TARG));
2124 (void)SvPOK_only(TARG);
2134 (void)SvPOK_only(TARG);
2141 djSP; dTARGET; dPOPTOPssrl;
2143 char *tmps = SvPV(left, PL_na);
2145 sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
2147 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
2151 "The crypt() function is unimplemented due to excessive paranoia.");
2164 if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2168 UV uv = utf8_to_uv(s, &ulen);
2170 if (PL_op->op_private & OPpLOCALE) {
2173 uv = toTITLE_LC_uni(uv);
2176 uv = toTITLE_utf8(s);
2178 tend = uv_to_utf8(tmpbuf, uv);
2180 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2182 sv_setpvn(TARG, tmpbuf, tend - tmpbuf);
2183 sv_catpvn(TARG, s + ulen, slen - ulen);
2187 s = SvPV_force(sv, slen);
2188 Copy(tmpbuf, s, ulen, U8);
2193 if (!SvPADTMP(sv)) {
2199 s = SvPV_force(sv, PL_na);
2201 if (PL_op->op_private & OPpLOCALE) {
2204 *s = toUPPER_LC(*s);
2220 if (IN_UTF8 && (s = SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2224 UV uv = utf8_to_uv(s, &ulen);
2226 if (PL_op->op_private & OPpLOCALE) {
2229 uv = toLOWER_LC_uni(uv);
2232 uv = toLOWER_utf8(s);
2234 tend = uv_to_utf8(tmpbuf, uv);
2236 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2238 sv_setpvn(TARG, tmpbuf, tend - tmpbuf);
2239 sv_catpvn(TARG, s + ulen, slen - ulen);
2243 s = SvPV_force(sv, slen);
2244 Copy(tmpbuf, s, ulen, U8);
2249 if (!SvPADTMP(sv)) {
2255 s = SvPV_force(sv, PL_na);
2257 if (PL_op->op_private & OPpLOCALE) {
2260 *s = toLOWER_LC(*s);
2287 (void)SvUPGRADE(TARG, SVt_PV);
2288 SvGROW(TARG, (len * 2) + 1);
2289 (void)SvPOK_only(TARG);
2292 if (PL_op->op_private & OPpLOCALE) {
2296 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2302 d = uv_to_utf8(d, toUPPER_utf8( s ));
2307 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2312 if (!SvPADTMP(sv)) {
2319 s = SvPV_force(sv, len);
2321 register U8 *send = s + len;
2323 if (PL_op->op_private & OPpLOCALE) {
2326 for (; s < send; s++)
2327 *s = toUPPER_LC(*s);
2330 for (; s < send; s++)
2354 (void)SvUPGRADE(TARG, SVt_PV);
2355 SvGROW(TARG, (len * 2) + 1);
2356 (void)SvPOK_only(TARG);
2359 if (PL_op->op_private & OPpLOCALE) {
2363 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2369 d = uv_to_utf8(d, toLOWER_utf8(s));
2374 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2379 if (!SvPADTMP(sv)) {
2386 s = SvPV_force(sv, len);
2388 register U8 *send = s + len;
2390 if (PL_op->op_private & OPpLOCALE) {
2393 for (; s < send; s++)
2394 *s = toLOWER_LC(*s);
2397 for (; s < send; s++)
2409 register char *s = SvPV(sv,len);
2413 (void)SvUPGRADE(TARG, SVt_PV);
2414 SvGROW(TARG, (len * 2) + 1);
2417 if (!(*s & 0x80) && !isALNUM(*s))
2422 SvCUR_set(TARG, d - SvPVX(TARG));
2423 (void)SvPOK_only(TARG);
2426 sv_setpvn(TARG, s, len);
2435 djSP; dMARK; dORIGMARK;
2437 register AV* av = (AV*)POPs;
2438 register I32 lval = PL_op->op_flags & OPf_MOD;
2439 I32 arybase = PL_curcop->cop_arybase;
2442 if (SvTYPE(av) == SVt_PVAV) {
2443 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2445 for (svp = MARK + 1; svp <= SP; svp++) {
2450 if (max > AvMAX(av))
2453 while (++MARK <= SP) {
2454 elem = SvIVx(*MARK);
2458 svp = av_fetch(av, elem, lval);
2460 if (!svp || *svp == &PL_sv_undef)
2461 DIE(no_aelem, elem);
2462 if (PL_op->op_private & OPpLVAL_INTRO)
2463 save_aelem(av, elem, svp);
2465 *MARK = svp ? *svp : &PL_sv_undef;
2468 if (GIMME != G_ARRAY) {
2476 /* Associative arrays. */
2481 HV *hash = (HV*)POPs;
2483 I32 gimme = GIMME_V;
2484 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2487 /* might clobber stack_sp */
2488 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2493 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2494 if (gimme == G_ARRAY) {
2496 /* might clobber stack_sp */
2497 sv_setsv(TARG, realhv ?
2498 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2503 else if (gimme == G_SCALAR)
2522 I32 gimme = GIMME_V;
2523 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2527 if (PL_op->op_private & OPpSLICE) {
2531 hvtype = SvTYPE(hv);
2532 while (++MARK <= SP) {
2533 if (hvtype == SVt_PVHV)
2534 sv = hv_delete_ent(hv, *MARK, discard, 0);
2536 DIE("Not a HASH reference");
2537 *MARK = sv ? sv : &PL_sv_undef;
2541 else if (gimme == G_SCALAR) {
2550 if (SvTYPE(hv) == SVt_PVHV)
2551 sv = hv_delete_ent(hv, keysv, discard, 0);
2553 DIE("Not a HASH reference");
2567 if (SvTYPE(hv) == SVt_PVHV) {
2568 if (hv_exists_ent(hv, tmpsv, 0))
2570 } else if (SvTYPE(hv) == SVt_PVAV) {
2571 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2574 DIE("Not a HASH reference");
2581 djSP; dMARK; dORIGMARK;
2582 register HV *hv = (HV*)POPs;
2583 register I32 lval = PL_op->op_flags & OPf_MOD;
2584 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2586 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2587 DIE("Can't localize pseudo-hash element");
2589 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2590 while (++MARK <= SP) {
2594 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2595 svp = he ? &HeVAL(he) : 0;
2597 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2600 if (!svp || *svp == &PL_sv_undef)
2601 DIE(no_helem, SvPV(keysv, PL_na));
2602 if (PL_op->op_private & OPpLVAL_INTRO)
2603 save_helem(hv, keysv, svp);
2605 *MARK = svp ? *svp : &PL_sv_undef;
2608 if (GIMME != G_ARRAY) {
2616 /* List operators. */
2621 if (GIMME != G_ARRAY) {
2623 *MARK = *SP; /* unwanted list, return last item */
2625 *MARK = &PL_sv_undef;
2634 SV **lastrelem = PL_stack_sp;
2635 SV **lastlelem = PL_stack_base + POPMARK;
2636 SV **firstlelem = PL_stack_base + POPMARK + 1;
2637 register SV **firstrelem = lastlelem + 1;
2638 I32 arybase = PL_curcop->cop_arybase;
2639 I32 lval = PL_op->op_flags & OPf_MOD;
2640 I32 is_something_there = lval;
2642 register I32 max = lastrelem - lastlelem;
2643 register SV **lelem;
2646 if (GIMME != G_ARRAY) {
2647 ix = SvIVx(*lastlelem);
2652 if (ix < 0 || ix >= max)
2653 *firstlelem = &PL_sv_undef;
2655 *firstlelem = firstrelem[ix];
2661 SP = firstlelem - 1;
2665 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2670 *lelem = &PL_sv_undef;
2671 else if (!(*lelem = firstrelem[ix]))
2672 *lelem = &PL_sv_undef;
2676 if (ix >= max || !(*lelem = firstrelem[ix]))
2677 *lelem = &PL_sv_undef;
2679 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2680 is_something_there = TRUE;
2682 if (is_something_there)
2685 SP = firstlelem - 1;
2691 djSP; dMARK; dORIGMARK;
2692 I32 items = SP - MARK;
2693 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2694 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2701 djSP; dMARK; dORIGMARK;
2702 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2706 SV *val = NEWSV(46, 0);
2708 sv_setsv(val, *++MARK);
2710 warn("Odd number of elements in hash assignment");
2711 (void)hv_store_ent(hv,key,val,0);
2720 djSP; dMARK; dORIGMARK;
2721 register AV *ary = (AV*)*++MARK;
2725 register I32 offset;
2726 register I32 length;
2733 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2734 *MARK-- = mg->mg_obj;
2738 perl_call_method("SPLICE",GIMME_V);
2747 offset = i = SvIVx(*MARK);
2749 offset += AvFILLp(ary) + 1;
2751 offset -= PL_curcop->cop_arybase;
2755 length = SvIVx(*MARK++);
2757 length += AvFILLp(ary) - offset + 1;
2763 length = AvMAX(ary) + 1; /* close enough to infinity */
2767 length = AvMAX(ary) + 1;
2769 if (offset > AvFILLp(ary) + 1)
2770 offset = AvFILLp(ary) + 1;
2771 after = AvFILLp(ary) + 1 - (offset + length);
2772 if (after < 0) { /* not that much array */
2773 length += after; /* offset+length now in array */
2779 /* At this point, MARK .. SP-1 is our new LIST */
2782 diff = newlen - length;
2783 if (newlen && !AvREAL(ary)) {
2787 assert(AvREAL(ary)); /* would leak, so croak */
2790 if (diff < 0) { /* shrinking the area */
2792 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2793 Copy(MARK, tmparyval, newlen, SV*);
2796 MARK = ORIGMARK + 1;
2797 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2798 MEXTEND(MARK, length);
2799 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2801 EXTEND_MORTAL(length);
2802 for (i = length, dst = MARK; i; i--) {
2803 sv_2mortal(*dst); /* free them eventualy */
2810 *MARK = AvARRAY(ary)[offset+length-1];
2813 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2814 SvREFCNT_dec(*dst++); /* free them now */
2817 AvFILLp(ary) += diff;
2819 /* pull up or down? */
2821 if (offset < after) { /* easier to pull up */
2822 if (offset) { /* esp. if nothing to pull */
2823 src = &AvARRAY(ary)[offset-1];
2824 dst = src - diff; /* diff is negative */
2825 for (i = offset; i > 0; i--) /* can't trust Copy */
2829 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2833 if (after) { /* anything to pull down? */
2834 src = AvARRAY(ary) + offset + length;
2835 dst = src + diff; /* diff is negative */
2836 Move(src, dst, after, SV*);
2838 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2839 /* avoid later double free */
2843 dst[--i] = &PL_sv_undef;
2846 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2848 *dst = NEWSV(46, 0);
2849 sv_setsv(*dst++, *src++);
2851 Safefree(tmparyval);
2854 else { /* no, expanding (or same) */
2856 New(452, tmparyval, length, SV*); /* so remember deletion */
2857 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2860 if (diff > 0) { /* expanding */
2862 /* push up or down? */
2864 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2868 Move(src, dst, offset, SV*);
2870 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2872 AvFILLp(ary) += diff;
2875 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2876 av_extend(ary, AvFILLp(ary) + diff);
2877 AvFILLp(ary) += diff;
2880 dst = AvARRAY(ary) + AvFILLp(ary);
2882 for (i = after; i; i--) {
2889 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2890 *dst = NEWSV(46, 0);
2891 sv_setsv(*dst++, *src++);
2893 MARK = ORIGMARK + 1;
2894 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2896 Copy(tmparyval, MARK, length, SV*);
2898 EXTEND_MORTAL(length);
2899 for (i = length, dst = MARK; i; i--) {
2900 sv_2mortal(*dst); /* free them eventualy */
2904 Safefree(tmparyval);
2908 else if (length--) {
2909 *MARK = tmparyval[length];
2912 while (length-- > 0)
2913 SvREFCNT_dec(tmparyval[length]);
2915 Safefree(tmparyval);
2918 *MARK = &PL_sv_undef;
2926 djSP; dMARK; dORIGMARK; dTARGET;
2927 register AV *ary = (AV*)*++MARK;
2928 register SV *sv = &PL_sv_undef;
2931 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2932 *MARK-- = mg->mg_obj;
2936 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2941 /* Why no pre-extend of ary here ? */
2942 for (++MARK; MARK <= SP; MARK++) {
2945 sv_setsv(sv, *MARK);
2950 PUSHi( AvFILL(ary) + 1 );
2958 SV *sv = av_pop(av);
2960 (void)sv_2mortal(sv);
2969 SV *sv = av_shift(av);
2974 (void)sv_2mortal(sv);
2981 djSP; dMARK; dORIGMARK; dTARGET;
2982 register AV *ary = (AV*)*++MARK;
2987 if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2988 *MARK-- = mg->mg_obj;
2992 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2997 av_unshift(ary, SP - MARK);
3000 sv_setsv(sv, *++MARK);
3001 (void)av_store(ary, i++, sv);
3005 PUSHi( AvFILL(ary) + 1 );
3015 if (GIMME == G_ARRAY) {
3026 register char *down;
3032 do_join(TARG, &PL_sv_no, MARK, SP);
3034 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3035 up = SvPV_force(TARG, len);
3037 if (IN_UTF8) { /* first reverse each character */
3038 unsigned char* s = SvPVX(TARG);
3039 unsigned char* send = s + len;
3049 if (s > send || !((*down & 0xc0) == 0x80)) {
3050 warn("Malformed UTF-8 character");
3062 down = SvPVX(TARG) + len - 1;
3068 (void)SvPOK_only(TARG);
3077 mul128(SV *sv, U8 m)
3080 char *s = SvPV(sv, len);
3084 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3085 SV *tmpNew = newSVpv("0000000000", 10);
3087 sv_catsv(tmpNew, sv);
3088 SvREFCNT_dec(sv); /* free old sv */
3093 while (!*t) /* trailing '\0'? */
3096 i = ((*t - '0') << 7) + m;
3097 *(t--) = '0' + (i % 10);
3103 /* Explosives and implosives. */
3105 static const char uuemap[] =
3106 "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3107 static char uudmap[256]; /* Initialised on first use */
3108 #if 'I' == 73 && 'J' == 74
3109 /* On an ASCII/ISO kind of system */
3110 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3113 Some other sort of character set - use memchr() so we don't match
3116 #define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
3124 I32 gimme = GIMME_V;
3128 register char *pat = SvPV(left, llen);
3129 register char *s = SvPV(right, rlen);
3130 char *strend = s + rlen;
3132 register char *patend = pat + llen;
3137 /* These must not be in registers: */
3148 unsigned Quad_t auquad;
3154 register U32 culong;
3156 static char* bitcount = 0;
3159 if (gimme != G_ARRAY) { /* arrange to do first one only */
3161 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3162 if (strchr("aAbBhHP", *patend) || *pat == '%') {
3164 while (isDIGIT(*patend) || *patend == '*')
3170 while (pat < patend) {
3172 datumtype = *pat++ & 0xFF;
3173 if (isSPACE(datumtype))
3177 else if (*pat == '*') {
3178 len = strend - strbeg; /* long enough */
3181 else if (isDIGIT(*pat)) {
3183 while (isDIGIT(*pat))
3184 len = (len * 10) + (*pat++ - '0');
3187 len = (datumtype != '@');
3190 croak("Invalid type in unpack: '%c'", (int)datumtype);
3191 case ',': /* grandfather in commas but with a warning */
3192 if (commas++ == 0 && PL_dowarn)
3193 warn("Invalid type in unpack: '%c'", (int)datumtype);
3196 if (len == 1 && pat[-1] != '1')
3205 if (len > strend - strbeg)
3206 DIE("@ outside of string");
3210 if (len > s - strbeg)
3211 DIE("X outside of string");
3215 if (len > strend - s)
3216 DIE("x outside of string");
3221 if (len > strend - s)
3224 goto uchar_checksum;
3225 sv = NEWSV(35, len);
3226 sv_setpvn(sv, s, len);
3228 if (datumtype == 'A') {
3229 aptr = s; /* borrow register */
3230 s = SvPVX(sv) + len - 1;
3231 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3234 SvCUR_set(sv, s - SvPVX(sv));
3235 s = aptr; /* unborrow register */
3237 XPUSHs(sv_2mortal(sv));
3241 if (pat[-1] == '*' || len > (strend - s) * 8)
3242 len = (strend - s) * 8;
3245 Newz(601, bitcount, 256, char);
3246 for (bits = 1; bits < 256; bits++) {
3247 if (bits & 1) bitcount[bits]++;
3248 if (bits & 2) bitcount[bits]++;
3249 if (bits & 4) bitcount[bits]++;
3250 if (bits & 8) bitcount[bits]++;
3251 if (bits & 16) bitcount[bits]++;
3252 if (bits & 32) bitcount[bits]++;
3253 if (bits & 64) bitcount[bits]++;
3254 if (bits & 128) bitcount[bits]++;
3258 culong += bitcount[*(unsigned char*)s++];
3263 if (datumtype == 'b') {
3265 if (bits & 1) culong++;
3271 if (bits & 128) culong++;
3278 sv = NEWSV(35, len + 1);
3281 aptr = pat; /* borrow register */
3283 if (datumtype == 'b') {
3285 for (len = 0; len < aint; len++) {
3286 if (len & 7) /*SUPPRESS 595*/
3290 *pat++ = '0' + (bits & 1);
3295 for (len = 0; len < aint; len++) {
3300 *pat++ = '0' + ((bits & 128) != 0);
3304 pat = aptr; /* unborrow register */
3305 XPUSHs(sv_2mortal(sv));
3309 if (pat[-1] == '*' || len > (strend - s) * 2)
3310 len = (strend - s) * 2;
3311 sv = NEWSV(35, len + 1);
3314 aptr = pat; /* borrow register */
3316 if (datumtype == 'h') {
3318 for (len = 0; len < aint; len++) {
3323 *pat++ = PL_hexdigit[bits & 15];
3328 for (len = 0; len < aint; len++) {
3333 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3337 pat = aptr; /* unborrow register */
3338 XPUSHs(sv_2mortal(sv));
3341 if (len > strend - s)
3346 if (aint >= 128) /* fake up signed chars */
3356 if (aint >= 128) /* fake up signed chars */
3359 sv_setiv(sv, (IV)aint);
3360 PUSHs(sv_2mortal(sv));
3365 if (len > strend - s)
3380 sv_setiv(sv, (IV)auint);
3381 PUSHs(sv_2mortal(sv));
3386 if (len > strend - s)
3389 while (len-- > 0 && s < strend) {
3390 auint = utf8_to_uv(s, &along);
3398 while (len-- > 0 && s < strend) {
3399 auint = utf8_to_uv(s, &along);
3402 sv_setiv(sv, (IV)auint);
3403 PUSHs(sv_2mortal(sv));
3408 along = (strend - s) / SIZE16;
3425 sv_setiv(sv, (IV)ashort);
3426 PUSHs(sv_2mortal(sv));
3433 along = (strend - s) / SIZE16;
3438 COPY16(s, &aushort);
3441 if (datumtype == 'n')
3442 aushort = PerlSock_ntohs(aushort);
3445 if (datumtype == 'v')
3446 aushort = vtohs(aushort);
3455 COPY16(s, &aushort);
3459 if (datumtype == 'n')
3460 aushort = PerlSock_ntohs(aushort);
3463 if (datumtype == 'v')
3464 aushort = vtohs(aushort);
3466 sv_setiv(sv, (IV)aushort);
3467 PUSHs(sv_2mortal(sv));
3472 along = (strend - s) / sizeof(int);
3477 Copy(s, &aint, 1, int);
3480 cdouble += (double)aint;
3489 Copy(s, &aint, 1, int);
3493 /* Without the dummy below unpack("i", pack("i",-1))
3494 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3495 * cc with optimization turned on */
3497 sv_setiv(sv, (IV)aint) :
3499 sv_setiv(sv, (IV)aint);
3500 PUSHs(sv_2mortal(sv));
3505 along = (strend - s) / sizeof(unsigned int);
3510 Copy(s, &auint, 1, unsigned int);
3511 s += sizeof(unsigned int);
3513 cdouble += (double)auint;
3522 Copy(s, &auint, 1, unsigned int);
3523 s += sizeof(unsigned int);
3525 sv_setuv(sv, (UV)auint);
3526 PUSHs(sv_2mortal(sv));
3531 along = (strend - s) / SIZE32;
3539 cdouble += (double)along;
3551 sv_setiv(sv, (IV)along);
3552 PUSHs(sv_2mortal(sv));
3559 along = (strend - s) / SIZE32;
3567 if (datumtype == 'N')
3568 aulong = PerlSock_ntohl(aulong);
3571 if (datumtype == 'V')
3572 aulong = vtohl(aulong);
3575 cdouble += (double)aulong;
3587 if (datumtype == 'N')
3588 aulong = PerlSock_ntohl(aulong);
3591 if (datumtype == 'V')
3592 aulong = vtohl(aulong);
3595 sv_setuv(sv, (UV)aulong);
3596 PUSHs(sv_2mortal(sv));
3601 along = (strend - s) / sizeof(char*);
3607 if (sizeof(char*) > strend - s)
3610 Copy(s, &aptr, 1, char*);
3616 PUSHs(sv_2mortal(sv));
3626 while ((len > 0) && (s < strend)) {
3627 auv = (auv << 7) | (*s & 0x7f);
3628 if (!(*s++ & 0x80)) {
3632 PUSHs(sv_2mortal(sv));
3636 else if (++bytes >= sizeof(UV)) { /* promote to string */
3639 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3640 while (s < strend) {
3641 sv = mul128(sv, *s & 0x7f);
3642 if (!(*s++ & 0x80)) {
3647 t = SvPV(sv, PL_na);
3651 PUSHs(sv_2mortal(sv));
3656 if ((s >= strend) && bytes)
3657 croak("Unterminated compressed integer");
3662 if (sizeof(char*) > strend - s)
3665 Copy(s, &aptr, 1, char*);
3670 sv_setpvn(sv, aptr, len);
3671 PUSHs(sv_2mortal(sv));
3675 along = (strend - s) / sizeof(Quad_t);
3681 if (s + sizeof(Quad_t) > strend)
3684 Copy(s, &aquad, 1, Quad_t);
3685 s += sizeof(Quad_t);
3688 if (aquad >= IV_MIN && aquad <= IV_MAX)
3689 sv_setiv(sv, (IV)aquad);
3691 sv_setnv(sv, (double)aquad);
3692 PUSHs(sv_2mortal(sv));
3696 along = (strend - s) / sizeof(Quad_t);
3702 if (s + sizeof(unsigned Quad_t) > strend)
3705 Copy(s, &auquad, 1, unsigned Quad_t);
3706 s += sizeof(unsigned Quad_t);
3709 if (auquad <= UV_MAX)
3710 sv_setuv(sv, (UV)auquad);
3712 sv_setnv(sv, (double)auquad);
3713 PUSHs(sv_2mortal(sv));
3717 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3720 along = (strend - s) / sizeof(float);
3725 Copy(s, &afloat, 1, float);
3734 Copy(s, &afloat, 1, float);
3737 sv_setnv(sv, (double)afloat);
3738 PUSHs(sv_2mortal(sv));
3744 along = (strend - s) / sizeof(double);
3749 Copy(s, &adouble, 1, double);
3750 s += sizeof(double);
3758 Copy(s, &adouble, 1, double);
3759 s += sizeof(double);
3761 sv_setnv(sv, (double)adouble);
3762 PUSHs(sv_2mortal(sv));
3768 * Initialise the decode mapping. By using a table driven
3769 * algorithm, the code will be character-set independent
3770 * (and just as fast as doing character arithmetic)
3772 if (uudmap['M'] == 0) {
3775 for (i = 0; i < sizeof(uuemap); i += 1)
3776 uudmap[uuemap[i]] = i;
3778 * Because ' ' and '`' map to the same value,
3779 * we need to decode them both the same.
3784 along = (strend - s) * 3 / 4;
3785 sv = NEWSV(42, along);
3788 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
3793 len = (*s++ - ' ') & 077;
3795 if (s < strend && ISUUCHAR(*s))
3796 a = uudmap[*s++] & 077;
3799 if (s < strend && ISUUCHAR(*s))
3800 b = uudmap[*s++] & 077;
3803 if (s < strend && ISUUCHAR(*s))
3804 c = uudmap[*s++] & 077;
3807 if (s < strend && ISUUCHAR(*s))
3808 d = uudmap[*s++] & 077;
3811 hunk[0] = (a << 2) | (b >> 4);
3812 hunk[1] = (b << 4) | (c >> 2);
3813 hunk[2] = (c << 6) | d;
3814 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3819 else if (s[1] == '\n') /* possible checksum byte */
3822 XPUSHs(sv_2mortal(sv));
3827 if (strchr("fFdD", datumtype) ||
3828 (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3832 while (checksum >= 16) {
3836 while (checksum >= 4) {
3842 along = (1 << checksum) - 1;
3843 while (cdouble < 0.0)
3845 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3846 sv_setnv(sv, cdouble);
3849 if (checksum < 32) {
3850 aulong = (1 << checksum) - 1;
3853 sv_setuv(sv, (UV)culong);
3855 XPUSHs(sv_2mortal(sv));
3859 if (SP == oldsp && gimme == G_SCALAR)
3860 PUSHs(&PL_sv_undef);
3865 doencodes(register SV *sv, register char *s, register I32 len)
3869 *hunk = uuemap[len];
3870 sv_catpvn(sv, hunk, 1);
3873 hunk[0] = uuemap[(077 & (*s >> 2))];
3874 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
3875 hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
3876 hunk[3] = uuemap[(077 & (s[2] & 077))];
3877 sv_catpvn(sv, hunk, 4);
3882 char r = (len > 1 ? s[1] : '\0');
3883 hunk[0] = uuemap[(077 & (*s >> 2))];
3884 hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
3885 hunk[2] = uuemap[(077 & ((r << 2) & 074))];
3886 hunk[3] = uuemap[0];
3887 sv_catpvn(sv, hunk, 4);
3889 sv_catpvn(sv, "\n", 1);
3893 is_an_int(char *s, STRLEN l)
3895 SV *result = newSVpv("", l);
3896 char *result_c = SvPV(result, PL_na); /* convenience */
3897 char *out = result_c;
3907 SvREFCNT_dec(result);
3930 SvREFCNT_dec(result);
3936 SvCUR_set(result, out - result_c);
3941 div128(SV *pnum, bool *done)
3942 /* must be '\0' terminated */
3946 char *s = SvPV(pnum, len);
3955 i = m * 10 + (*t - '0');
3957 r = (i >> 7); /* r < 10 */
3964 SvCUR_set(pnum, (STRLEN) (t - s));
3971 djSP; dMARK; dORIGMARK; dTARGET;
3972 register SV *cat = TARG;
3975 register char *pat = SvPVx(*++MARK, fromlen);
3976 register char *patend = pat + fromlen;
3981 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3982 static char *space10 = " ";
3984 /* These must not be in registers: */
3993 unsigned Quad_t auquad;
4002 sv_setpvn(cat, "", 0);
4003 while (pat < patend) {
4004 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4005 datumtype = *pat++ & 0xFF;
4006 if (isSPACE(datumtype))
4009 len = strchr("@Xxu", datumtype) ? 0 : items;
4012 else if (isDIGIT(*pat)) {
4014 while (isDIGIT(*pat))
4015 len = (len * 10) + (*pat++ - '0');
4021 croak("Invalid type in pack: '%c'", (int)datumtype);
4022 case ',': /* grandfather in commas but with a warning */
4023 if (commas++ == 0 && PL_dowarn)
4024 warn("Invalid type in pack: '%c'", (int)datumtype);
4027 DIE("%% may only be used in unpack");
4038 if (SvCUR(cat) < len)
4039 DIE("X outside of string");
4046 sv_catpvn(cat, null10, 10);
4049 sv_catpvn(cat, null10, len);
4054 aptr = SvPV(fromstr, fromlen);
4058 sv_catpvn(cat, aptr, len);
4060 sv_catpvn(cat, aptr, fromlen);
4062 if (datumtype == 'A') {
4064 sv_catpvn(cat, space10, 10);
4067 sv_catpvn(cat, space10, len);
4071 sv_catpvn(cat, null10, 10);
4074 sv_catpvn(cat, null10, len);
4081 char *savepat = pat;
4086 aptr = SvPV(fromstr, fromlen);
4091 SvCUR(cat) += (len+7)/8;
4092 SvGROW(cat, SvCUR(cat) + 1);
4093 aptr = SvPVX(cat) + aint;
4098 if (datumtype == 'B') {
4099 for (len = 0; len++ < aint;) {
4100 items |= *pat++ & 1;
4104 *aptr++ = items & 0xff;
4110 for (len = 0; len++ < aint;) {
4116 *aptr++ = items & 0xff;
4122 if (datumtype == 'B')
4123 items <<= 7 - (aint & 7);
4125 items >>= 7 - (aint & 7);
4126 *aptr++ = items & 0xff;
4128 pat = SvPVX(cat) + SvCUR(cat);
4139 char *savepat = pat;
4144 aptr = SvPV(fromstr, fromlen);
4149 SvCUR(cat) += (len+1)/2;
4150 SvGROW(cat, SvCUR(cat) + 1);
4151 aptr = SvPVX(cat) + aint;
4156 if (datumtype == 'H') {
4157 for (len = 0; len++ < aint;) {
4159 items |= ((*pat++ & 15) + 9) & 15;
4161 items |= *pat++ & 15;
4165 *aptr++ = items & 0xff;
4171 for (len = 0; len++ < aint;) {
4173 items |= (((*pat++ & 15) + 9) & 15) << 4;
4175 items |= (*pat++ & 15) << 4;
4179 *aptr++ = items & 0xff;
4185 *aptr++ = items & 0xff;
4186 pat = SvPVX(cat) + SvCUR(cat);
4198 aint = SvIV(fromstr);
4200 sv_catpvn(cat, &achar, sizeof(char));
4206 auint = SvUV(fromstr);
4207 SvGROW(cat, SvCUR(cat) + 10);
4208 SvCUR_set(cat, uv_to_utf8(SvEND(cat), auint) - SvPVX(cat));
4212 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4217 afloat = (float)SvNV(fromstr);
4218 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4225 adouble = (double)SvNV(fromstr);
4226 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4232 ashort = (I16)SvIV(fromstr);
4234 ashort = PerlSock_htons(ashort);
4236 CAT16(cat, &ashort);
4242 ashort = (I16)SvIV(fromstr);
4244 ashort = htovs(ashort);
4246 CAT16(cat, &ashort);
4253 ashort = (I16)SvIV(fromstr);
4254 CAT16(cat, &ashort);
4260 auint = SvUV(fromstr);
4261 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4267 adouble = floor(SvNV(fromstr));
4270 croak("Cannot compress negative numbers");
4276 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4277 adouble <= UV_MAX_cxux
4284 char buf[1 + sizeof(UV)];
4285 char *in = buf + sizeof(buf);
4286 UV auv = U_V(adouble);;
4289 *--in = (auv & 0x7f) | 0x80;
4292 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4293 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4295 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4296 char *from, *result, *in;
4301 /* Copy string and check for compliance */
4302 from = SvPV(fromstr, len);
4303 if ((norm = is_an_int(from, len)) == NULL)
4304 croak("can compress only unsigned integer");
4306 New('w', result, len, char);
4310 *--in = div128(norm, &done) | 0x80;
4311 result[len - 1] &= 0x7F; /* clear continue bit */
4312 sv_catpvn(cat, in, (result + len) - in);
4314 SvREFCNT_dec(norm); /* free norm */
4316 else if (SvNOKp(fromstr)) {
4317 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4318 char *in = buf + sizeof(buf);
4321 double next = floor(adouble / 128);
4322 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4323 if (--in < buf) /* this cannot happen ;-) */
4324 croak ("Cannot compress integer");
4326 } while (adouble > 0);
4327 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4328 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4331 croak("Cannot compress non integer");
4337 aint = SvIV(fromstr);
4338 sv_catpvn(cat, (char*)&aint, sizeof(int));
4344 aulong = SvUV(fromstr);
4346 aulong = PerlSock_htonl(aulong);
4348 CAT32(cat, &aulong);
4354 aulong = SvUV(fromstr);
4356 aulong = htovl(aulong);
4358 CAT32(cat, &aulong);
4364 aulong = SvUV(fromstr);
4365 CAT32(cat, &aulong);
4371 along = SvIV(fromstr);
4379 auquad = (unsigned Quad_t)SvIV(fromstr);
4380 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4386 aquad = (Quad_t)SvIV(fromstr);
4387 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4390 #endif /* HAS_QUAD */
4392 len = 1; /* assume SV is correct length */
4397 if (fromstr == &PL_sv_undef)
4400 /* XXX better yet, could spirit away the string to
4401 * a safe spot and hang on to it until the result
4402 * of pack() (and all copies of the result) are
4405 if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4406 warn("Attempt to pack pointer to temporary value");
4407 if (SvPOK(fromstr) || SvNIOK(fromstr))
4408 aptr = SvPV(fromstr,PL_na);
4410 aptr = SvPV_force(fromstr,PL_na);
4412 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4417 aptr = SvPV(fromstr, fromlen);
4418 SvGROW(cat, fromlen * 4 / 3);
4423 while (fromlen > 0) {
4430 doencodes(cat, aptr, todo);
4449 register I32 limit = POPi; /* note, negative is forever */
4452 register char *s = SvPV(sv, len);
4453 char *strend = s + len;
4455 register REGEXP *rx;
4459 I32 maxiters = (strend - s) + 10;
4462 I32 origlimit = limit;
4465 AV *oldstack = PL_curstack;
4466 I32 gimme = GIMME_V;
4467 I32 oldsave = PL_savestack_ix;
4468 I32 make_mortal = 1;
4469 MAGIC *mg = (MAGIC *) NULL;
4472 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4477 DIE("panic: do_split");
4478 rx = pm->op_pmregexp;
4480 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4481 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4483 if (pm->op_pmreplroot)
4484 ary = GvAVn((GV*)pm->op_pmreplroot);
4485 else if (gimme != G_ARRAY)
4487 ary = (AV*)PL_curpad[0];
4489 ary = GvAVn(PL_defgv);
4490 #endif /* USE_THREADS */
4493 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4499 if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4506 for (i = AvFILLp(ary); i >= 0; i--)
4507 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4509 /* temporarily switch stacks */
4510 SWITCHSTACK(PL_curstack, ary);
4514 base = SP - PL_stack_base;
4516 if (pm->op_pmflags & PMf_SKIPWHITE) {
4517 if (pm->op_pmflags & PMf_LOCALE) {
4518 while (isSPACE_LC(*s))
4526 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4527 SAVEINT(PL_multiline);
4528 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4532 limit = maxiters + 2;
4533 if (pm->op_pmflags & PMf_WHITE) {
4536 while (m < strend &&
4537 !((pm->op_pmflags & PMf_LOCALE)
4538 ? isSPACE_LC(*m) : isSPACE(*m)))
4543 dstr = NEWSV(30, m-s);
4544 sv_setpvn(dstr, s, m-s);
4550 while (s < strend &&
4551 ((pm->op_pmflags & PMf_LOCALE)
4552 ? isSPACE_LC(*s) : isSPACE(*s)))
4556 else if (strEQ("^", rx->precomp)) {
4559 for (m = s; m < strend && *m != '\n'; m++) ;
4563 dstr = NEWSV(30, m-s);
4564 sv_setpvn(dstr, s, m-s);
4571 else if (rx->check_substr && !rx->nparens
4572 && (rx->reganch & ROPT_CHECK_ALL)
4573 && !(rx->reganch & ROPT_ANCH)) {
4574 i = SvCUR(rx->check_substr);
4575 if (i == 1 && !SvTAIL(rx->check_substr)) {
4576 i = *SvPVX(rx->check_substr);
4579 for (m = s; m < strend && *m != i; m++) ;
4582 dstr = NEWSV(30, m-s);
4583 sv_setpvn(dstr, s, m-s);
4592 while (s < strend && --limit &&
4593 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4594 rx->check_substr, 0)) )
4597 dstr = NEWSV(31, m-s);
4598 sv_setpvn(dstr, s, m-s);
4607 maxiters += (strend - s) * rx->nparens;
4608 while (s < strend && --limit &&
4609 CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4611 TAINT_IF(RX_MATCH_TAINTED(rx));
4613 && rx->subbase != orig) {
4618 strend = s + (strend - m);
4621 dstr = NEWSV(32, m-s);
4622 sv_setpvn(dstr, s, m-s);
4627 for (i = 1; i <= rx->nparens; i++) {
4631 dstr = NEWSV(33, m-s);
4632 sv_setpvn(dstr, s, m-s);
4635 dstr = NEWSV(33, 0);
4645 LEAVE_SCOPE(oldsave);
4646 iters = (SP - PL_stack_base) - base;
4647 if (iters > maxiters)
4650 /* keep field after final delim? */
4651 if (s < strend || (iters && origlimit)) {
4652 dstr = NEWSV(34, strend-s);
4653 sv_setpvn(dstr, s, strend-s);
4659 else if (!origlimit) {
4660 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4666 SWITCHSTACK(ary, oldstack);
4667 if (SvSMAGICAL(ary)) {
4672 if (gimme == G_ARRAY) {
4674 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4682 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4685 if (gimme == G_ARRAY) {
4686 /* EXTEND should not be needed - we just popped them */
4688 for (i=0; i < iters; i++) {
4689 SV **svp = av_fetch(ary, i, FALSE);
4690 PUSHs((svp) ? *svp : &PL_sv_undef);
4697 if (gimme == G_ARRAY)
4700 if (iters || !pm->op_pmreplroot) {
4710 unlock_condpair(void *svv)
4713 MAGIC *mg = mg_find((SV*)svv, 'm');
4716 croak("panic: unlock_condpair unlocking non-mutex");
4717 MUTEX_LOCK(MgMUTEXP(mg));
4718 if (MgOWNER(mg) != thr)
4719 croak("panic: unlock_condpair unlocking mutex that we don't own");
4721 COND_SIGNAL(MgOWNERCONDP(mg));
4722 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4723 (unsigned long)thr, (unsigned long)svv);)
4724 MUTEX_UNLOCK(MgMUTEXP(mg));
4726 #endif /* USE_THREADS */
4739 mg = condpair_magic(sv);
4740 MUTEX_LOCK(MgMUTEXP(mg));
4741 if (MgOWNER(mg) == thr)
4742 MUTEX_UNLOCK(MgMUTEXP(mg));
4745 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4747 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4748 (unsigned long)thr, (unsigned long)sv);)
4749 MUTEX_UNLOCK(MgMUTEXP(mg));
4750 SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
4751 save_destructor(unlock_condpair, sv);
4753 #endif /* USE_THREADS */
4754 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4755 || SvTYPE(retsv) == SVt_PVCV) {
4756 retsv = refto(retsv);
4767 if (PL_op->op_private & OPpLVAL_INTRO)
4768 PUSHs(*save_threadsv(PL_op->op_targ));
4770 PUSHs(THREADSV(PL_op->op_targ));
4773 DIE("tried to access per-thread data in non-threaded perl");
4774 #endif /* USE_THREADS */