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 COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
96 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
97 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
99 # define COPY16(s,p) Copy(s, p, SIZE16, char)
100 # define COPY32(s,p) Copy(s, p, SIZE32, char)
101 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
102 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
103 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
107 static void doencodes _((SV* sv, char* s, I32 len));
108 static SV* refto _((SV* sv));
109 static U32 seed _((void));
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__);
214 tryAMAGICunDEREF(to_gv);
217 if (SvTYPE(sv) == SVt_PVIO) {
218 GV *gv = (GV*) sv_newmortal();
219 gv_init(gv, 0, "", 0, 0);
220 GvIOp(gv) = (IO *)sv;
221 (void)SvREFCNT_inc(sv);
224 else if (SvTYPE(sv) != SVt_PVGV)
225 DIE("Not a GLOB reference");
228 if (SvTYPE(sv) != SVt_PVGV) {
232 if (SvGMAGICAL(sv)) {
238 if (PL_op->op_flags & OPf_REF ||
239 PL_op->op_private & HINT_STRICT_REFS)
240 DIE(PL_no_usym, "a symbol");
241 if (ckWARN(WARN_UNINITIALIZED))
242 warner(WARN_UNINITIALIZED, PL_warn_uninit);
246 if ((PL_op->op_flags & OPf_SPECIAL) &&
247 !(PL_op->op_flags & OPf_MOD))
249 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
254 if (PL_op->op_private & HINT_STRICT_REFS)
255 DIE(PL_no_symref, sym, "a symbol");
256 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
260 if (PL_op->op_private & OPpLVAL_INTRO)
261 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
272 tryAMAGICunDEREF(to_sv);
275 switch (SvTYPE(sv)) {
279 DIE("Not a SCALAR reference");
287 if (SvTYPE(gv) != SVt_PVGV) {
288 if (SvGMAGICAL(sv)) {
294 if (PL_op->op_flags & OPf_REF ||
295 PL_op->op_private & HINT_STRICT_REFS)
296 DIE(PL_no_usym, "a SCALAR");
297 if (ckWARN(WARN_UNINITIALIZED))
298 warner(WARN_UNINITIALIZED, PL_warn_uninit);
302 if ((PL_op->op_flags & OPf_SPECIAL) &&
303 !(PL_op->op_flags & OPf_MOD))
305 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
310 if (PL_op->op_private & HINT_STRICT_REFS)
311 DIE(PL_no_symref, sym, "a SCALAR");
312 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
317 if (PL_op->op_flags & OPf_MOD) {
318 if (PL_op->op_private & OPpLVAL_INTRO)
319 sv = save_scalar((GV*)TOPs);
320 else if (PL_op->op_private & OPpDEREF)
321 vivify_ref(sv, PL_op->op_private & OPpDEREF);
331 SV *sv = AvARYLEN(av);
333 AvARYLEN(av) = sv = NEWSV(0,0);
334 sv_upgrade(sv, SVt_IV);
335 sv_magic(sv, (SV*)av, '#', Nullch, 0);
343 djSP; dTARGET; dPOPss;
345 if (PL_op->op_flags & OPf_MOD) {
346 if (SvTYPE(TARG) < SVt_PVLV) {
347 sv_upgrade(TARG, SVt_PVLV);
348 sv_magic(TARG, Nullsv, '.', Nullch, 0);
352 if (LvTARG(TARG) != sv) {
354 SvREFCNT_dec(LvTARG(TARG));
355 LvTARG(TARG) = SvREFCNT_inc(sv);
357 PUSHs(TARG); /* no SvSETMAGIC */
363 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
364 mg = mg_find(sv, 'g');
365 if (mg && mg->mg_len >= 0) {
369 PUSHi(i + PL_curcop->cop_arybase);
383 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
384 /* (But not in defined().) */
385 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
388 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
391 cv = (CV*)&PL_sv_undef;
405 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
406 char *s = SvPVX(TOPs);
407 if (strnEQ(s, "CORE::", 6)) {
410 code = keyword(s + 6, SvCUR(TOPs) - 6);
411 if (code < 0) { /* Overridable. */
412 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
413 int i = 0, n = 0, seen_question = 0;
415 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
417 while (i < MAXO) { /* The slow way. */
418 if (strEQ(s + 6, PL_op_name[i])
419 || strEQ(s + 6, PL_op_desc[i]))
425 goto nonesuch; /* Should not happen... */
427 oa = PL_opargs[i] >> OASHIFT;
429 if (oa & OA_OPTIONAL) {
433 else if (seen_question)
434 goto set; /* XXXX system, exec */
435 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
436 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
439 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
440 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
444 ret = sv_2mortal(newSVpv(str, n - 1));
446 else if (code) /* Non-Overridable */
448 else { /* None such */
450 croak("Cannot find an opnumber for \"%s\"", s+6);
454 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
456 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
465 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
467 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
483 if (GIMME != G_ARRAY) {
487 *MARK = &PL_sv_undef;
488 *MARK = refto(*MARK);
492 EXTEND_MORTAL(SP - MARK);
494 *MARK = refto(*MARK);
503 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
506 if (!(sv = LvTARG(sv)))
509 else if (SvPADTMP(sv))
513 (void)SvREFCNT_inc(sv);
516 sv_upgrade(rv, SVt_RV);
530 if (sv && SvGMAGICAL(sv))
533 if (!sv || !SvROK(sv))
537 pv = sv_reftype(sv,TRUE);
538 PUSHp(pv, strlen(pv));
548 stash = PL_curcop->cop_stash;
552 char *ptr = SvPV(ssv,len);
553 if (ckWARN(WARN_UNSAFE) && len == 0)
555 "Explicit blessing to '' (assuming package main)");
556 stash = gv_stashpvn(ptr, len, TRUE);
559 (void)sv_bless(TOPs, stash);
573 elem = SvPV(sv, n_a);
577 switch (elem ? *elem : '\0')
580 if (strEQ(elem, "ARRAY"))
581 tmpRef = (SV*)GvAV(gv);
584 if (strEQ(elem, "CODE"))
585 tmpRef = (SV*)GvCVu(gv);
588 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
589 tmpRef = (SV*)GvIOp(gv);
592 if (strEQ(elem, "GLOB"))
596 if (strEQ(elem, "HASH"))
597 tmpRef = (SV*)GvHV(gv);
600 if (strEQ(elem, "IO"))
601 tmpRef = (SV*)GvIOp(gv);
604 if (strEQ(elem, "NAME"))
605 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
608 if (strEQ(elem, "PACKAGE"))
609 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
612 if (strEQ(elem, "SCALAR"))
626 /* Pattern matching */
631 register UNOP *unop = cUNOP;
632 register unsigned char *s;
635 register I32 *sfirst;
639 if (sv == PL_lastscream) {
645 SvSCREAM_off(PL_lastscream);
646 SvREFCNT_dec(PL_lastscream);
648 PL_lastscream = SvREFCNT_inc(sv);
651 s = (unsigned char*)(SvPV(sv, len));
655 if (pos > PL_maxscream) {
656 if (PL_maxscream < 0) {
657 PL_maxscream = pos + 80;
658 New(301, PL_screamfirst, 256, I32);
659 New(302, PL_screamnext, PL_maxscream, I32);
662 PL_maxscream = pos + pos / 4;
663 Renew(PL_screamnext, PL_maxscream, I32);
667 sfirst = PL_screamfirst;
668 snext = PL_screamnext;
670 if (!sfirst || !snext)
671 DIE("do_study: out of memory");
673 for (ch = 256; ch; --ch)
680 snext[pos] = sfirst[ch] - pos;
687 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
696 if (PL_op->op_flags & OPf_STACKED)
702 TARG = sv_newmortal();
707 /* Lvalue operators. */
719 djSP; dMARK; dTARGET;
729 SETi(do_chomp(TOPs));
735 djSP; dMARK; dTARGET;
736 register I32 count = 0;
739 count += do_chomp(POPs);
750 if (!sv || !SvANY(sv))
752 switch (SvTYPE(sv)) {
754 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
758 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
762 if (CvROOT(sv) || CvXSUB(sv))
779 if (!PL_op->op_private) {
788 if (SvTHINKFIRST(sv)) {
789 if (SvREADONLY(sv)) {
791 if (PL_curcop != &PL_compiling)
798 switch (SvTYPE(sv)) {
808 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
809 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
810 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
813 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
815 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
819 SvSetMagicSV(sv, &PL_sv_undef);
823 Newz(602, gp, 1, GP);
824 GvGP(sv) = gp_ref(gp);
825 GvSV(sv) = NEWSV(72,0);
826 GvLINE(sv) = PL_curcop->cop_line;
832 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
835 SvPV_set(sv, Nullch);
848 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
850 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
851 SvIVX(TOPs) != IV_MIN)
854 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
865 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
867 sv_setsv(TARG, TOPs);
868 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
869 SvIVX(TOPs) != IV_MAX)
872 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
886 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
888 sv_setsv(TARG, TOPs);
889 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
890 SvIVX(TOPs) != IV_MIN)
893 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
902 /* Ordinary operators. */
906 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
909 SETn( pow( left, right) );
916 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
919 SETn( left * right );
926 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
931 DIE("Illegal division by zero");
933 /* insure that 20./5. == 4. */
936 if ((double)I_V(left) == left &&
937 (double)I_V(right) == right &&
938 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
942 value = left / right;
946 value = left / right;
955 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
963 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
965 right = (right_neg = (i < 0)) ? -i : i;
969 right = U_V((right_neg = (n < 0)) ? -n : n);
972 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
974 left = (left_neg = (i < 0)) ? -i : i;
978 left = U_V((left_neg = (n < 0)) ? -n : n);
982 DIE("Illegal modulus zero");
985 if ((left_neg != right_neg) && ans)
988 /* XXX may warn: unary minus operator applied to unsigned type */
989 /* could change -foo to be (~foo)+1 instead */
990 if (ans <= ~((UV)IV_MAX)+1)
991 sv_setiv(TARG, ~ans+1);
993 sv_setnv(TARG, -(double)ans);
1004 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1006 register I32 count = POPi;
1007 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1009 I32 items = SP - MARK;
1012 max = items * count;
1021 repeatcpy((char*)(MARK + items), (char*)MARK,
1022 items * sizeof(SV*), count - 1);
1025 else if (count <= 0)
1028 else { /* Note: mark already snarfed by pp_list */
1033 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1034 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1035 DIE("Can't x= to readonly value");
1039 SvSetSV(TARG, tmpstr);
1040 SvPV_force(TARG, len);
1045 SvGROW(TARG, (count * len) + 1);
1046 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1047 SvCUR(TARG) *= count;
1049 *SvEND(TARG) = '\0';
1051 (void)SvPOK_only(TARG);
1060 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1063 SETn( left - right );
1070 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1073 if (PL_op->op_private & HINT_INTEGER) {
1075 i = BWi(i) << shift;
1089 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1092 if (PL_op->op_private & HINT_INTEGER) {
1094 i = BWi(i) >> shift;
1108 djSP; tryAMAGICbinSET(lt,0);
1111 SETs(boolSV(TOPn < value));
1118 djSP; tryAMAGICbinSET(gt,0);
1121 SETs(boolSV(TOPn > value));
1128 djSP; tryAMAGICbinSET(le,0);
1131 SETs(boolSV(TOPn <= value));
1138 djSP; tryAMAGICbinSET(ge,0);
1141 SETs(boolSV(TOPn >= value));
1148 djSP; tryAMAGICbinSET(ne,0);
1151 SETs(boolSV(TOPn != value));
1158 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1165 else if (left < right)
1167 else if (left > right)
1180 djSP; tryAMAGICbinSET(slt,0);
1183 int cmp = ((PL_op->op_private & OPpLOCALE)
1184 ? sv_cmp_locale(left, right)
1185 : sv_cmp(left, right));
1186 SETs(boolSV(cmp < 0));
1193 djSP; tryAMAGICbinSET(sgt,0);
1196 int cmp = ((PL_op->op_private & OPpLOCALE)
1197 ? sv_cmp_locale(left, right)
1198 : sv_cmp(left, right));
1199 SETs(boolSV(cmp > 0));
1206 djSP; tryAMAGICbinSET(sle,0);
1209 int cmp = ((PL_op->op_private & OPpLOCALE)
1210 ? sv_cmp_locale(left, right)
1211 : sv_cmp(left, right));
1212 SETs(boolSV(cmp <= 0));
1219 djSP; tryAMAGICbinSET(sge,0);
1222 int cmp = ((PL_op->op_private & OPpLOCALE)
1223 ? sv_cmp_locale(left, right)
1224 : sv_cmp(left, right));
1225 SETs(boolSV(cmp >= 0));
1232 djSP; tryAMAGICbinSET(seq,0);
1235 SETs(boolSV(sv_eq(left, right)));
1242 djSP; tryAMAGICbinSET(sne,0);
1245 SETs(boolSV(!sv_eq(left, right)));
1252 djSP; dTARGET; tryAMAGICbin(scmp,0);
1255 int cmp = ((PL_op->op_private & OPpLOCALE)
1256 ? sv_cmp_locale(left, right)
1257 : sv_cmp(left, right));
1265 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1268 if (SvNIOKp(left) || SvNIOKp(right)) {
1269 if (PL_op->op_private & HINT_INTEGER) {
1270 IBW value = SvIV(left) & SvIV(right);
1274 UBW value = SvUV(left) & SvUV(right);
1279 do_vop(PL_op->op_type, TARG, left, right);
1288 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1291 if (SvNIOKp(left) || SvNIOKp(right)) {
1292 if (PL_op->op_private & HINT_INTEGER) {
1293 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1297 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1302 do_vop(PL_op->op_type, TARG, left, right);
1311 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1314 if (SvNIOKp(left) || SvNIOKp(right)) {
1315 if (PL_op->op_private & HINT_INTEGER) {
1316 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1320 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1325 do_vop(PL_op->op_type, TARG, left, right);
1334 djSP; dTARGET; tryAMAGICun(neg);
1339 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1341 else if (SvNIOKp(sv))
1343 else if (SvPOKp(sv)) {
1345 char *s = SvPV(sv, len);
1346 if (isIDFIRST(*s)) {
1347 sv_setpvn(TARG, "-", 1);
1350 else if (*s == '+' || *s == '-') {
1352 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1354 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1355 sv_setpvn(TARG, "-", 1);
1359 sv_setnv(TARG, -SvNV(sv));
1370 djSP; tryAMAGICunSET(not);
1371 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1377 djSP; dTARGET; tryAMAGICun(compl);
1381 if (PL_op->op_private & HINT_INTEGER) {
1382 IBW value = ~SvIV(sv);
1386 UBW value = ~SvUV(sv);
1391 register char *tmps;
1392 register long *tmpl;
1397 tmps = SvPV_force(TARG, len);
1400 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1403 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1407 for ( ; anum > 0; anum--, tmps++)
1416 /* integer versions of some of the above */
1420 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1423 SETi( left * right );
1430 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1434 DIE("Illegal division by zero");
1435 value = POPi / value;
1443 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1447 DIE("Illegal modulus zero");
1448 SETi( left % right );
1455 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1458 SETi( left + right );
1465 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1468 SETi( left - right );
1475 djSP; tryAMAGICbinSET(lt,0);
1478 SETs(boolSV(left < right));
1485 djSP; tryAMAGICbinSET(gt,0);
1488 SETs(boolSV(left > right));
1495 djSP; tryAMAGICbinSET(le,0);
1498 SETs(boolSV(left <= right));
1505 djSP; tryAMAGICbinSET(ge,0);
1508 SETs(boolSV(left >= right));
1515 djSP; tryAMAGICbinSET(eq,0);
1518 SETs(boolSV(left == right));
1525 djSP; tryAMAGICbinSET(ne,0);
1528 SETs(boolSV(left != right));
1535 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1542 else if (left < right)
1553 djSP; dTARGET; tryAMAGICun(neg);
1558 /* High falutin' math. */
1562 djSP; dTARGET; tryAMAGICbin(atan2,0);
1565 SETn(atan2(left, right));
1572 djSP; dTARGET; tryAMAGICun(sin);
1584 djSP; dTARGET; tryAMAGICun(cos);
1594 /* Support Configure command-line overrides for rand() functions.
1595 After 5.005, perhaps we should replace this by Configure support
1596 for drand48(), random(), or rand(). For 5.005, though, maintain
1597 compatibility by calling rand() but allow the user to override it.
1598 See INSTALL for details. --Andy Dougherty 15 July 1998
1600 /* Now it's after 5.005, and Configure supports drand48() and random(),
1601 in addition to rand(). So the overrides should not be needed any more.
1602 --Jarkko Hietaniemi 27 September 1998
1605 #ifndef HAS_DRAND48_PROTO
1606 extern double drand48 _((void));
1619 if (!PL_srand_called) {
1620 (void)seedDrand01((Rand_seed_t)seed());
1621 PL_srand_called = TRUE;
1636 (void)seedDrand01((Rand_seed_t)anum);
1637 PL_srand_called = TRUE;
1646 * This is really just a quick hack which grabs various garbage
1647 * values. It really should be a real hash algorithm which
1648 * spreads the effect of every input bit onto every output bit,
1649 * if someone who knows about such things would bother to write it.
1650 * Might be a good idea to add that function to CORE as well.
1651 * No numbers below come from careful analysis or anything here,
1652 * except they are primes and SEED_C1 > 1E6 to get a full-width
1653 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1654 * probably be bigger too.
1657 # define SEED_C1 1000003
1658 #define SEED_C4 73819
1660 # define SEED_C1 25747
1661 #define SEED_C4 20639
1665 #define SEED_C5 26107
1668 #ifndef PERL_NO_DEV_RANDOM
1673 # include <starlet.h>
1674 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1675 * in 100-ns units, typically incremented ever 10 ms. */
1676 unsigned int when[2];
1678 # ifdef HAS_GETTIMEOFDAY
1679 struct timeval when;
1685 /* This test is an escape hatch, this symbol isn't set by Configure. */
1686 #ifndef PERL_NO_DEV_RANDOM
1687 #ifndef PERL_RANDOM_DEVICE
1688 /* /dev/random isn't used by default because reads from it will block
1689 * if there isn't enough entropy available. You can compile with
1690 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1691 * is enough real entropy to fill the seed. */
1692 # define PERL_RANDOM_DEVICE "/dev/urandom"
1694 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1696 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1705 _ckvmssts(sys$gettim(when));
1706 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1708 # ifdef HAS_GETTIMEOFDAY
1709 gettimeofday(&when,(struct timezone *) 0);
1710 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1713 u = (U32)SEED_C1 * when;
1716 u += SEED_C3 * (U32)getpid();
1717 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1718 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1719 u += SEED_C5 * (U32)(UV)&when;
1726 djSP; dTARGET; tryAMAGICun(exp);
1738 djSP; dTARGET; tryAMAGICun(log);
1743 SET_NUMERIC_STANDARD();
1744 DIE("Can't take log of %g", value);
1754 djSP; dTARGET; tryAMAGICun(sqrt);
1759 SET_NUMERIC_STANDARD();
1760 DIE("Can't take sqrt of %g", value);
1762 value = sqrt(value);
1772 double value = TOPn;
1775 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1781 (void)modf(value, &value);
1783 (void)modf(-value, &value);
1798 djSP; dTARGET; tryAMAGICun(abs);
1800 double value = TOPn;
1803 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1804 (iv = SvIVX(TOPs)) != IV_MIN) {
1826 XPUSHu(scan_hex(tmps, 99, &argtype));
1839 while (*tmps && isSPACE(*tmps))
1844 value = scan_hex(++tmps, 99, &argtype);
1845 else if (*tmps == 'b')
1846 value = scan_bin(++tmps, 99, &argtype);
1848 value = scan_oct(tmps, 99, &argtype);
1860 SETi( sv_len_utf8(TOPs) );
1864 SETi( sv_len(TOPs) );
1878 I32 lvalue = PL_op->op_flags & OPf_MOD;
1880 I32 arybase = PL_curcop->cop_arybase;
1884 SvTAINTED_off(TARG); /* decontaminate */
1888 repl = SvPV(sv, repl_len);
1895 tmps = SvPV(sv, curlen);
1897 utfcurlen = sv_len_utf8(sv);
1898 if (utfcurlen == curlen)
1906 if (pos >= arybase) {
1924 else if (len >= 0) {
1926 if (rem > (I32)curlen)
1940 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1941 warner(WARN_SUBSTR, "substr outside of string");
1946 sv_pos_u2b(sv, &pos, &rem);
1948 sv_setpvn(TARG, tmps, rem);
1949 if (lvalue) { /* it's an lvalue! */
1950 if (!SvGMAGICAL(sv)) {
1954 if (ckWARN(WARN_SUBSTR))
1956 "Attempt to use reference as lvalue in substr");
1958 if (SvOK(sv)) /* is it defined ? */
1959 (void)SvPOK_only(sv);
1961 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1964 if (SvTYPE(TARG) < SVt_PVLV) {
1965 sv_upgrade(TARG, SVt_PVLV);
1966 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1970 if (LvTARG(TARG) != sv) {
1972 SvREFCNT_dec(LvTARG(TARG));
1973 LvTARG(TARG) = SvREFCNT_inc(sv);
1975 LvTARGOFF(TARG) = pos;
1976 LvTARGLEN(TARG) = rem;
1979 sv_insert(sv, pos, rem, repl, repl_len);
1982 PUSHs(TARG); /* avoid SvSETMAGIC here */
1989 register I32 size = POPi;
1990 register I32 offset = POPi;
1991 register SV *src = POPs;
1992 I32 lvalue = PL_op->op_flags & OPf_MOD;
1994 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1995 unsigned long retnum;
1998 SvTAINTED_off(TARG); /* decontaminate */
1999 offset *= size; /* turn into bit offset */
2000 len = (offset + size + 7) / 8;
2001 if (offset < 0 || size < 1)
2004 if (lvalue) { /* it's an lvalue! */
2005 if (SvTYPE(TARG) < SVt_PVLV) {
2006 sv_upgrade(TARG, SVt_PVLV);
2007 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2011 if (LvTARG(TARG) != src) {
2013 SvREFCNT_dec(LvTARG(TARG));
2014 LvTARG(TARG) = SvREFCNT_inc(src);
2016 LvTARGOFF(TARG) = offset;
2017 LvTARGLEN(TARG) = size;
2025 if (offset >= srclen)
2028 retnum = (unsigned long) s[offset] << 8;
2030 else if (size == 32) {
2031 if (offset >= srclen)
2033 else if (offset + 1 >= srclen)
2034 retnum = (unsigned long) s[offset] << 24;
2035 else if (offset + 2 >= srclen)
2036 retnum = ((unsigned long) s[offset] << 24) +
2037 ((unsigned long) s[offset + 1] << 16);
2039 retnum = ((unsigned long) s[offset] << 24) +
2040 ((unsigned long) s[offset + 1] << 16) +
2041 (s[offset + 2] << 8);
2046 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2051 else if (size == 16)
2052 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2053 else if (size == 32)
2054 retnum = ((unsigned long) s[offset] << 24) +
2055 ((unsigned long) s[offset + 1] << 16) +
2056 (s[offset + 2] << 8) + s[offset+3];
2060 sv_setuv(TARG, (UV)retnum);
2075 I32 arybase = PL_curcop->cop_arybase;
2080 offset = POPi - arybase;
2083 tmps = SvPV(big, biglen);
2084 if (IN_UTF8 && offset > 0)
2085 sv_pos_u2b(big, &offset, 0);
2088 else if (offset > biglen)
2090 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2091 (unsigned char*)tmps + biglen, little, 0)))
2094 retval = tmps2 - tmps;
2095 if (IN_UTF8 && retval > 0)
2096 sv_pos_b2u(big, &retval);
2097 PUSHi(retval + arybase);
2112 I32 arybase = PL_curcop->cop_arybase;
2118 tmps2 = SvPV(little, llen);
2119 tmps = SvPV(big, blen);
2123 if (IN_UTF8 && offset > 0)
2124 sv_pos_u2b(big, &offset, 0);
2125 offset = offset - arybase + llen;
2129 else if (offset > blen)
2131 if (!(tmps2 = rninstr(tmps, tmps + offset,
2132 tmps2, tmps2 + llen)))
2135 retval = tmps2 - tmps;
2136 if (IN_UTF8 && retval > 0)
2137 sv_pos_b2u(big, &retval);
2138 PUSHi(retval + arybase);
2144 djSP; dMARK; dORIGMARK; dTARGET;
2145 #ifdef USE_LOCALE_NUMERIC
2146 if (PL_op->op_private & OPpLOCALE)
2147 SET_NUMERIC_LOCAL();
2149 SET_NUMERIC_STANDARD();
2151 do_sprintf(TARG, SP-MARK, MARK+1);
2152 TAINT_IF(SvTAINTED(TARG));
2163 U8 *tmps = (U8*)POPpx;
2166 if (IN_UTF8 && (*tmps & 0x80))
2167 value = utf8_to_uv(tmps, &retlen);
2169 value = (UV)(*tmps & 255);
2180 (void)SvUPGRADE(TARG,SVt_PV);
2182 if (IN_UTF8 && value >= 128) {
2185 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2186 SvCUR_set(TARG, tmps - SvPVX(TARG));
2188 (void)SvPOK_only(TARG);
2198 (void)SvPOK_only(TARG);
2205 djSP; dTARGET; dPOPTOPssrl;
2208 char *tmps = SvPV(left, n_a);
2210 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2212 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2216 "The crypt() function is unimplemented due to excessive paranoia.");
2229 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2233 UV uv = utf8_to_uv(s, &ulen);
2235 if (PL_op->op_private & OPpLOCALE) {
2238 uv = toTITLE_LC_uni(uv);
2241 uv = toTITLE_utf8(s);
2243 tend = uv_to_utf8(tmpbuf, uv);
2245 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2247 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2248 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2252 s = (U8*)SvPV_force(sv, slen);
2253 Copy(tmpbuf, s, ulen, U8);
2258 if (!SvPADTMP(sv)) {
2264 s = (U8*)SvPV_force(sv, slen);
2266 if (PL_op->op_private & OPpLOCALE) {
2269 *s = toUPPER_LC(*s);
2285 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2289 UV uv = utf8_to_uv(s, &ulen);
2291 if (PL_op->op_private & OPpLOCALE) {
2294 uv = toLOWER_LC_uni(uv);
2297 uv = toLOWER_utf8(s);
2299 tend = uv_to_utf8(tmpbuf, uv);
2301 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2303 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2304 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2308 s = (U8*)SvPV_force(sv, slen);
2309 Copy(tmpbuf, s, ulen, U8);
2314 if (!SvPADTMP(sv)) {
2320 s = (U8*)SvPV_force(sv, slen);
2322 if (PL_op->op_private & OPpLOCALE) {
2325 *s = toLOWER_LC(*s);
2348 s = (U8*)SvPV(sv,len);
2350 sv_setpvn(TARG, "", 0);
2355 (void)SvUPGRADE(TARG, SVt_PV);
2356 SvGROW(TARG, (len * 2) + 1);
2357 (void)SvPOK_only(TARG);
2358 d = (U8*)SvPVX(TARG);
2360 if (PL_op->op_private & OPpLOCALE) {
2364 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2370 d = uv_to_utf8(d, toUPPER_utf8( s ));
2375 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2380 if (!SvPADTMP(sv)) {
2387 s = (U8*)SvPV_force(sv, len);
2389 register U8 *send = s + len;
2391 if (PL_op->op_private & OPpLOCALE) {
2394 for (; s < send; s++)
2395 *s = toUPPER_LC(*s);
2398 for (; s < send; s++)
2418 s = (U8*)SvPV(sv,len);
2420 sv_setpvn(TARG, "", 0);
2425 (void)SvUPGRADE(TARG, SVt_PV);
2426 SvGROW(TARG, (len * 2) + 1);
2427 (void)SvPOK_only(TARG);
2428 d = (U8*)SvPVX(TARG);
2430 if (PL_op->op_private & OPpLOCALE) {
2434 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2440 d = uv_to_utf8(d, toLOWER_utf8(s));
2445 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2450 if (!SvPADTMP(sv)) {
2457 s = (U8*)SvPV_force(sv, len);
2459 register U8 *send = s + len;
2461 if (PL_op->op_private & OPpLOCALE) {
2464 for (; s < send; s++)
2465 *s = toLOWER_LC(*s);
2468 for (; s < send; s++)
2480 register char *s = SvPV(sv,len);
2484 (void)SvUPGRADE(TARG, SVt_PV);
2485 SvGROW(TARG, (len * 2) + 1);
2490 STRLEN ulen = UTF8SKIP(s);
2513 SvCUR_set(TARG, d - SvPVX(TARG));
2514 (void)SvPOK_only(TARG);
2517 sv_setpvn(TARG, s, len);
2526 djSP; dMARK; dORIGMARK;
2528 register AV* av = (AV*)POPs;
2529 register I32 lval = PL_op->op_flags & OPf_MOD;
2530 I32 arybase = PL_curcop->cop_arybase;
2533 if (SvTYPE(av) == SVt_PVAV) {
2534 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2536 for (svp = MARK + 1; svp <= SP; svp++) {
2541 if (max > AvMAX(av))
2544 while (++MARK <= SP) {
2545 elem = SvIVx(*MARK);
2549 svp = av_fetch(av, elem, lval);
2551 if (!svp || *svp == &PL_sv_undef)
2552 DIE(PL_no_aelem, elem);
2553 if (PL_op->op_private & OPpLVAL_INTRO)
2554 save_aelem(av, elem, svp);
2556 *MARK = svp ? *svp : &PL_sv_undef;
2559 if (GIMME != G_ARRAY) {
2567 /* Associative arrays. */
2572 HV *hash = (HV*)POPs;
2574 I32 gimme = GIMME_V;
2575 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2578 /* might clobber stack_sp */
2579 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2584 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2585 if (gimme == G_ARRAY) {
2587 /* might clobber stack_sp */
2588 sv_setsv(TARG, realhv ?
2589 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2594 else if (gimme == G_SCALAR)
2613 I32 gimme = GIMME_V;
2614 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2618 if (PL_op->op_private & OPpSLICE) {
2622 hvtype = SvTYPE(hv);
2623 while (++MARK <= SP) {
2624 if (hvtype == SVt_PVHV)
2625 sv = hv_delete_ent(hv, *MARK, discard, 0);
2627 DIE("Not a HASH reference");
2628 *MARK = sv ? sv : &PL_sv_undef;
2632 else if (gimme == G_SCALAR) {
2641 if (SvTYPE(hv) == SVt_PVHV)
2642 sv = hv_delete_ent(hv, keysv, discard, 0);
2644 DIE("Not a HASH reference");
2658 if (SvTYPE(hv) == SVt_PVHV) {
2659 if (hv_exists_ent(hv, tmpsv, 0))
2662 else if (SvTYPE(hv) == SVt_PVAV) {
2663 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2667 DIE("Not a HASH reference");
2674 djSP; dMARK; dORIGMARK;
2675 register HV *hv = (HV*)POPs;
2676 register I32 lval = PL_op->op_flags & OPf_MOD;
2677 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2679 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2680 DIE("Can't localize pseudo-hash element");
2682 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2683 while (++MARK <= SP) {
2687 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2688 svp = he ? &HeVAL(he) : 0;
2691 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2694 if (!svp || *svp == &PL_sv_undef) {
2696 DIE(PL_no_helem, SvPV(keysv, n_a));
2698 if (PL_op->op_private & OPpLVAL_INTRO)
2699 save_helem(hv, keysv, svp);
2701 *MARK = svp ? *svp : &PL_sv_undef;
2704 if (GIMME != G_ARRAY) {
2712 /* List operators. */
2717 if (GIMME != G_ARRAY) {
2719 *MARK = *SP; /* unwanted list, return last item */
2721 *MARK = &PL_sv_undef;
2730 SV **lastrelem = PL_stack_sp;
2731 SV **lastlelem = PL_stack_base + POPMARK;
2732 SV **firstlelem = PL_stack_base + POPMARK + 1;
2733 register SV **firstrelem = lastlelem + 1;
2734 I32 arybase = PL_curcop->cop_arybase;
2735 I32 lval = PL_op->op_flags & OPf_MOD;
2736 I32 is_something_there = lval;
2738 register I32 max = lastrelem - lastlelem;
2739 register SV **lelem;
2742 if (GIMME != G_ARRAY) {
2743 ix = SvIVx(*lastlelem);
2748 if (ix < 0 || ix >= max)
2749 *firstlelem = &PL_sv_undef;
2751 *firstlelem = firstrelem[ix];
2757 SP = firstlelem - 1;
2761 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2766 *lelem = &PL_sv_undef;
2767 else if (!(*lelem = firstrelem[ix]))
2768 *lelem = &PL_sv_undef;
2772 if (ix >= max || !(*lelem = firstrelem[ix]))
2773 *lelem = &PL_sv_undef;
2775 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2776 is_something_there = TRUE;
2778 if (is_something_there)
2781 SP = firstlelem - 1;
2787 djSP; dMARK; dORIGMARK;
2788 I32 items = SP - MARK;
2789 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2790 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2797 djSP; dMARK; dORIGMARK;
2798 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2802 SV *val = NEWSV(46, 0);
2804 sv_setsv(val, *++MARK);
2805 else if (ckWARN(WARN_UNSAFE))
2806 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2807 (void)hv_store_ent(hv,key,val,0);
2816 djSP; dMARK; dORIGMARK;
2817 register AV *ary = (AV*)*++MARK;
2821 register I32 offset;
2822 register I32 length;
2829 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2830 *MARK-- = SvTIED_obj((SV*)ary, mg);
2834 perl_call_method("SPLICE",GIMME_V);
2843 offset = i = SvIVx(*MARK);
2845 offset += AvFILLp(ary) + 1;
2847 offset -= PL_curcop->cop_arybase;
2849 DIE(PL_no_aelem, i);
2851 length = SvIVx(*MARK++);
2853 length += AvFILLp(ary) - offset + 1;
2859 length = AvMAX(ary) + 1; /* close enough to infinity */
2863 length = AvMAX(ary) + 1;
2865 if (offset > AvFILLp(ary) + 1)
2866 offset = AvFILLp(ary) + 1;
2867 after = AvFILLp(ary) + 1 - (offset + length);
2868 if (after < 0) { /* not that much array */
2869 length += after; /* offset+length now in array */
2875 /* At this point, MARK .. SP-1 is our new LIST */
2878 diff = newlen - length;
2879 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2882 if (diff < 0) { /* shrinking the area */
2884 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2885 Copy(MARK, tmparyval, newlen, SV*);
2888 MARK = ORIGMARK + 1;
2889 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2890 MEXTEND(MARK, length);
2891 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2893 EXTEND_MORTAL(length);
2894 for (i = length, dst = MARK; i; i--) {
2895 sv_2mortal(*dst); /* free them eventualy */
2902 *MARK = AvARRAY(ary)[offset+length-1];
2905 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2906 SvREFCNT_dec(*dst++); /* free them now */
2909 AvFILLp(ary) += diff;
2911 /* pull up or down? */
2913 if (offset < after) { /* easier to pull up */
2914 if (offset) { /* esp. if nothing to pull */
2915 src = &AvARRAY(ary)[offset-1];
2916 dst = src - diff; /* diff is negative */
2917 for (i = offset; i > 0; i--) /* can't trust Copy */
2921 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2925 if (after) { /* anything to pull down? */
2926 src = AvARRAY(ary) + offset + length;
2927 dst = src + diff; /* diff is negative */
2928 Move(src, dst, after, SV*);
2930 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2931 /* avoid later double free */
2935 dst[--i] = &PL_sv_undef;
2938 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2940 *dst = NEWSV(46, 0);
2941 sv_setsv(*dst++, *src++);
2943 Safefree(tmparyval);
2946 else { /* no, expanding (or same) */
2948 New(452, tmparyval, length, SV*); /* so remember deletion */
2949 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2952 if (diff > 0) { /* expanding */
2954 /* push up or down? */
2956 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2960 Move(src, dst, offset, SV*);
2962 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2964 AvFILLp(ary) += diff;
2967 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2968 av_extend(ary, AvFILLp(ary) + diff);
2969 AvFILLp(ary) += diff;
2972 dst = AvARRAY(ary) + AvFILLp(ary);
2974 for (i = after; i; i--) {
2981 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2982 *dst = NEWSV(46, 0);
2983 sv_setsv(*dst++, *src++);
2985 MARK = ORIGMARK + 1;
2986 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2988 Copy(tmparyval, MARK, length, SV*);
2990 EXTEND_MORTAL(length);
2991 for (i = length, dst = MARK; i; i--) {
2992 sv_2mortal(*dst); /* free them eventualy */
2996 Safefree(tmparyval);
3000 else if (length--) {
3001 *MARK = tmparyval[length];
3004 while (length-- > 0)
3005 SvREFCNT_dec(tmparyval[length]);
3007 Safefree(tmparyval);
3010 *MARK = &PL_sv_undef;
3018 djSP; dMARK; dORIGMARK; dTARGET;
3019 register AV *ary = (AV*)*++MARK;
3020 register SV *sv = &PL_sv_undef;
3023 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3024 *MARK-- = SvTIED_obj((SV*)ary, mg);
3028 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3033 /* Why no pre-extend of ary here ? */
3034 for (++MARK; MARK <= SP; MARK++) {
3037 sv_setsv(sv, *MARK);
3042 PUSHi( AvFILL(ary) + 1 );
3050 SV *sv = av_pop(av);
3052 (void)sv_2mortal(sv);
3061 SV *sv = av_shift(av);
3066 (void)sv_2mortal(sv);
3073 djSP; dMARK; dORIGMARK; dTARGET;
3074 register AV *ary = (AV*)*++MARK;
3079 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3080 *MARK-- = SvTIED_obj((SV*)ary, mg);
3084 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3089 av_unshift(ary, SP - MARK);
3092 sv_setsv(sv, *++MARK);
3093 (void)av_store(ary, i++, sv);
3097 PUSHi( AvFILL(ary) + 1 );
3107 if (GIMME == G_ARRAY) {
3118 register char *down;
3124 do_join(TARG, &PL_sv_no, MARK, SP);
3126 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3127 up = SvPV_force(TARG, len);
3129 if (IN_UTF8) { /* first reverse each character */
3130 U8* s = (U8*)SvPVX(TARG);
3131 U8* send = (U8*)(s + len);
3140 down = (char*)(s - 1);
3141 if (s > send || !((*down & 0xc0) == 0x80)) {
3142 warn("Malformed UTF-8 character");
3154 down = SvPVX(TARG) + len - 1;
3160 (void)SvPOK_only(TARG);
3169 mul128(SV *sv, U8 m)
3172 char *s = SvPV(sv, len);
3176 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3177 SV *tmpNew = newSVpv("0000000000", 10);
3179 sv_catsv(tmpNew, sv);
3180 SvREFCNT_dec(sv); /* free old sv */
3185 while (!*t) /* trailing '\0'? */
3188 i = ((*t - '0') << 7) + m;
3189 *(t--) = '0' + (i % 10);
3195 /* Explosives and implosives. */
3197 #if 'I' == 73 && 'J' == 74
3198 /* On an ASCII/ISO kind of system */
3199 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3202 Some other sort of character set - use memchr() so we don't match
3205 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3213 I32 gimme = GIMME_V;
3217 register char *pat = SvPV(left, llen);
3218 register char *s = SvPV(right, rlen);
3219 char *strend = s + rlen;
3221 register char *patend = pat + llen;
3226 /* These must not be in registers: */
3243 register U32 culong;
3246 int natint; /* native integer */
3247 int unatint; /* unsigned native integer */
3249 if (gimme != G_ARRAY) { /* arrange to do first one only */
3251 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3252 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3254 while (isDIGIT(*patend) || *patend == '*')
3260 while (pat < patend) {
3262 datumtype = *pat++ & 0xFF;
3264 if (isSPACE(datumtype))
3267 char *natstr = "sSiIlL";
3269 if (strchr(natstr, datumtype)) {
3274 croak("'_' allowed only after types %s", natstr);
3278 else if (*pat == '*') {
3279 len = strend - strbeg; /* long enough */
3282 else if (isDIGIT(*pat)) {
3284 while (isDIGIT(*pat))
3285 len = (len * 10) + (*pat++ - '0');
3288 len = (datumtype != '@');
3291 croak("Invalid type in unpack: '%c'", (int)datumtype);
3292 case ',': /* grandfather in commas but with a warning */
3293 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3294 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3297 if (len == 1 && pat[-1] != '1')
3306 if (len > strend - strbeg)
3307 DIE("@ outside of string");
3311 if (len > s - strbeg)
3312 DIE("X outside of string");
3316 if (len > strend - s)
3317 DIE("x outside of string");
3323 if (len > strend - s)
3326 goto uchar_checksum;
3327 sv = NEWSV(35, len);
3328 sv_setpvn(sv, s, len);
3330 if (datumtype == 'A' || datumtype == 'Z') {
3331 aptr = s; /* borrow register */
3332 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3337 else { /* 'A' strips both nulls and spaces */
3338 s = SvPVX(sv) + len - 1;
3339 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3343 SvCUR_set(sv, s - SvPVX(sv));
3344 s = aptr; /* unborrow register */
3346 XPUSHs(sv_2mortal(sv));
3350 if (pat[-1] == '*' || len > (strend - s) * 8)
3351 len = (strend - s) * 8;
3354 Newz(601, PL_bitcount, 256, char);
3355 for (bits = 1; bits < 256; bits++) {
3356 if (bits & 1) PL_bitcount[bits]++;
3357 if (bits & 2) PL_bitcount[bits]++;
3358 if (bits & 4) PL_bitcount[bits]++;
3359 if (bits & 8) PL_bitcount[bits]++;
3360 if (bits & 16) PL_bitcount[bits]++;
3361 if (bits & 32) PL_bitcount[bits]++;
3362 if (bits & 64) PL_bitcount[bits]++;
3363 if (bits & 128) PL_bitcount[bits]++;
3367 culong += PL_bitcount[*(unsigned char*)s++];
3372 if (datumtype == 'b') {
3374 if (bits & 1) culong++;
3380 if (bits & 128) culong++;
3387 sv = NEWSV(35, len + 1);
3390 aptr = pat; /* borrow register */
3392 if (datumtype == 'b') {
3394 for (len = 0; len < aint; len++) {
3395 if (len & 7) /*SUPPRESS 595*/
3399 *pat++ = '0' + (bits & 1);
3404 for (len = 0; len < aint; len++) {
3409 *pat++ = '0' + ((bits & 128) != 0);
3413 pat = aptr; /* unborrow register */
3414 XPUSHs(sv_2mortal(sv));
3418 if (pat[-1] == '*' || len > (strend - s) * 2)
3419 len = (strend - s) * 2;
3420 sv = NEWSV(35, len + 1);
3423 aptr = pat; /* borrow register */
3425 if (datumtype == 'h') {
3427 for (len = 0; len < aint; len++) {
3432 *pat++ = PL_hexdigit[bits & 15];
3437 for (len = 0; len < aint; len++) {
3442 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3446 pat = aptr; /* unborrow register */
3447 XPUSHs(sv_2mortal(sv));
3450 if (len > strend - s)
3455 if (aint >= 128) /* fake up signed chars */
3465 if (aint >= 128) /* fake up signed chars */
3468 sv_setiv(sv, (IV)aint);
3469 PUSHs(sv_2mortal(sv));
3474 if (len > strend - s)
3489 sv_setiv(sv, (IV)auint);
3490 PUSHs(sv_2mortal(sv));
3495 if (len > strend - s)
3498 while (len-- > 0 && s < strend) {
3499 auint = utf8_to_uv((U8*)s, &along);
3502 cdouble += (double)auint;
3510 while (len-- > 0 && s < strend) {
3511 auint = utf8_to_uv((U8*)s, &along);
3514 sv_setuv(sv, (UV)auint);
3515 PUSHs(sv_2mortal(sv));
3520 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3526 COPYNN(s, &ashort, sizeof(short));
3545 COPYNN(s, &ashort, sizeof(short));
3548 sv_setiv(sv, (IV)ashort);
3549 PUSHs(sv_2mortal(sv));
3557 sv_setiv(sv, (IV)ashort);
3558 PUSHs(sv_2mortal(sv));
3566 unatint = natint && datumtype == 'S';
3567 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3573 COPYNN(s, &aushort, sizeof(unsigned short));
3574 s += sizeof(unsigned short);
3580 COPY16(s, &aushort);
3583 if (datumtype == 'n')
3584 aushort = PerlSock_ntohs(aushort);
3587 if (datumtype == 'v')
3588 aushort = vtohs(aushort);
3599 COPYNN(s, &aushort, sizeof(unsigned short));
3600 s += sizeof(unsigned short);
3602 sv_setiv(sv, (IV)aushort);
3603 PUSHs(sv_2mortal(sv));
3608 COPY16(s, &aushort);
3612 if (datumtype == 'n')
3613 aushort = PerlSock_ntohs(aushort);
3616 if (datumtype == 'v')
3617 aushort = vtohs(aushort);
3619 sv_setiv(sv, (IV)aushort);
3620 PUSHs(sv_2mortal(sv));
3626 along = (strend - s) / sizeof(int);
3631 Copy(s, &aint, 1, int);
3634 cdouble += (double)aint;
3643 Copy(s, &aint, 1, int);
3647 /* Without the dummy below unpack("i", pack("i",-1))
3648 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3649 * cc with optimization turned on */
3651 sv_setiv(sv, (IV)aint) :
3653 sv_setiv(sv, (IV)aint);
3654 PUSHs(sv_2mortal(sv));
3659 along = (strend - s) / sizeof(unsigned int);
3664 Copy(s, &auint, 1, unsigned int);
3665 s += sizeof(unsigned int);
3667 cdouble += (double)auint;
3676 Copy(s, &auint, 1, unsigned int);
3677 s += sizeof(unsigned int);
3680 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3681 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3682 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3683 * with optimization turned on.
3684 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3685 * does not have this problem even with -O4)
3688 sv_setuv(sv, (UV)auint) :
3690 sv_setuv(sv, (UV)auint);
3691 PUSHs(sv_2mortal(sv));
3696 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3702 COPYNN(s, &along, sizeof(long));
3705 cdouble += (double)along;
3715 cdouble += (double)along;
3726 COPYNN(s, &along, sizeof(long));
3729 sv_setiv(sv, (IV)along);
3730 PUSHs(sv_2mortal(sv));
3738 sv_setiv(sv, (IV)along);
3739 PUSHs(sv_2mortal(sv));
3747 unatint = natint && datumtype;
3748 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3754 COPYNN(s, &aulong, sizeof(unsigned long));
3755 s += sizeof(unsigned long);
3757 cdouble += (double)aulong;
3767 if (datumtype == 'N')
3768 aulong = PerlSock_ntohl(aulong);
3771 if (datumtype == 'V')
3772 aulong = vtohl(aulong);
3775 cdouble += (double)aulong;
3786 COPYNN(s, &aulong, sizeof(unsigned long));
3787 s += sizeof(unsigned long);
3789 sv_setuv(sv, (UV)aulong);
3790 PUSHs(sv_2mortal(sv));
3798 if (datumtype == 'N')
3799 aulong = PerlSock_ntohl(aulong);
3802 if (datumtype == 'V')
3803 aulong = vtohl(aulong);
3806 sv_setuv(sv, (UV)aulong);
3807 PUSHs(sv_2mortal(sv));
3813 along = (strend - s) / sizeof(char*);
3819 if (sizeof(char*) > strend - s)
3822 Copy(s, &aptr, 1, char*);
3828 PUSHs(sv_2mortal(sv));
3838 while ((len > 0) && (s < strend)) {
3839 auv = (auv << 7) | (*s & 0x7f);
3840 if (!(*s++ & 0x80)) {
3844 PUSHs(sv_2mortal(sv));
3848 else if (++bytes >= sizeof(UV)) { /* promote to string */
3852 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3853 while (s < strend) {
3854 sv = mul128(sv, *s & 0x7f);
3855 if (!(*s++ & 0x80)) {
3864 PUSHs(sv_2mortal(sv));
3869 if ((s >= strend) && bytes)
3870 croak("Unterminated compressed integer");
3875 if (sizeof(char*) > strend - s)
3878 Copy(s, &aptr, 1, char*);
3883 sv_setpvn(sv, aptr, len);
3884 PUSHs(sv_2mortal(sv));
3888 along = (strend - s) / sizeof(Quad_t);
3894 if (s + sizeof(Quad_t) > strend)
3897 Copy(s, &aquad, 1, Quad_t);
3898 s += sizeof(Quad_t);
3901 if (aquad >= IV_MIN && aquad <= IV_MAX)
3902 sv_setiv(sv, (IV)aquad);
3904 sv_setnv(sv, (double)aquad);
3905 PUSHs(sv_2mortal(sv));
3909 along = (strend - s) / sizeof(Quad_t);
3915 if (s + sizeof(Uquad_t) > strend)
3918 Copy(s, &auquad, 1, Uquad_t);
3919 s += sizeof(Uquad_t);
3922 if (auquad <= UV_MAX)
3923 sv_setuv(sv, (UV)auquad);
3925 sv_setnv(sv, (double)auquad);
3926 PUSHs(sv_2mortal(sv));
3930 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3933 along = (strend - s) / sizeof(float);
3938 Copy(s, &afloat, 1, float);
3947 Copy(s, &afloat, 1, float);
3950 sv_setnv(sv, (double)afloat);
3951 PUSHs(sv_2mortal(sv));
3957 along = (strend - s) / sizeof(double);
3962 Copy(s, &adouble, 1, double);
3963 s += sizeof(double);
3971 Copy(s, &adouble, 1, double);
3972 s += sizeof(double);
3974 sv_setnv(sv, (double)adouble);
3975 PUSHs(sv_2mortal(sv));
3981 * Initialise the decode mapping. By using a table driven
3982 * algorithm, the code will be character-set independent
3983 * (and just as fast as doing character arithmetic)
3985 if (PL_uudmap['M'] == 0) {
3988 for (i = 0; i < sizeof(PL_uuemap); i += 1)
3989 PL_uudmap[PL_uuemap[i]] = i;
3991 * Because ' ' and '`' map to the same value,
3992 * we need to decode them both the same.
3997 along = (strend - s) * 3 / 4;
3998 sv = NEWSV(42, along);
4001 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4006 len = PL_uudmap[*s++] & 077;
4008 if (s < strend && ISUUCHAR(*s))
4009 a = PL_uudmap[*s++] & 077;
4012 if (s < strend && ISUUCHAR(*s))
4013 b = PL_uudmap[*s++] & 077;
4016 if (s < strend && ISUUCHAR(*s))
4017 c = PL_uudmap[*s++] & 077;
4020 if (s < strend && ISUUCHAR(*s))
4021 d = PL_uudmap[*s++] & 077;
4024 hunk[0] = (a << 2) | (b >> 4);
4025 hunk[1] = (b << 4) | (c >> 2);
4026 hunk[2] = (c << 6) | d;
4027 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4032 else if (s[1] == '\n') /* possible checksum byte */
4035 XPUSHs(sv_2mortal(sv));
4040 if (strchr("fFdD", datumtype) ||
4041 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4045 while (checksum >= 16) {
4049 while (checksum >= 4) {
4055 along = (1 << checksum) - 1;
4056 while (cdouble < 0.0)
4058 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4059 sv_setnv(sv, cdouble);
4062 if (checksum < 32) {
4063 aulong = (1 << checksum) - 1;
4066 sv_setuv(sv, (UV)culong);
4068 XPUSHs(sv_2mortal(sv));
4072 if (SP == oldsp && gimme == G_SCALAR)
4073 PUSHs(&PL_sv_undef);
4078 doencodes(register SV *sv, register char *s, register I32 len)
4082 *hunk = PL_uuemap[len];
4083 sv_catpvn(sv, hunk, 1);
4086 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4087 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4088 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4089 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4090 sv_catpvn(sv, hunk, 4);
4095 char r = (len > 1 ? s[1] : '\0');
4096 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4097 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4098 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4099 hunk[3] = PL_uuemap[0];
4100 sv_catpvn(sv, hunk, 4);
4102 sv_catpvn(sv, "\n", 1);
4106 is_an_int(char *s, STRLEN l)
4109 SV *result = newSVpv("", l);
4110 char *result_c = SvPV(result, n_a); /* convenience */
4111 char *out = result_c;
4121 SvREFCNT_dec(result);
4144 SvREFCNT_dec(result);
4150 SvCUR_set(result, out - result_c);
4155 div128(SV *pnum, bool *done)
4156 /* must be '\0' terminated */
4160 char *s = SvPV(pnum, len);
4169 i = m * 10 + (*t - '0');
4171 r = (i >> 7); /* r < 10 */
4178 SvCUR_set(pnum, (STRLEN) (t - s));
4185 djSP; dMARK; dORIGMARK; dTARGET;
4186 register SV *cat = TARG;
4189 register char *pat = SvPVx(*++MARK, fromlen);
4190 register char *patend = pat + fromlen;
4195 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4196 static char *space10 = " ";
4198 /* These must not be in registers: */
4213 int natint; /* native integer */
4217 sv_setpvn(cat, "", 0);
4218 while (pat < patend) {
4219 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4220 datumtype = *pat++ & 0xFF;
4222 if (isSPACE(datumtype))
4225 char *natstr = "sSiIlL";
4227 if (strchr(natstr, datumtype)) {
4232 croak("'_' allowed only after types %s", natstr);
4235 len = strchr("@Xxu", datumtype) ? 0 : items;
4238 else if (isDIGIT(*pat)) {
4240 while (isDIGIT(*pat))
4241 len = (len * 10) + (*pat++ - '0');
4247 croak("Invalid type in pack: '%c'", (int)datumtype);
4248 case ',': /* grandfather in commas but with a warning */
4249 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4250 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4253 DIE("%% may only be used in unpack");
4264 if (SvCUR(cat) < len)
4265 DIE("X outside of string");
4272 sv_catpvn(cat, null10, 10);
4275 sv_catpvn(cat, null10, len);
4281 aptr = SvPV(fromstr, fromlen);
4285 sv_catpvn(cat, aptr, len);
4287 sv_catpvn(cat, aptr, fromlen);
4289 if (datumtype == 'A') {
4291 sv_catpvn(cat, space10, 10);
4294 sv_catpvn(cat, space10, len);
4298 sv_catpvn(cat, null10, 10);
4301 sv_catpvn(cat, null10, len);
4308 char *savepat = pat;
4313 aptr = SvPV(fromstr, fromlen);
4318 SvCUR(cat) += (len+7)/8;
4319 SvGROW(cat, SvCUR(cat) + 1);
4320 aptr = SvPVX(cat) + aint;
4325 if (datumtype == 'B') {
4326 for (len = 0; len++ < aint;) {
4327 items |= *pat++ & 1;
4331 *aptr++ = items & 0xff;
4337 for (len = 0; len++ < aint;) {
4343 *aptr++ = items & 0xff;
4349 if (datumtype == 'B')
4350 items <<= 7 - (aint & 7);
4352 items >>= 7 - (aint & 7);
4353 *aptr++ = items & 0xff;
4355 pat = SvPVX(cat) + SvCUR(cat);
4366 char *savepat = pat;
4371 aptr = SvPV(fromstr, fromlen);
4376 SvCUR(cat) += (len+1)/2;
4377 SvGROW(cat, SvCUR(cat) + 1);
4378 aptr = SvPVX(cat) + aint;
4383 if (datumtype == 'H') {
4384 for (len = 0; len++ < aint;) {
4386 items |= ((*pat++ & 15) + 9) & 15;
4388 items |= *pat++ & 15;
4392 *aptr++ = items & 0xff;
4398 for (len = 0; len++ < aint;) {
4400 items |= (((*pat++ & 15) + 9) & 15) << 4;
4402 items |= (*pat++ & 15) << 4;
4406 *aptr++ = items & 0xff;
4412 *aptr++ = items & 0xff;
4413 pat = SvPVX(cat) + SvCUR(cat);
4425 aint = SvIV(fromstr);
4427 sv_catpvn(cat, &achar, sizeof(char));
4433 auint = SvUV(fromstr);
4434 SvGROW(cat, SvCUR(cat) + 10);
4435 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4440 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4445 afloat = (float)SvNV(fromstr);
4446 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4453 adouble = (double)SvNV(fromstr);
4454 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4460 ashort = (I16)SvIV(fromstr);
4462 ashort = PerlSock_htons(ashort);
4464 CAT16(cat, &ashort);
4470 ashort = (I16)SvIV(fromstr);
4472 ashort = htovs(ashort);
4474 CAT16(cat, &ashort);
4479 unsigned short aushort;
4483 aushort = SvUV(fromstr);
4484 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4492 aushort = (U16)SvIV(fromstr);
4493 CAT16(cat, &aushort);
4501 ashort = SvIV(fromstr);
4502 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4508 ashort = (I16)SvIV(fromstr);
4509 CAT16(cat, &ashort);
4516 auint = SvUV(fromstr);
4517 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4523 adouble = floor(SvNV(fromstr));
4526 croak("Cannot compress negative numbers");
4532 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4533 adouble <= UV_MAX_cxux
4540 char buf[1 + sizeof(UV)];
4541 char *in = buf + sizeof(buf);
4542 UV auv = U_V(adouble);;
4545 *--in = (auv & 0x7f) | 0x80;
4548 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4549 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4551 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4552 char *from, *result, *in;
4557 /* Copy string and check for compliance */
4558 from = SvPV(fromstr, len);
4559 if ((norm = is_an_int(from, len)) == NULL)
4560 croak("can compress only unsigned integer");
4562 New('w', result, len, char);
4566 *--in = div128(norm, &done) | 0x80;
4567 result[len - 1] &= 0x7F; /* clear continue bit */
4568 sv_catpvn(cat, in, (result + len) - in);
4570 SvREFCNT_dec(norm); /* free norm */
4572 else if (SvNOKp(fromstr)) {
4573 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4574 char *in = buf + sizeof(buf);
4577 double next = floor(adouble / 128);
4578 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4579 if (--in < buf) /* this cannot happen ;-) */
4580 croak ("Cannot compress integer");
4582 } while (adouble > 0);
4583 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4584 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4587 croak("Cannot compress non integer");
4593 aint = SvIV(fromstr);
4594 sv_catpvn(cat, (char*)&aint, sizeof(int));
4600 aulong = SvUV(fromstr);
4602 aulong = PerlSock_htonl(aulong);
4604 CAT32(cat, &aulong);
4610 aulong = SvUV(fromstr);
4612 aulong = htovl(aulong);
4614 CAT32(cat, &aulong);
4621 aulong = SvUV(fromstr);
4622 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4628 aulong = SvUV(fromstr);
4629 CAT32(cat, &aulong);
4637 along = SvIV(fromstr);
4638 sv_catpvn(cat, (char *)&along, sizeof(long));
4644 along = SvIV(fromstr);
4653 auquad = (Uquad_t)SvIV(fromstr);
4654 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4660 aquad = (Quad_t)SvIV(fromstr);
4661 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4664 #endif /* HAS_QUAD */
4666 len = 1; /* assume SV is correct length */
4671 if (fromstr == &PL_sv_undef)
4675 /* XXX better yet, could spirit away the string to
4676 * a safe spot and hang on to it until the result
4677 * of pack() (and all copies of the result) are
4680 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4682 "Attempt to pack pointer to temporary value");
4683 if (SvPOK(fromstr) || SvNIOK(fromstr))
4684 aptr = SvPV(fromstr,n_a);
4686 aptr = SvPV_force(fromstr,n_a);
4688 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4693 aptr = SvPV(fromstr, fromlen);
4694 SvGROW(cat, fromlen * 4 / 3);
4699 while (fromlen > 0) {
4706 doencodes(cat, aptr, todo);
4725 register I32 limit = POPi; /* note, negative is forever */
4728 register char *s = SvPV(sv, len);
4729 char *strend = s + len;
4731 register REGEXP *rx;
4735 I32 maxiters = (strend - s) + 10;
4738 I32 origlimit = limit;
4741 AV *oldstack = PL_curstack;
4742 I32 gimme = GIMME_V;
4743 I32 oldsave = PL_savestack_ix;
4744 I32 make_mortal = 1;
4745 MAGIC *mg = (MAGIC *) NULL;
4748 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4753 DIE("panic: do_split");
4754 rx = pm->op_pmregexp;
4756 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4757 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4759 if (pm->op_pmreplroot)
4760 ary = GvAVn((GV*)pm->op_pmreplroot);
4761 else if (gimme != G_ARRAY)
4763 ary = (AV*)PL_curpad[0];
4765 ary = GvAVn(PL_defgv);
4766 #endif /* USE_THREADS */
4769 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4775 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4777 XPUSHs(SvTIED_obj((SV*)ary, mg));
4782 for (i = AvFILLp(ary); i >= 0; i--)
4783 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4785 /* temporarily switch stacks */
4786 SWITCHSTACK(PL_curstack, ary);
4790 base = SP - PL_stack_base;
4792 if (pm->op_pmflags & PMf_SKIPWHITE) {
4793 if (pm->op_pmflags & PMf_LOCALE) {
4794 while (isSPACE_LC(*s))
4802 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4803 SAVEINT(PL_multiline);
4804 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4808 limit = maxiters + 2;
4809 if (pm->op_pmflags & PMf_WHITE) {
4812 while (m < strend &&
4813 !((pm->op_pmflags & PMf_LOCALE)
4814 ? isSPACE_LC(*m) : isSPACE(*m)))
4819 dstr = NEWSV(30, m-s);
4820 sv_setpvn(dstr, s, m-s);
4826 while (s < strend &&
4827 ((pm->op_pmflags & PMf_LOCALE)
4828 ? isSPACE_LC(*s) : isSPACE(*s)))
4832 else if (strEQ("^", rx->precomp)) {
4835 for (m = s; m < strend && *m != '\n'; m++) ;
4839 dstr = NEWSV(30, m-s);
4840 sv_setpvn(dstr, s, m-s);
4847 else if (rx->check_substr && !rx->nparens
4848 && (rx->reganch & ROPT_CHECK_ALL)
4849 && !(rx->reganch & ROPT_ANCH)) {
4850 i = SvCUR(rx->check_substr);
4851 if (i == 1 && !SvTAIL(rx->check_substr)) {
4852 i = *SvPVX(rx->check_substr);
4855 for (m = s; m < strend && *m != i; m++) ;
4858 dstr = NEWSV(30, m-s);
4859 sv_setpvn(dstr, s, m-s);
4868 while (s < strend && --limit &&
4869 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4870 rx->check_substr, 0)) )
4873 dstr = NEWSV(31, m-s);
4874 sv_setpvn(dstr, s, m-s);
4883 maxiters += (strend - s) * rx->nparens;
4884 while (s < strend && --limit &&
4885 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4887 TAINT_IF(RX_MATCH_TAINTED(rx));
4889 && rx->subbase != orig) {
4894 strend = s + (strend - m);
4897 dstr = NEWSV(32, m-s);
4898 sv_setpvn(dstr, s, m-s);
4903 for (i = 1; i <= rx->nparens; i++) {
4907 dstr = NEWSV(33, m-s);
4908 sv_setpvn(dstr, s, m-s);
4911 dstr = NEWSV(33, 0);
4921 LEAVE_SCOPE(oldsave);
4922 iters = (SP - PL_stack_base) - base;
4923 if (iters > maxiters)
4926 /* keep field after final delim? */
4927 if (s < strend || (iters && origlimit)) {
4928 dstr = NEWSV(34, strend-s);
4929 sv_setpvn(dstr, s, strend-s);
4935 else if (!origlimit) {
4936 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4942 SWITCHSTACK(ary, oldstack);
4943 if (SvSMAGICAL(ary)) {
4948 if (gimme == G_ARRAY) {
4950 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4958 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4961 if (gimme == G_ARRAY) {
4962 /* EXTEND should not be needed - we just popped them */
4964 for (i=0; i < iters; i++) {
4965 SV **svp = av_fetch(ary, i, FALSE);
4966 PUSHs((svp) ? *svp : &PL_sv_undef);
4973 if (gimme == G_ARRAY)
4976 if (iters || !pm->op_pmreplroot) {
4986 unlock_condpair(void *svv)
4989 MAGIC *mg = mg_find((SV*)svv, 'm');
4992 croak("panic: unlock_condpair unlocking non-mutex");
4993 MUTEX_LOCK(MgMUTEXP(mg));
4994 if (MgOWNER(mg) != thr)
4995 croak("panic: unlock_condpair unlocking mutex that we don't own");
4997 COND_SIGNAL(MgOWNERCONDP(mg));
4998 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4999 (unsigned long)thr, (unsigned long)svv);)
5000 MUTEX_UNLOCK(MgMUTEXP(mg));
5002 #endif /* USE_THREADS */
5015 mg = condpair_magic(sv);
5016 MUTEX_LOCK(MgMUTEXP(mg));
5017 if (MgOWNER(mg) == thr)
5018 MUTEX_UNLOCK(MgMUTEXP(mg));
5021 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5023 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5024 (unsigned long)thr, (unsigned long)sv);)
5025 MUTEX_UNLOCK(MgMUTEXP(mg));
5026 save_destructor(unlock_condpair, sv);
5028 #endif /* USE_THREADS */
5029 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5030 || SvTYPE(retsv) == SVt_PVCV) {
5031 retsv = refto(retsv);
5042 if (PL_op->op_private & OPpLVAL_INTRO)
5043 PUSHs(*save_threadsv(PL_op->op_targ));
5045 PUSHs(THREADSV(PL_op->op_targ));
5048 DIE("tried to access per-thread data in non-threaded perl");
5049 #endif /* USE_THREADS */