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 SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
82 # define PERL_NATINT_PACK
85 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
86 # if BYTEORDER == 0x12345678
87 # define OFF16(p) (char*)(p)
88 # define OFF32(p) (char*)(p)
90 # if BYTEORDER == 0x87654321
91 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
92 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
94 }}}} bad cray byte order
97 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
98 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
99 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
100 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
101 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
103 # define COPY16(s,p) Copy(s, p, SIZE16, char)
104 # define COPY32(s,p) Copy(s, p, SIZE32, char)
105 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
106 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
107 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
111 static void doencodes _((SV* sv, char* s, I32 len));
112 static SV* refto _((SV* sv));
113 static U32 seed _((void));
116 /* variations on pp_null */
122 /* XXX I can't imagine anyone who doesn't have this actually _needs_
123 it, since pid_t is an integral type.
126 #ifdef NEED_GETPID_PROTO
127 extern Pid_t getpid (void);
133 if (GIMME_V == G_SCALAR)
134 XPUSHs(&PL_sv_undef);
148 if (PL_op->op_private & OPpLVAL_INTRO)
149 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
151 if (PL_op->op_flags & OPf_REF) {
155 if (GIMME == G_ARRAY) {
156 I32 maxarg = AvFILL((AV*)TARG) + 1;
158 if (SvMAGICAL(TARG)) {
160 for (i=0; i < maxarg; i++) {
161 SV **svp = av_fetch((AV*)TARG, i, FALSE);
162 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
166 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
171 SV* sv = sv_newmortal();
172 I32 maxarg = AvFILL((AV*)TARG) + 1;
173 sv_setiv(sv, maxarg);
185 if (PL_op->op_private & OPpLVAL_INTRO)
186 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
187 if (PL_op->op_flags & OPf_REF)
190 if (gimme == G_ARRAY) {
191 RETURNOP(do_kv(ARGS));
193 else if (gimme == G_SCALAR) {
194 SV* sv = sv_newmortal();
195 if (HvFILL((HV*)TARG))
196 sv_setpvf(sv, "%ld/%ld",
197 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
207 DIE("NOT IMPL LINE %d",__LINE__);
218 tryAMAGICunDEREF(to_gv);
221 if (SvTYPE(sv) == SVt_PVIO) {
222 GV *gv = (GV*) sv_newmortal();
223 gv_init(gv, 0, "", 0, 0);
224 GvIOp(gv) = (IO *)sv;
225 (void)SvREFCNT_inc(sv);
228 else if (SvTYPE(sv) != SVt_PVGV)
229 DIE("Not a GLOB reference");
232 if (SvTYPE(sv) != SVt_PVGV) {
236 if (SvGMAGICAL(sv)) {
242 if (PL_op->op_flags & OPf_REF ||
243 PL_op->op_private & HINT_STRICT_REFS)
244 DIE(PL_no_usym, "a symbol");
245 if (ckWARN(WARN_UNINITIALIZED))
246 warner(WARN_UNINITIALIZED, PL_warn_uninit);
250 if ((PL_op->op_flags & OPf_SPECIAL) &&
251 !(PL_op->op_flags & OPf_MOD))
253 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
258 if (PL_op->op_private & HINT_STRICT_REFS)
259 DIE(PL_no_symref, sym, "a symbol");
260 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
264 if (PL_op->op_private & OPpLVAL_INTRO)
265 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
276 tryAMAGICunDEREF(to_sv);
279 switch (SvTYPE(sv)) {
283 DIE("Not a SCALAR reference");
291 if (SvTYPE(gv) != SVt_PVGV) {
292 if (SvGMAGICAL(sv)) {
298 if (PL_op->op_flags & OPf_REF ||
299 PL_op->op_private & HINT_STRICT_REFS)
300 DIE(PL_no_usym, "a SCALAR");
301 if (ckWARN(WARN_UNINITIALIZED))
302 warner(WARN_UNINITIALIZED, PL_warn_uninit);
306 if ((PL_op->op_flags & OPf_SPECIAL) &&
307 !(PL_op->op_flags & OPf_MOD))
309 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
314 if (PL_op->op_private & HINT_STRICT_REFS)
315 DIE(PL_no_symref, sym, "a SCALAR");
316 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
321 if (PL_op->op_flags & OPf_MOD) {
322 if (PL_op->op_private & OPpLVAL_INTRO)
323 sv = save_scalar((GV*)TOPs);
324 else if (PL_op->op_private & OPpDEREF)
325 vivify_ref(sv, PL_op->op_private & OPpDEREF);
335 SV *sv = AvARYLEN(av);
337 AvARYLEN(av) = sv = NEWSV(0,0);
338 sv_upgrade(sv, SVt_IV);
339 sv_magic(sv, (SV*)av, '#', Nullch, 0);
347 djSP; dTARGET; dPOPss;
349 if (PL_op->op_flags & OPf_MOD) {
350 if (SvTYPE(TARG) < SVt_PVLV) {
351 sv_upgrade(TARG, SVt_PVLV);
352 sv_magic(TARG, Nullsv, '.', Nullch, 0);
356 if (LvTARG(TARG) != sv) {
358 SvREFCNT_dec(LvTARG(TARG));
359 LvTARG(TARG) = SvREFCNT_inc(sv);
361 PUSHs(TARG); /* no SvSETMAGIC */
367 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
368 mg = mg_find(sv, 'g');
369 if (mg && mg->mg_len >= 0) {
373 PUSHi(i + PL_curcop->cop_arybase);
387 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
388 /* (But not in defined().) */
389 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
392 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
395 cv = (CV*)&PL_sv_undef;
409 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
410 char *s = SvPVX(TOPs);
411 if (strnEQ(s, "CORE::", 6)) {
414 code = keyword(s + 6, SvCUR(TOPs) - 6);
415 if (code < 0) { /* Overridable. */
416 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
417 int i = 0, n = 0, seen_question = 0;
419 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
421 while (i < MAXO) { /* The slow way. */
422 if (strEQ(s + 6, PL_op_name[i])
423 || strEQ(s + 6, PL_op_desc[i]))
429 goto nonesuch; /* Should not happen... */
431 oa = PL_opargs[i] >> OASHIFT;
433 if (oa & OA_OPTIONAL) {
437 else if (seen_question)
438 goto set; /* XXXX system, exec */
439 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
440 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
443 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
444 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
448 ret = sv_2mortal(newSVpv(str, n - 1));
450 else if (code) /* Non-Overridable */
452 else { /* None such */
454 croak("Cannot find an opnumber for \"%s\"", s+6);
458 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
460 ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
469 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
471 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
487 if (GIMME != G_ARRAY) {
491 *MARK = &PL_sv_undef;
492 *MARK = refto(*MARK);
496 EXTEND_MORTAL(SP - MARK);
498 *MARK = refto(*MARK);
507 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
510 if (!(sv = LvTARG(sv)))
513 else if (SvPADTMP(sv))
517 (void)SvREFCNT_inc(sv);
520 sv_upgrade(rv, SVt_RV);
534 if (sv && SvGMAGICAL(sv))
537 if (!sv || !SvROK(sv))
541 pv = sv_reftype(sv,TRUE);
542 PUSHp(pv, strlen(pv));
552 stash = PL_curcop->cop_stash;
556 char *ptr = SvPV(ssv,len);
557 if (ckWARN(WARN_UNSAFE) && len == 0)
559 "Explicit blessing to '' (assuming package main)");
560 stash = gv_stashpvn(ptr, len, TRUE);
563 (void)sv_bless(TOPs, stash);
577 elem = SvPV(sv, n_a);
581 switch (elem ? *elem : '\0')
584 if (strEQ(elem, "ARRAY"))
585 tmpRef = (SV*)GvAV(gv);
588 if (strEQ(elem, "CODE"))
589 tmpRef = (SV*)GvCVu(gv);
592 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
593 tmpRef = (SV*)GvIOp(gv);
596 if (strEQ(elem, "GLOB"))
600 if (strEQ(elem, "HASH"))
601 tmpRef = (SV*)GvHV(gv);
604 if (strEQ(elem, "IO"))
605 tmpRef = (SV*)GvIOp(gv);
608 if (strEQ(elem, "NAME"))
609 sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
612 if (strEQ(elem, "PACKAGE"))
613 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
616 if (strEQ(elem, "SCALAR"))
630 /* Pattern matching */
635 register UNOP *unop = cUNOP;
636 register unsigned char *s;
639 register I32 *sfirst;
643 if (sv == PL_lastscream) {
649 SvSCREAM_off(PL_lastscream);
650 SvREFCNT_dec(PL_lastscream);
652 PL_lastscream = SvREFCNT_inc(sv);
655 s = (unsigned char*)(SvPV(sv, len));
659 if (pos > PL_maxscream) {
660 if (PL_maxscream < 0) {
661 PL_maxscream = pos + 80;
662 New(301, PL_screamfirst, 256, I32);
663 New(302, PL_screamnext, PL_maxscream, I32);
666 PL_maxscream = pos + pos / 4;
667 Renew(PL_screamnext, PL_maxscream, I32);
671 sfirst = PL_screamfirst;
672 snext = PL_screamnext;
674 if (!sfirst || !snext)
675 DIE("do_study: out of memory");
677 for (ch = 256; ch; --ch)
684 snext[pos] = sfirst[ch] - pos;
691 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
700 if (PL_op->op_flags & OPf_STACKED)
706 TARG = sv_newmortal();
711 /* Lvalue operators. */
723 djSP; dMARK; dTARGET;
733 SETi(do_chomp(TOPs));
739 djSP; dMARK; dTARGET;
740 register I32 count = 0;
743 count += do_chomp(POPs);
754 if (!sv || !SvANY(sv))
756 switch (SvTYPE(sv)) {
758 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
762 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
766 if (CvROOT(sv) || CvXSUB(sv))
783 if (!PL_op->op_private) {
792 if (SvTHINKFIRST(sv)) {
793 if (SvREADONLY(sv)) {
795 if (PL_curcop != &PL_compiling)
802 switch (SvTYPE(sv)) {
812 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
813 warner(WARN_UNSAFE, "Constant subroutine %s undefined",
814 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
817 { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
819 CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
823 SvSetMagicSV(sv, &PL_sv_undef);
827 Newz(602, gp, 1, GP);
828 GvGP(sv) = gp_ref(gp);
829 GvSV(sv) = NEWSV(72,0);
830 GvLINE(sv) = PL_curcop->cop_line;
836 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
839 SvPV_set(sv, Nullch);
852 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
854 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
855 SvIVX(TOPs) != IV_MIN)
858 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
869 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
871 sv_setsv(TARG, TOPs);
872 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
873 SvIVX(TOPs) != IV_MAX)
876 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
890 if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
892 sv_setsv(TARG, TOPs);
893 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
894 SvIVX(TOPs) != IV_MIN)
897 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
906 /* Ordinary operators. */
910 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
913 SETn( pow( left, right) );
920 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
923 SETn( left * right );
930 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
935 DIE("Illegal division by zero");
937 /* insure that 20./5. == 4. */
940 if ((double)I_V(left) == left &&
941 (double)I_V(right) == right &&
942 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
946 value = left / right;
950 value = left / right;
959 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
967 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
969 right = (right_neg = (i < 0)) ? -i : i;
973 right = U_V((right_neg = (n < 0)) ? -n : n);
976 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
978 left = (left_neg = (i < 0)) ? -i : i;
982 left = U_V((left_neg = (n < 0)) ? -n : n);
986 DIE("Illegal modulus zero");
989 if ((left_neg != right_neg) && ans)
992 /* XXX may warn: unary minus operator applied to unsigned type */
993 /* could change -foo to be (~foo)+1 instead */
994 if (ans <= ~((UV)IV_MAX)+1)
995 sv_setiv(TARG, ~ans+1);
997 sv_setnv(TARG, -(double)ans);
1000 sv_setuv(TARG, ans);
1008 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1010 register I32 count = POPi;
1011 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1013 I32 items = SP - MARK;
1016 max = items * count;
1025 repeatcpy((char*)(MARK + items), (char*)MARK,
1026 items * sizeof(SV*), count - 1);
1029 else if (count <= 0)
1032 else { /* Note: mark already snarfed by pp_list */
1037 if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
1038 if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
1039 DIE("Can't x= to readonly value");
1043 SvSetSV(TARG, tmpstr);
1044 SvPV_force(TARG, len);
1049 SvGROW(TARG, (count * len) + 1);
1050 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1051 SvCUR(TARG) *= count;
1053 *SvEND(TARG) = '\0';
1055 (void)SvPOK_only(TARG);
1064 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1067 SETn( left - right );
1074 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1077 if (PL_op->op_private & HINT_INTEGER) {
1079 i = BWi(i) << shift;
1093 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1096 if (PL_op->op_private & HINT_INTEGER) {
1098 i = BWi(i) >> shift;
1112 djSP; tryAMAGICbinSET(lt,0);
1115 SETs(boolSV(TOPn < value));
1122 djSP; tryAMAGICbinSET(gt,0);
1125 SETs(boolSV(TOPn > value));
1132 djSP; tryAMAGICbinSET(le,0);
1135 SETs(boolSV(TOPn <= value));
1142 djSP; tryAMAGICbinSET(ge,0);
1145 SETs(boolSV(TOPn >= value));
1152 djSP; tryAMAGICbinSET(ne,0);
1155 SETs(boolSV(TOPn != value));
1162 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1169 else if (left < right)
1171 else if (left > right)
1184 djSP; tryAMAGICbinSET(slt,0);
1187 int cmp = ((PL_op->op_private & OPpLOCALE)
1188 ? sv_cmp_locale(left, right)
1189 : sv_cmp(left, right));
1190 SETs(boolSV(cmp < 0));
1197 djSP; tryAMAGICbinSET(sgt,0);
1200 int cmp = ((PL_op->op_private & OPpLOCALE)
1201 ? sv_cmp_locale(left, right)
1202 : sv_cmp(left, right));
1203 SETs(boolSV(cmp > 0));
1210 djSP; tryAMAGICbinSET(sle,0);
1213 int cmp = ((PL_op->op_private & OPpLOCALE)
1214 ? sv_cmp_locale(left, right)
1215 : sv_cmp(left, right));
1216 SETs(boolSV(cmp <= 0));
1223 djSP; tryAMAGICbinSET(sge,0);
1226 int cmp = ((PL_op->op_private & OPpLOCALE)
1227 ? sv_cmp_locale(left, right)
1228 : sv_cmp(left, right));
1229 SETs(boolSV(cmp >= 0));
1236 djSP; tryAMAGICbinSET(seq,0);
1239 SETs(boolSV(sv_eq(left, right)));
1246 djSP; tryAMAGICbinSET(sne,0);
1249 SETs(boolSV(!sv_eq(left, right)));
1256 djSP; dTARGET; tryAMAGICbin(scmp,0);
1259 int cmp = ((PL_op->op_private & OPpLOCALE)
1260 ? sv_cmp_locale(left, right)
1261 : sv_cmp(left, right));
1269 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1272 if (SvNIOKp(left) || SvNIOKp(right)) {
1273 if (PL_op->op_private & HINT_INTEGER) {
1274 IBW value = SvIV(left) & SvIV(right);
1278 UBW value = SvUV(left) & SvUV(right);
1283 do_vop(PL_op->op_type, TARG, left, right);
1292 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1295 if (SvNIOKp(left) || SvNIOKp(right)) {
1296 if (PL_op->op_private & HINT_INTEGER) {
1297 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1301 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1306 do_vop(PL_op->op_type, TARG, left, right);
1315 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1318 if (SvNIOKp(left) || SvNIOKp(right)) {
1319 if (PL_op->op_private & HINT_INTEGER) {
1320 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1324 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1329 do_vop(PL_op->op_type, TARG, left, right);
1338 djSP; dTARGET; tryAMAGICun(neg);
1343 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1345 else if (SvNIOKp(sv))
1347 else if (SvPOKp(sv)) {
1349 char *s = SvPV(sv, len);
1350 if (isIDFIRST(*s)) {
1351 sv_setpvn(TARG, "-", 1);
1354 else if (*s == '+' || *s == '-') {
1356 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1358 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1359 sv_setpvn(TARG, "-", 1);
1363 sv_setnv(TARG, -SvNV(sv));
1374 djSP; tryAMAGICunSET(not);
1375 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1381 djSP; dTARGET; tryAMAGICun(compl);
1385 if (PL_op->op_private & HINT_INTEGER) {
1386 IBW value = ~SvIV(sv);
1390 UBW value = ~SvUV(sv);
1395 register char *tmps;
1396 register long *tmpl;
1401 tmps = SvPV_force(TARG, len);
1404 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1407 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1411 for ( ; anum > 0; anum--, tmps++)
1420 /* integer versions of some of the above */
1424 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1427 SETi( left * right );
1434 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1438 DIE("Illegal division by zero");
1439 value = POPi / value;
1447 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1451 DIE("Illegal modulus zero");
1452 SETi( left % right );
1459 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1462 SETi( left + right );
1469 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1472 SETi( left - right );
1479 djSP; tryAMAGICbinSET(lt,0);
1482 SETs(boolSV(left < right));
1489 djSP; tryAMAGICbinSET(gt,0);
1492 SETs(boolSV(left > right));
1499 djSP; tryAMAGICbinSET(le,0);
1502 SETs(boolSV(left <= right));
1509 djSP; tryAMAGICbinSET(ge,0);
1512 SETs(boolSV(left >= right));
1519 djSP; tryAMAGICbinSET(eq,0);
1522 SETs(boolSV(left == right));
1529 djSP; tryAMAGICbinSET(ne,0);
1532 SETs(boolSV(left != right));
1539 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1546 else if (left < right)
1557 djSP; dTARGET; tryAMAGICun(neg);
1562 /* High falutin' math. */
1566 djSP; dTARGET; tryAMAGICbin(atan2,0);
1569 SETn(atan2(left, right));
1576 djSP; dTARGET; tryAMAGICun(sin);
1588 djSP; dTARGET; tryAMAGICun(cos);
1598 /* Support Configure command-line overrides for rand() functions.
1599 After 5.005, perhaps we should replace this by Configure support
1600 for drand48(), random(), or rand(). For 5.005, though, maintain
1601 compatibility by calling rand() but allow the user to override it.
1602 See INSTALL for details. --Andy Dougherty 15 July 1998
1604 /* Now it's after 5.005, and Configure supports drand48() and random(),
1605 in addition to rand(). So the overrides should not be needed any more.
1606 --Jarkko Hietaniemi 27 September 1998
1609 #ifndef HAS_DRAND48_PROTO
1610 extern double drand48 _((void));
1623 if (!PL_srand_called) {
1624 (void)seedDrand01((Rand_seed_t)seed());
1625 PL_srand_called = TRUE;
1640 (void)seedDrand01((Rand_seed_t)anum);
1641 PL_srand_called = TRUE;
1650 * This is really just a quick hack which grabs various garbage
1651 * values. It really should be a real hash algorithm which
1652 * spreads the effect of every input bit onto every output bit,
1653 * if someone who knows about such things would bother to write it.
1654 * Might be a good idea to add that function to CORE as well.
1655 * No numbers below come from careful analysis or anything here,
1656 * except they are primes and SEED_C1 > 1E6 to get a full-width
1657 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1658 * probably be bigger too.
1661 # define SEED_C1 1000003
1662 #define SEED_C4 73819
1664 # define SEED_C1 25747
1665 #define SEED_C4 20639
1669 #define SEED_C5 26107
1672 #ifndef PERL_NO_DEV_RANDOM
1677 # include <starlet.h>
1678 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1679 * in 100-ns units, typically incremented ever 10 ms. */
1680 unsigned int when[2];
1682 # ifdef HAS_GETTIMEOFDAY
1683 struct timeval when;
1689 /* This test is an escape hatch, this symbol isn't set by Configure. */
1690 #ifndef PERL_NO_DEV_RANDOM
1691 #ifndef PERL_RANDOM_DEVICE
1692 /* /dev/random isn't used by default because reads from it will block
1693 * if there isn't enough entropy available. You can compile with
1694 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1695 * is enough real entropy to fill the seed. */
1696 # define PERL_RANDOM_DEVICE "/dev/urandom"
1698 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1700 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1709 _ckvmssts(sys$gettim(when));
1710 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1712 # ifdef HAS_GETTIMEOFDAY
1713 gettimeofday(&when,(struct timezone *) 0);
1714 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1717 u = (U32)SEED_C1 * when;
1720 u += SEED_C3 * (U32)getpid();
1721 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1722 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1723 u += SEED_C5 * (U32)(UV)&when;
1730 djSP; dTARGET; tryAMAGICun(exp);
1742 djSP; dTARGET; tryAMAGICun(log);
1747 SET_NUMERIC_STANDARD();
1748 DIE("Can't take log of %g", value);
1758 djSP; dTARGET; tryAMAGICun(sqrt);
1763 SET_NUMERIC_STANDARD();
1764 DIE("Can't take sqrt of %g", value);
1766 value = sqrt(value);
1776 double value = TOPn;
1779 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1785 (void)modf(value, &value);
1787 (void)modf(-value, &value);
1802 djSP; dTARGET; tryAMAGICun(abs);
1804 double value = TOPn;
1807 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1808 (iv = SvIVX(TOPs)) != IV_MIN) {
1830 XPUSHu(scan_hex(tmps, 99, &argtype));
1843 while (*tmps && isSPACE(*tmps))
1848 value = scan_hex(++tmps, 99, &argtype);
1849 else if (*tmps == 'b')
1850 value = scan_bin(++tmps, 99, &argtype);
1852 value = scan_oct(tmps, 99, &argtype);
1864 SETi( sv_len_utf8(TOPs) );
1868 SETi( sv_len(TOPs) );
1882 I32 lvalue = PL_op->op_flags & OPf_MOD;
1884 I32 arybase = PL_curcop->cop_arybase;
1888 SvTAINTED_off(TARG); /* decontaminate */
1892 repl = SvPV(sv, repl_len);
1899 tmps = SvPV(sv, curlen);
1901 utfcurlen = sv_len_utf8(sv);
1902 if (utfcurlen == curlen)
1910 if (pos >= arybase) {
1928 else if (len >= 0) {
1930 if (rem > (I32)curlen)
1944 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1945 warner(WARN_SUBSTR, "substr outside of string");
1950 sv_pos_u2b(sv, &pos, &rem);
1952 sv_setpvn(TARG, tmps, rem);
1953 if (lvalue) { /* it's an lvalue! */
1954 if (!SvGMAGICAL(sv)) {
1958 if (ckWARN(WARN_SUBSTR))
1960 "Attempt to use reference as lvalue in substr");
1962 if (SvOK(sv)) /* is it defined ? */
1963 (void)SvPOK_only(sv);
1965 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1968 if (SvTYPE(TARG) < SVt_PVLV) {
1969 sv_upgrade(TARG, SVt_PVLV);
1970 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1974 if (LvTARG(TARG) != sv) {
1976 SvREFCNT_dec(LvTARG(TARG));
1977 LvTARG(TARG) = SvREFCNT_inc(sv);
1979 LvTARGOFF(TARG) = pos;
1980 LvTARGLEN(TARG) = rem;
1983 sv_insert(sv, pos, rem, repl, repl_len);
1986 PUSHs(TARG); /* avoid SvSETMAGIC here */
1993 register I32 size = POPi;
1994 register I32 offset = POPi;
1995 register SV *src = POPs;
1996 I32 lvalue = PL_op->op_flags & OPf_MOD;
1998 unsigned char *s = (unsigned char*)SvPV(src, srclen);
1999 unsigned long retnum;
2002 SvTAINTED_off(TARG); /* decontaminate */
2003 offset *= size; /* turn into bit offset */
2004 len = (offset + size + 7) / 8;
2005 if (offset < 0 || size < 1)
2008 if (lvalue) { /* it's an lvalue! */
2009 if (SvTYPE(TARG) < SVt_PVLV) {
2010 sv_upgrade(TARG, SVt_PVLV);
2011 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2015 if (LvTARG(TARG) != src) {
2017 SvREFCNT_dec(LvTARG(TARG));
2018 LvTARG(TARG) = SvREFCNT_inc(src);
2020 LvTARGOFF(TARG) = offset;
2021 LvTARGLEN(TARG) = size;
2029 if (offset >= srclen)
2032 retnum = (unsigned long) s[offset] << 8;
2034 else if (size == 32) {
2035 if (offset >= srclen)
2037 else if (offset + 1 >= srclen)
2038 retnum = (unsigned long) s[offset] << 24;
2039 else if (offset + 2 >= srclen)
2040 retnum = ((unsigned long) s[offset] << 24) +
2041 ((unsigned long) s[offset + 1] << 16);
2043 retnum = ((unsigned long) s[offset] << 24) +
2044 ((unsigned long) s[offset + 1] << 16) +
2045 (s[offset + 2] << 8);
2050 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2055 else if (size == 16)
2056 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2057 else if (size == 32)
2058 retnum = ((unsigned long) s[offset] << 24) +
2059 ((unsigned long) s[offset + 1] << 16) +
2060 (s[offset + 2] << 8) + s[offset+3];
2064 sv_setuv(TARG, (UV)retnum);
2079 I32 arybase = PL_curcop->cop_arybase;
2084 offset = POPi - arybase;
2087 tmps = SvPV(big, biglen);
2088 if (IN_UTF8 && offset > 0)
2089 sv_pos_u2b(big, &offset, 0);
2092 else if (offset > biglen)
2094 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2095 (unsigned char*)tmps + biglen, little, 0)))
2098 retval = tmps2 - tmps;
2099 if (IN_UTF8 && retval > 0)
2100 sv_pos_b2u(big, &retval);
2101 PUSHi(retval + arybase);
2116 I32 arybase = PL_curcop->cop_arybase;
2122 tmps2 = SvPV(little, llen);
2123 tmps = SvPV(big, blen);
2127 if (IN_UTF8 && offset > 0)
2128 sv_pos_u2b(big, &offset, 0);
2129 offset = offset - arybase + llen;
2133 else if (offset > blen)
2135 if (!(tmps2 = rninstr(tmps, tmps + offset,
2136 tmps2, tmps2 + llen)))
2139 retval = tmps2 - tmps;
2140 if (IN_UTF8 && retval > 0)
2141 sv_pos_b2u(big, &retval);
2142 PUSHi(retval + arybase);
2148 djSP; dMARK; dORIGMARK; dTARGET;
2149 #ifdef USE_LOCALE_NUMERIC
2150 if (PL_op->op_private & OPpLOCALE)
2151 SET_NUMERIC_LOCAL();
2153 SET_NUMERIC_STANDARD();
2155 do_sprintf(TARG, SP-MARK, MARK+1);
2156 TAINT_IF(SvTAINTED(TARG));
2167 U8 *tmps = (U8*)POPpx;
2170 if (IN_UTF8 && (*tmps & 0x80))
2171 value = utf8_to_uv(tmps, &retlen);
2173 value = (UV)(*tmps & 255);
2184 (void)SvUPGRADE(TARG,SVt_PV);
2186 if (IN_UTF8 && value >= 128) {
2189 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2190 SvCUR_set(TARG, tmps - SvPVX(TARG));
2192 (void)SvPOK_only(TARG);
2202 (void)SvPOK_only(TARG);
2209 djSP; dTARGET; dPOPTOPssrl;
2212 char *tmps = SvPV(left, n_a);
2214 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2216 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2220 "The crypt() function is unimplemented due to excessive paranoia.");
2233 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2237 UV uv = utf8_to_uv(s, &ulen);
2239 if (PL_op->op_private & OPpLOCALE) {
2242 uv = toTITLE_LC_uni(uv);
2245 uv = toTITLE_utf8(s);
2247 tend = uv_to_utf8(tmpbuf, uv);
2249 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2251 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2252 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2256 s = (U8*)SvPV_force(sv, slen);
2257 Copy(tmpbuf, s, ulen, U8);
2262 if (!SvPADTMP(sv)) {
2268 s = (U8*)SvPV_force(sv, slen);
2270 if (PL_op->op_private & OPpLOCALE) {
2273 *s = toUPPER_LC(*s);
2289 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2293 UV uv = utf8_to_uv(s, &ulen);
2295 if (PL_op->op_private & OPpLOCALE) {
2298 uv = toLOWER_LC_uni(uv);
2301 uv = toLOWER_utf8(s);
2303 tend = uv_to_utf8(tmpbuf, uv);
2305 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2307 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2308 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2312 s = (U8*)SvPV_force(sv, slen);
2313 Copy(tmpbuf, s, ulen, U8);
2318 if (!SvPADTMP(sv)) {
2324 s = (U8*)SvPV_force(sv, slen);
2326 if (PL_op->op_private & OPpLOCALE) {
2329 *s = toLOWER_LC(*s);
2352 s = (U8*)SvPV(sv,len);
2354 sv_setpvn(TARG, "", 0);
2359 (void)SvUPGRADE(TARG, SVt_PV);
2360 SvGROW(TARG, (len * 2) + 1);
2361 (void)SvPOK_only(TARG);
2362 d = (U8*)SvPVX(TARG);
2364 if (PL_op->op_private & OPpLOCALE) {
2368 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2374 d = uv_to_utf8(d, toUPPER_utf8( s ));
2379 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2384 if (!SvPADTMP(sv)) {
2391 s = (U8*)SvPV_force(sv, len);
2393 register U8 *send = s + len;
2395 if (PL_op->op_private & OPpLOCALE) {
2398 for (; s < send; s++)
2399 *s = toUPPER_LC(*s);
2402 for (; s < send; s++)
2422 s = (U8*)SvPV(sv,len);
2424 sv_setpvn(TARG, "", 0);
2429 (void)SvUPGRADE(TARG, SVt_PV);
2430 SvGROW(TARG, (len * 2) + 1);
2431 (void)SvPOK_only(TARG);
2432 d = (U8*)SvPVX(TARG);
2434 if (PL_op->op_private & OPpLOCALE) {
2438 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2444 d = uv_to_utf8(d, toLOWER_utf8(s));
2449 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2454 if (!SvPADTMP(sv)) {
2461 s = (U8*)SvPV_force(sv, len);
2463 register U8 *send = s + len;
2465 if (PL_op->op_private & OPpLOCALE) {
2468 for (; s < send; s++)
2469 *s = toLOWER_LC(*s);
2472 for (; s < send; s++)
2484 register char *s = SvPV(sv,len);
2488 (void)SvUPGRADE(TARG, SVt_PV);
2489 SvGROW(TARG, (len * 2) + 1);
2494 STRLEN ulen = UTF8SKIP(s);
2517 SvCUR_set(TARG, d - SvPVX(TARG));
2518 (void)SvPOK_only(TARG);
2521 sv_setpvn(TARG, s, len);
2530 djSP; dMARK; dORIGMARK;
2532 register AV* av = (AV*)POPs;
2533 register I32 lval = PL_op->op_flags & OPf_MOD;
2534 I32 arybase = PL_curcop->cop_arybase;
2537 if (SvTYPE(av) == SVt_PVAV) {
2538 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2540 for (svp = MARK + 1; svp <= SP; svp++) {
2545 if (max > AvMAX(av))
2548 while (++MARK <= SP) {
2549 elem = SvIVx(*MARK);
2553 svp = av_fetch(av, elem, lval);
2555 if (!svp || *svp == &PL_sv_undef)
2556 DIE(PL_no_aelem, elem);
2557 if (PL_op->op_private & OPpLVAL_INTRO)
2558 save_aelem(av, elem, svp);
2560 *MARK = svp ? *svp : &PL_sv_undef;
2563 if (GIMME != G_ARRAY) {
2571 /* Associative arrays. */
2576 HV *hash = (HV*)POPs;
2578 I32 gimme = GIMME_V;
2579 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2582 /* might clobber stack_sp */
2583 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2588 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2589 if (gimme == G_ARRAY) {
2591 /* might clobber stack_sp */
2592 sv_setsv(TARG, realhv ?
2593 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2598 else if (gimme == G_SCALAR)
2617 I32 gimme = GIMME_V;
2618 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2622 if (PL_op->op_private & OPpSLICE) {
2626 hvtype = SvTYPE(hv);
2627 while (++MARK <= SP) {
2628 if (hvtype == SVt_PVHV)
2629 sv = hv_delete_ent(hv, *MARK, discard, 0);
2631 DIE("Not a HASH reference");
2632 *MARK = sv ? sv : &PL_sv_undef;
2636 else if (gimme == G_SCALAR) {
2645 if (SvTYPE(hv) == SVt_PVHV)
2646 sv = hv_delete_ent(hv, keysv, discard, 0);
2648 DIE("Not a HASH reference");
2662 if (SvTYPE(hv) == SVt_PVHV) {
2663 if (hv_exists_ent(hv, tmpsv, 0))
2666 else if (SvTYPE(hv) == SVt_PVAV) {
2667 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2671 DIE("Not a HASH reference");
2678 djSP; dMARK; dORIGMARK;
2679 register HV *hv = (HV*)POPs;
2680 register I32 lval = PL_op->op_flags & OPf_MOD;
2681 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2683 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2684 DIE("Can't localize pseudo-hash element");
2686 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2687 while (++MARK <= SP) {
2691 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2692 svp = he ? &HeVAL(he) : 0;
2695 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2698 if (!svp || *svp == &PL_sv_undef) {
2700 DIE(PL_no_helem, SvPV(keysv, n_a));
2702 if (PL_op->op_private & OPpLVAL_INTRO)
2703 save_helem(hv, keysv, svp);
2705 *MARK = svp ? *svp : &PL_sv_undef;
2708 if (GIMME != G_ARRAY) {
2716 /* List operators. */
2721 if (GIMME != G_ARRAY) {
2723 *MARK = *SP; /* unwanted list, return last item */
2725 *MARK = &PL_sv_undef;
2734 SV **lastrelem = PL_stack_sp;
2735 SV **lastlelem = PL_stack_base + POPMARK;
2736 SV **firstlelem = PL_stack_base + POPMARK + 1;
2737 register SV **firstrelem = lastlelem + 1;
2738 I32 arybase = PL_curcop->cop_arybase;
2739 I32 lval = PL_op->op_flags & OPf_MOD;
2740 I32 is_something_there = lval;
2742 register I32 max = lastrelem - lastlelem;
2743 register SV **lelem;
2746 if (GIMME != G_ARRAY) {
2747 ix = SvIVx(*lastlelem);
2752 if (ix < 0 || ix >= max)
2753 *firstlelem = &PL_sv_undef;
2755 *firstlelem = firstrelem[ix];
2761 SP = firstlelem - 1;
2765 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2770 *lelem = &PL_sv_undef;
2771 else if (!(*lelem = firstrelem[ix]))
2772 *lelem = &PL_sv_undef;
2776 if (ix >= max || !(*lelem = firstrelem[ix]))
2777 *lelem = &PL_sv_undef;
2779 if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2780 is_something_there = TRUE;
2782 if (is_something_there)
2785 SP = firstlelem - 1;
2791 djSP; dMARK; dORIGMARK;
2792 I32 items = SP - MARK;
2793 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2794 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2801 djSP; dMARK; dORIGMARK;
2802 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2806 SV *val = NEWSV(46, 0);
2808 sv_setsv(val, *++MARK);
2809 else if (ckWARN(WARN_UNSAFE))
2810 warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
2811 (void)hv_store_ent(hv,key,val,0);
2820 djSP; dMARK; dORIGMARK;
2821 register AV *ary = (AV*)*++MARK;
2825 register I32 offset;
2826 register I32 length;
2833 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2834 *MARK-- = SvTIED_obj((SV*)ary, mg);
2838 perl_call_method("SPLICE",GIMME_V);
2847 offset = i = SvIVx(*MARK);
2849 offset += AvFILLp(ary) + 1;
2851 offset -= PL_curcop->cop_arybase;
2853 DIE(PL_no_aelem, i);
2855 length = SvIVx(*MARK++);
2857 length += AvFILLp(ary) - offset + 1;
2863 length = AvMAX(ary) + 1; /* close enough to infinity */
2867 length = AvMAX(ary) + 1;
2869 if (offset > AvFILLp(ary) + 1)
2870 offset = AvFILLp(ary) + 1;
2871 after = AvFILLp(ary) + 1 - (offset + length);
2872 if (after < 0) { /* not that much array */
2873 length += after; /* offset+length now in array */
2879 /* At this point, MARK .. SP-1 is our new LIST */
2882 diff = newlen - length;
2883 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2886 if (diff < 0) { /* shrinking the area */
2888 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2889 Copy(MARK, tmparyval, newlen, SV*);
2892 MARK = ORIGMARK + 1;
2893 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2894 MEXTEND(MARK, length);
2895 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2897 EXTEND_MORTAL(length);
2898 for (i = length, dst = MARK; i; i--) {
2899 sv_2mortal(*dst); /* free them eventualy */
2906 *MARK = AvARRAY(ary)[offset+length-1];
2909 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2910 SvREFCNT_dec(*dst++); /* free them now */
2913 AvFILLp(ary) += diff;
2915 /* pull up or down? */
2917 if (offset < after) { /* easier to pull up */
2918 if (offset) { /* esp. if nothing to pull */
2919 src = &AvARRAY(ary)[offset-1];
2920 dst = src - diff; /* diff is negative */
2921 for (i = offset; i > 0; i--) /* can't trust Copy */
2925 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2929 if (after) { /* anything to pull down? */
2930 src = AvARRAY(ary) + offset + length;
2931 dst = src + diff; /* diff is negative */
2932 Move(src, dst, after, SV*);
2934 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2935 /* avoid later double free */
2939 dst[--i] = &PL_sv_undef;
2942 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2944 *dst = NEWSV(46, 0);
2945 sv_setsv(*dst++, *src++);
2947 Safefree(tmparyval);
2950 else { /* no, expanding (or same) */
2952 New(452, tmparyval, length, SV*); /* so remember deletion */
2953 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2956 if (diff > 0) { /* expanding */
2958 /* push up or down? */
2960 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2964 Move(src, dst, offset, SV*);
2966 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2968 AvFILLp(ary) += diff;
2971 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2972 av_extend(ary, AvFILLp(ary) + diff);
2973 AvFILLp(ary) += diff;
2976 dst = AvARRAY(ary) + AvFILLp(ary);
2978 for (i = after; i; i--) {
2985 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2986 *dst = NEWSV(46, 0);
2987 sv_setsv(*dst++, *src++);
2989 MARK = ORIGMARK + 1;
2990 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2992 Copy(tmparyval, MARK, length, SV*);
2994 EXTEND_MORTAL(length);
2995 for (i = length, dst = MARK; i; i--) {
2996 sv_2mortal(*dst); /* free them eventualy */
3000 Safefree(tmparyval);
3004 else if (length--) {
3005 *MARK = tmparyval[length];
3008 while (length-- > 0)
3009 SvREFCNT_dec(tmparyval[length]);
3011 Safefree(tmparyval);
3014 *MARK = &PL_sv_undef;
3022 djSP; dMARK; dORIGMARK; dTARGET;
3023 register AV *ary = (AV*)*++MARK;
3024 register SV *sv = &PL_sv_undef;
3027 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3028 *MARK-- = SvTIED_obj((SV*)ary, mg);
3032 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
3037 /* Why no pre-extend of ary here ? */
3038 for (++MARK; MARK <= SP; MARK++) {
3041 sv_setsv(sv, *MARK);
3046 PUSHi( AvFILL(ary) + 1 );
3054 SV *sv = av_pop(av);
3056 (void)sv_2mortal(sv);
3065 SV *sv = av_shift(av);
3070 (void)sv_2mortal(sv);
3077 djSP; dMARK; dORIGMARK; dTARGET;
3078 register AV *ary = (AV*)*++MARK;
3083 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3084 *MARK-- = SvTIED_obj((SV*)ary, mg);
3088 perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3093 av_unshift(ary, SP - MARK);
3096 sv_setsv(sv, *++MARK);
3097 (void)av_store(ary, i++, sv);
3101 PUSHi( AvFILL(ary) + 1 );
3111 if (GIMME == G_ARRAY) {
3122 register char *down;
3128 do_join(TARG, &PL_sv_no, MARK, SP);
3130 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3131 up = SvPV_force(TARG, len);
3133 if (IN_UTF8) { /* first reverse each character */
3134 U8* s = (U8*)SvPVX(TARG);
3135 U8* send = (U8*)(s + len);
3144 down = (char*)(s - 1);
3145 if (s > send || !((*down & 0xc0) == 0x80)) {
3146 warn("Malformed UTF-8 character");
3158 down = SvPVX(TARG) + len - 1;
3164 (void)SvPOK_only(TARG);
3173 mul128(SV *sv, U8 m)
3176 char *s = SvPV(sv, len);
3180 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3181 SV *tmpNew = newSVpv("0000000000", 10);
3183 sv_catsv(tmpNew, sv);
3184 SvREFCNT_dec(sv); /* free old sv */
3189 while (!*t) /* trailing '\0'? */
3192 i = ((*t - '0') << 7) + m;
3193 *(t--) = '0' + (i % 10);
3199 /* Explosives and implosives. */
3201 #if 'I' == 73 && 'J' == 74
3202 /* On an ASCII/ISO kind of system */
3203 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3206 Some other sort of character set - use memchr() so we don't match
3209 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3217 I32 gimme = GIMME_V;
3221 register char *pat = SvPV(left, llen);
3222 register char *s = SvPV(right, rlen);
3223 char *strend = s + rlen;
3225 register char *patend = pat + llen;
3230 /* These must not be in registers: */
3247 register U32 culong;
3250 #ifdef PERL_NATINT_PACK
3251 int natint; /* native integer */
3252 int unatint; /* unsigned native integer */
3255 if (gimme != G_ARRAY) { /* arrange to do first one only */
3257 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3258 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3260 while (isDIGIT(*patend) || *patend == '*')
3266 while (pat < patend) {
3268 datumtype = *pat++ & 0xFF;
3269 #ifdef PERL_NATINT_PACK
3272 if (isSPACE(datumtype))
3275 char *natstr = "sSiIlL";
3277 if (strchr(natstr, datumtype)) {
3278 #ifdef PERL_NATINT_PACK
3284 croak("'_' allowed only after types %s", natstr);
3288 else if (*pat == '*') {
3289 len = strend - strbeg; /* long enough */
3292 else if (isDIGIT(*pat)) {
3294 while (isDIGIT(*pat))
3295 len = (len * 10) + (*pat++ - '0');
3298 len = (datumtype != '@');
3301 croak("Invalid type in unpack: '%c'", (int)datumtype);
3302 case ',': /* grandfather in commas but with a warning */
3303 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3304 warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3307 if (len == 1 && pat[-1] != '1')
3316 if (len > strend - strbeg)
3317 DIE("@ outside of string");
3321 if (len > s - strbeg)
3322 DIE("X outside of string");
3326 if (len > strend - s)
3327 DIE("x outside of string");
3333 if (len > strend - s)
3336 goto uchar_checksum;
3337 sv = NEWSV(35, len);
3338 sv_setpvn(sv, s, len);
3340 if (datumtype == 'A' || datumtype == 'Z') {
3341 aptr = s; /* borrow register */
3342 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3347 else { /* 'A' strips both nulls and spaces */
3348 s = SvPVX(sv) + len - 1;
3349 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3353 SvCUR_set(sv, s - SvPVX(sv));
3354 s = aptr; /* unborrow register */
3356 XPUSHs(sv_2mortal(sv));
3360 if (pat[-1] == '*' || len > (strend - s) * 8)
3361 len = (strend - s) * 8;
3364 Newz(601, PL_bitcount, 256, char);
3365 for (bits = 1; bits < 256; bits++) {
3366 if (bits & 1) PL_bitcount[bits]++;
3367 if (bits & 2) PL_bitcount[bits]++;
3368 if (bits & 4) PL_bitcount[bits]++;
3369 if (bits & 8) PL_bitcount[bits]++;
3370 if (bits & 16) PL_bitcount[bits]++;
3371 if (bits & 32) PL_bitcount[bits]++;
3372 if (bits & 64) PL_bitcount[bits]++;
3373 if (bits & 128) PL_bitcount[bits]++;
3377 culong += PL_bitcount[*(unsigned char*)s++];
3382 if (datumtype == 'b') {
3384 if (bits & 1) culong++;
3390 if (bits & 128) culong++;
3397 sv = NEWSV(35, len + 1);
3400 aptr = pat; /* borrow register */
3402 if (datumtype == 'b') {
3404 for (len = 0; len < aint; len++) {
3405 if (len & 7) /*SUPPRESS 595*/
3409 *pat++ = '0' + (bits & 1);
3414 for (len = 0; len < aint; len++) {
3419 *pat++ = '0' + ((bits & 128) != 0);
3423 pat = aptr; /* unborrow register */
3424 XPUSHs(sv_2mortal(sv));
3428 if (pat[-1] == '*' || len > (strend - s) * 2)
3429 len = (strend - s) * 2;
3430 sv = NEWSV(35, len + 1);
3433 aptr = pat; /* borrow register */
3435 if (datumtype == 'h') {
3437 for (len = 0; len < aint; len++) {
3442 *pat++ = PL_hexdigit[bits & 15];
3447 for (len = 0; len < aint; len++) {
3452 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3456 pat = aptr; /* unborrow register */
3457 XPUSHs(sv_2mortal(sv));
3460 if (len > strend - s)
3465 if (aint >= 128) /* fake up signed chars */
3475 if (aint >= 128) /* fake up signed chars */
3478 sv_setiv(sv, (IV)aint);
3479 PUSHs(sv_2mortal(sv));
3484 if (len > strend - s)
3499 sv_setiv(sv, (IV)auint);
3500 PUSHs(sv_2mortal(sv));
3505 if (len > strend - s)
3508 while (len-- > 0 && s < strend) {
3509 auint = utf8_to_uv((U8*)s, &along);
3512 cdouble += (double)auint;
3520 while (len-- > 0 && s < strend) {
3521 auint = utf8_to_uv((U8*)s, &along);
3524 sv_setuv(sv, (UV)auint);
3525 PUSHs(sv_2mortal(sv));
3530 #if SHORTSIZE == SIZE16
3531 along = (strend - s) / SIZE16;
3533 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3538 #if SHORTSIZE != SIZE16
3541 COPYNN(s, &ashort, sizeof(short));
3560 #if SHORTSIZE != SIZE16
3563 COPYNN(s, &ashort, sizeof(short));
3566 sv_setiv(sv, (IV)ashort);
3567 PUSHs(sv_2mortal(sv));
3577 sv_setiv(sv, (IV)ashort);
3578 PUSHs(sv_2mortal(sv));
3586 #if SHORTSIZE == SIZE16
3587 along = (strend - s) / SIZE16;
3589 unatint = natint && datumtype == 'S';
3590 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3595 #if SHORTSIZE != SIZE16
3598 COPYNN(s, &aushort, sizeof(unsigned short));
3599 s += sizeof(unsigned short);
3607 COPY16(s, &aushort);
3610 if (datumtype == 'n')
3611 aushort = PerlSock_ntohs(aushort);
3614 if (datumtype == 'v')
3615 aushort = vtohs(aushort);
3624 #if SHORTSIZE != SIZE16
3627 COPYNN(s, &aushort, sizeof(unsigned short));
3628 s += sizeof(unsigned short);
3630 sv_setiv(sv, (UV)aushort);
3631 PUSHs(sv_2mortal(sv));
3638 COPY16(s, &aushort);
3642 if (datumtype == 'n')
3643 aushort = PerlSock_ntohs(aushort);
3646 if (datumtype == 'v')
3647 aushort = vtohs(aushort);
3649 sv_setiv(sv, (UV)aushort);
3650 PUSHs(sv_2mortal(sv));
3656 along = (strend - s) / sizeof(int);
3661 Copy(s, &aint, 1, int);
3664 cdouble += (double)aint;
3673 Copy(s, &aint, 1, int);
3677 /* Without the dummy below unpack("i", pack("i",-1))
3678 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3679 * cc with optimization turned on */
3681 sv_setiv(sv, (IV)aint) :
3683 sv_setiv(sv, (IV)aint);
3684 PUSHs(sv_2mortal(sv));
3689 along = (strend - s) / sizeof(unsigned int);
3694 Copy(s, &auint, 1, unsigned int);
3695 s += sizeof(unsigned int);
3697 cdouble += (double)auint;
3706 Copy(s, &auint, 1, unsigned int);
3707 s += sizeof(unsigned int);
3710 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3711 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3712 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3713 * with optimization turned on.
3714 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3715 * does not have this problem even with -O4)
3718 sv_setuv(sv, (UV)auint) :
3720 sv_setuv(sv, (UV)auint);
3721 PUSHs(sv_2mortal(sv));
3726 #if LONGSIZE == SIZE32
3727 along = (strend - s) / SIZE32;
3729 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3734 #if LONGSIZE != SIZE32
3737 COPYNN(s, &along, sizeof(long));
3740 cdouble += (double)along;
3752 cdouble += (double)along;
3761 #if LONGSIZE != SIZE32
3764 COPYNN(s, &along, sizeof(long));
3767 sv_setiv(sv, (IV)along);
3768 PUSHs(sv_2mortal(sv));
3778 sv_setiv(sv, (IV)along);
3779 PUSHs(sv_2mortal(sv));
3787 #if LONGSIZE == SIZE32
3788 along = (strend - s) / SIZE32;
3790 unatint = natint && datumtype == 'L';
3791 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3796 #if LONGSIZE != SIZE32
3799 COPYNN(s, &aulong, sizeof(unsigned long));
3800 s += sizeof(unsigned long);
3802 cdouble += (double)aulong;
3814 if (datumtype == 'N')
3815 aulong = PerlSock_ntohl(aulong);
3818 if (datumtype == 'V')
3819 aulong = vtohl(aulong);
3822 cdouble += (double)aulong;
3831 #if LONGSIZE != SIZE32
3834 COPYNN(s, &aulong, sizeof(unsigned long));
3835 s += sizeof(unsigned long);
3837 sv_setuv(sv, (UV)aulong);
3838 PUSHs(sv_2mortal(sv));
3848 if (datumtype == 'N')
3849 aulong = PerlSock_ntohl(aulong);
3852 if (datumtype == 'V')
3853 aulong = vtohl(aulong);
3856 sv_setuv(sv, (UV)aulong);
3857 PUSHs(sv_2mortal(sv));
3863 along = (strend - s) / sizeof(char*);
3869 if (sizeof(char*) > strend - s)
3872 Copy(s, &aptr, 1, char*);
3878 PUSHs(sv_2mortal(sv));
3888 while ((len > 0) && (s < strend)) {
3889 auv = (auv << 7) | (*s & 0x7f);
3890 if (!(*s++ & 0x80)) {
3894 PUSHs(sv_2mortal(sv));
3898 else if (++bytes >= sizeof(UV)) { /* promote to string */
3902 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3903 while (s < strend) {
3904 sv = mul128(sv, *s & 0x7f);
3905 if (!(*s++ & 0x80)) {
3914 PUSHs(sv_2mortal(sv));
3919 if ((s >= strend) && bytes)
3920 croak("Unterminated compressed integer");
3925 if (sizeof(char*) > strend - s)
3928 Copy(s, &aptr, 1, char*);
3933 sv_setpvn(sv, aptr, len);
3934 PUSHs(sv_2mortal(sv));
3938 along = (strend - s) / sizeof(Quad_t);
3944 if (s + sizeof(Quad_t) > strend)
3947 Copy(s, &aquad, 1, Quad_t);
3948 s += sizeof(Quad_t);
3951 if (aquad >= IV_MIN && aquad <= IV_MAX)
3952 sv_setiv(sv, (IV)aquad);
3954 sv_setnv(sv, (double)aquad);
3955 PUSHs(sv_2mortal(sv));
3959 along = (strend - s) / sizeof(Quad_t);
3965 if (s + sizeof(Uquad_t) > strend)
3968 Copy(s, &auquad, 1, Uquad_t);
3969 s += sizeof(Uquad_t);
3972 if (auquad <= UV_MAX)
3973 sv_setuv(sv, (UV)auquad);
3975 sv_setnv(sv, (double)auquad);
3976 PUSHs(sv_2mortal(sv));
3980 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3983 along = (strend - s) / sizeof(float);
3988 Copy(s, &afloat, 1, float);
3997 Copy(s, &afloat, 1, float);
4000 sv_setnv(sv, (double)afloat);
4001 PUSHs(sv_2mortal(sv));
4007 along = (strend - s) / sizeof(double);
4012 Copy(s, &adouble, 1, double);
4013 s += sizeof(double);
4021 Copy(s, &adouble, 1, double);
4022 s += sizeof(double);
4024 sv_setnv(sv, (double)adouble);
4025 PUSHs(sv_2mortal(sv));
4031 * Initialise the decode mapping. By using a table driven
4032 * algorithm, the code will be character-set independent
4033 * (and just as fast as doing character arithmetic)
4035 if (PL_uudmap['M'] == 0) {
4038 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4039 PL_uudmap[PL_uuemap[i]] = i;
4041 * Because ' ' and '`' map to the same value,
4042 * we need to decode them both the same.
4047 along = (strend - s) * 3 / 4;
4048 sv = NEWSV(42, along);
4051 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4056 len = PL_uudmap[*s++] & 077;
4058 if (s < strend && ISUUCHAR(*s))
4059 a = PL_uudmap[*s++] & 077;
4062 if (s < strend && ISUUCHAR(*s))
4063 b = PL_uudmap[*s++] & 077;
4066 if (s < strend && ISUUCHAR(*s))
4067 c = PL_uudmap[*s++] & 077;
4070 if (s < strend && ISUUCHAR(*s))
4071 d = PL_uudmap[*s++] & 077;
4074 hunk[0] = (a << 2) | (b >> 4);
4075 hunk[1] = (b << 4) | (c >> 2);
4076 hunk[2] = (c << 6) | d;
4077 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4082 else if (s[1] == '\n') /* possible checksum byte */
4085 XPUSHs(sv_2mortal(sv));
4090 if (strchr("fFdD", datumtype) ||
4091 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4095 while (checksum >= 16) {
4099 while (checksum >= 4) {
4105 along = (1 << checksum) - 1;
4106 while (cdouble < 0.0)
4108 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4109 sv_setnv(sv, cdouble);
4112 if (checksum < 32) {
4113 aulong = (1 << checksum) - 1;
4116 sv_setuv(sv, (UV)culong);
4118 XPUSHs(sv_2mortal(sv));
4122 if (SP == oldsp && gimme == G_SCALAR)
4123 PUSHs(&PL_sv_undef);
4128 doencodes(register SV *sv, register char *s, register I32 len)
4132 *hunk = PL_uuemap[len];
4133 sv_catpvn(sv, hunk, 1);
4136 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4137 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4138 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4139 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4140 sv_catpvn(sv, hunk, 4);
4145 char r = (len > 1 ? s[1] : '\0');
4146 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4147 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4148 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4149 hunk[3] = PL_uuemap[0];
4150 sv_catpvn(sv, hunk, 4);
4152 sv_catpvn(sv, "\n", 1);
4156 is_an_int(char *s, STRLEN l)
4159 SV *result = newSVpv("", l);
4160 char *result_c = SvPV(result, n_a); /* convenience */
4161 char *out = result_c;
4171 SvREFCNT_dec(result);
4194 SvREFCNT_dec(result);
4200 SvCUR_set(result, out - result_c);
4205 div128(SV *pnum, bool *done)
4206 /* must be '\0' terminated */
4210 char *s = SvPV(pnum, len);
4219 i = m * 10 + (*t - '0');
4221 r = (i >> 7); /* r < 10 */
4228 SvCUR_set(pnum, (STRLEN) (t - s));
4235 djSP; dMARK; dORIGMARK; dTARGET;
4236 register SV *cat = TARG;
4239 register char *pat = SvPVx(*++MARK, fromlen);
4240 register char *patend = pat + fromlen;
4245 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4246 static char *space10 = " ";
4248 /* These must not be in registers: */
4263 #ifdef PERL_NATINT_PACK
4264 int natint; /* native integer */
4269 sv_setpvn(cat, "", 0);
4270 while (pat < patend) {
4271 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4272 datumtype = *pat++ & 0xFF;
4273 #ifdef PERL_NATINT_PACK
4276 if (isSPACE(datumtype))
4279 char *natstr = "sSiIlL";
4281 if (strchr(natstr, datumtype)) {
4282 #ifdef PERL_NATINT_PACK
4288 croak("'_' allowed only after types %s", natstr);
4291 len = strchr("@Xxu", datumtype) ? 0 : items;
4294 else if (isDIGIT(*pat)) {
4296 while (isDIGIT(*pat))
4297 len = (len * 10) + (*pat++ - '0');
4303 croak("Invalid type in pack: '%c'", (int)datumtype);
4304 case ',': /* grandfather in commas but with a warning */
4305 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4306 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4309 DIE("%% may only be used in unpack");
4320 if (SvCUR(cat) < len)
4321 DIE("X outside of string");
4328 sv_catpvn(cat, null10, 10);
4331 sv_catpvn(cat, null10, len);
4337 aptr = SvPV(fromstr, fromlen);
4341 sv_catpvn(cat, aptr, len);
4343 sv_catpvn(cat, aptr, fromlen);
4345 if (datumtype == 'A') {
4347 sv_catpvn(cat, space10, 10);
4350 sv_catpvn(cat, space10, len);
4354 sv_catpvn(cat, null10, 10);
4357 sv_catpvn(cat, null10, len);
4364 char *savepat = pat;
4369 aptr = SvPV(fromstr, fromlen);
4374 SvCUR(cat) += (len+7)/8;
4375 SvGROW(cat, SvCUR(cat) + 1);
4376 aptr = SvPVX(cat) + aint;
4381 if (datumtype == 'B') {
4382 for (len = 0; len++ < aint;) {
4383 items |= *pat++ & 1;
4387 *aptr++ = items & 0xff;
4393 for (len = 0; len++ < aint;) {
4399 *aptr++ = items & 0xff;
4405 if (datumtype == 'B')
4406 items <<= 7 - (aint & 7);
4408 items >>= 7 - (aint & 7);
4409 *aptr++ = items & 0xff;
4411 pat = SvPVX(cat) + SvCUR(cat);
4422 char *savepat = pat;
4427 aptr = SvPV(fromstr, fromlen);
4432 SvCUR(cat) += (len+1)/2;
4433 SvGROW(cat, SvCUR(cat) + 1);
4434 aptr = SvPVX(cat) + aint;
4439 if (datumtype == 'H') {
4440 for (len = 0; len++ < aint;) {
4442 items |= ((*pat++ & 15) + 9) & 15;
4444 items |= *pat++ & 15;
4448 *aptr++ = items & 0xff;
4454 for (len = 0; len++ < aint;) {
4456 items |= (((*pat++ & 15) + 9) & 15) << 4;
4458 items |= (*pat++ & 15) << 4;
4462 *aptr++ = items & 0xff;
4468 *aptr++ = items & 0xff;
4469 pat = SvPVX(cat) + SvCUR(cat);
4481 aint = SvIV(fromstr);
4483 sv_catpvn(cat, &achar, sizeof(char));
4489 auint = SvUV(fromstr);
4490 SvGROW(cat, SvCUR(cat) + 10);
4491 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4496 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4501 afloat = (float)SvNV(fromstr);
4502 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4509 adouble = (double)SvNV(fromstr);
4510 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4516 ashort = (I16)SvIV(fromstr);
4518 ashort = PerlSock_htons(ashort);
4520 CAT16(cat, &ashort);
4526 ashort = (I16)SvIV(fromstr);
4528 ashort = htovs(ashort);
4530 CAT16(cat, &ashort);
4534 #if SHORTSIZE != SIZE16
4536 unsigned short aushort;
4540 aushort = SvUV(fromstr);
4541 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4551 aushort = (U16)SvUV(fromstr);
4552 CAT16(cat, &aushort);
4562 ashort = SvIV(fromstr);
4563 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4571 ashort = (I16)SvIV(fromstr);
4572 CAT16(cat, &ashort);
4579 auint = SvUV(fromstr);
4580 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4586 adouble = floor(SvNV(fromstr));
4589 croak("Cannot compress negative numbers");
4595 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4596 adouble <= UV_MAX_cxux
4603 char buf[1 + sizeof(UV)];
4604 char *in = buf + sizeof(buf);
4605 UV auv = U_V(adouble);;
4608 *--in = (auv & 0x7f) | 0x80;
4611 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4612 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4614 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4615 char *from, *result, *in;
4620 /* Copy string and check for compliance */
4621 from = SvPV(fromstr, len);
4622 if ((norm = is_an_int(from, len)) == NULL)
4623 croak("can compress only unsigned integer");
4625 New('w', result, len, char);
4629 *--in = div128(norm, &done) | 0x80;
4630 result[len - 1] &= 0x7F; /* clear continue bit */
4631 sv_catpvn(cat, in, (result + len) - in);
4633 SvREFCNT_dec(norm); /* free norm */
4635 else if (SvNOKp(fromstr)) {
4636 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4637 char *in = buf + sizeof(buf);
4640 double next = floor(adouble / 128);
4641 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4642 if (--in < buf) /* this cannot happen ;-) */
4643 croak ("Cannot compress integer");
4645 } while (adouble > 0);
4646 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4647 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4650 croak("Cannot compress non integer");
4656 aint = SvIV(fromstr);
4657 sv_catpvn(cat, (char*)&aint, sizeof(int));
4663 aulong = SvUV(fromstr);
4665 aulong = PerlSock_htonl(aulong);
4667 CAT32(cat, &aulong);
4673 aulong = SvUV(fromstr);
4675 aulong = htovl(aulong);
4677 CAT32(cat, &aulong);
4681 #if LONGSIZE != SIZE32
4685 aulong = SvUV(fromstr);
4686 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4694 aulong = SvUV(fromstr);
4695 CAT32(cat, &aulong);
4700 #if LONGSIZE != SIZE32
4704 along = SvIV(fromstr);
4705 sv_catpvn(cat, (char *)&along, sizeof(long));
4713 along = SvIV(fromstr);
4722 auquad = (Uquad_t)SvIV(fromstr);
4723 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4729 aquad = (Quad_t)SvIV(fromstr);
4730 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4733 #endif /* HAS_QUAD */
4735 len = 1; /* assume SV is correct length */
4740 if (fromstr == &PL_sv_undef)
4744 /* XXX better yet, could spirit away the string to
4745 * a safe spot and hang on to it until the result
4746 * of pack() (and all copies of the result) are
4749 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4751 "Attempt to pack pointer to temporary value");
4752 if (SvPOK(fromstr) || SvNIOK(fromstr))
4753 aptr = SvPV(fromstr,n_a);
4755 aptr = SvPV_force(fromstr,n_a);
4757 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4762 aptr = SvPV(fromstr, fromlen);
4763 SvGROW(cat, fromlen * 4 / 3);
4768 while (fromlen > 0) {
4775 doencodes(cat, aptr, todo);
4794 register I32 limit = POPi; /* note, negative is forever */
4797 register char *s = SvPV(sv, len);
4798 char *strend = s + len;
4800 register REGEXP *rx;
4804 I32 maxiters = (strend - s) + 10;
4807 I32 origlimit = limit;
4810 AV *oldstack = PL_curstack;
4811 I32 gimme = GIMME_V;
4812 I32 oldsave = PL_savestack_ix;
4813 I32 make_mortal = 1;
4814 MAGIC *mg = (MAGIC *) NULL;
4817 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4822 DIE("panic: do_split");
4823 rx = pm->op_pmregexp;
4825 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4826 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4828 if (pm->op_pmreplroot)
4829 ary = GvAVn((GV*)pm->op_pmreplroot);
4830 else if (gimme != G_ARRAY)
4832 ary = (AV*)PL_curpad[0];
4834 ary = GvAVn(PL_defgv);
4835 #endif /* USE_THREADS */
4838 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4844 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4846 XPUSHs(SvTIED_obj((SV*)ary, mg));
4851 for (i = AvFILLp(ary); i >= 0; i--)
4852 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4854 /* temporarily switch stacks */
4855 SWITCHSTACK(PL_curstack, ary);
4859 base = SP - PL_stack_base;
4861 if (pm->op_pmflags & PMf_SKIPWHITE) {
4862 if (pm->op_pmflags & PMf_LOCALE) {
4863 while (isSPACE_LC(*s))
4871 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4872 SAVEINT(PL_multiline);
4873 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4877 limit = maxiters + 2;
4878 if (pm->op_pmflags & PMf_WHITE) {
4881 while (m < strend &&
4882 !((pm->op_pmflags & PMf_LOCALE)
4883 ? isSPACE_LC(*m) : isSPACE(*m)))
4888 dstr = NEWSV(30, m-s);
4889 sv_setpvn(dstr, s, m-s);
4895 while (s < strend &&
4896 ((pm->op_pmflags & PMf_LOCALE)
4897 ? isSPACE_LC(*s) : isSPACE(*s)))
4901 else if (strEQ("^", rx->precomp)) {
4904 for (m = s; m < strend && *m != '\n'; m++) ;
4908 dstr = NEWSV(30, m-s);
4909 sv_setpvn(dstr, s, m-s);
4916 else if (rx->check_substr && !rx->nparens
4917 && (rx->reganch & ROPT_CHECK_ALL)
4918 && !(rx->reganch & ROPT_ANCH)) {
4919 i = SvCUR(rx->check_substr);
4920 if (i == 1 && !SvTAIL(rx->check_substr)) {
4921 i = *SvPVX(rx->check_substr);
4924 for (m = s; m < strend && *m != i; m++) ;
4927 dstr = NEWSV(30, m-s);
4928 sv_setpvn(dstr, s, m-s);
4937 while (s < strend && --limit &&
4938 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4939 rx->check_substr, 0)) )
4942 dstr = NEWSV(31, m-s);
4943 sv_setpvn(dstr, s, m-s);
4952 maxiters += (strend - s) * rx->nparens;
4953 while (s < strend && --limit &&
4954 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4956 TAINT_IF(RX_MATCH_TAINTED(rx));
4958 && rx->subbase != orig) {
4963 strend = s + (strend - m);
4966 dstr = NEWSV(32, m-s);
4967 sv_setpvn(dstr, s, m-s);
4972 for (i = 1; i <= rx->nparens; i++) {
4976 dstr = NEWSV(33, m-s);
4977 sv_setpvn(dstr, s, m-s);
4980 dstr = NEWSV(33, 0);
4990 LEAVE_SCOPE(oldsave);
4991 iters = (SP - PL_stack_base) - base;
4992 if (iters > maxiters)
4995 /* keep field after final delim? */
4996 if (s < strend || (iters && origlimit)) {
4997 dstr = NEWSV(34, strend-s);
4998 sv_setpvn(dstr, s, strend-s);
5004 else if (!origlimit) {
5005 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5011 SWITCHSTACK(ary, oldstack);
5012 if (SvSMAGICAL(ary)) {
5017 if (gimme == G_ARRAY) {
5019 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5027 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5030 if (gimme == G_ARRAY) {
5031 /* EXTEND should not be needed - we just popped them */
5033 for (i=0; i < iters; i++) {
5034 SV **svp = av_fetch(ary, i, FALSE);
5035 PUSHs((svp) ? *svp : &PL_sv_undef);
5042 if (gimme == G_ARRAY)
5045 if (iters || !pm->op_pmreplroot) {
5055 unlock_condpair(void *svv)
5058 MAGIC *mg = mg_find((SV*)svv, 'm');
5061 croak("panic: unlock_condpair unlocking non-mutex");
5062 MUTEX_LOCK(MgMUTEXP(mg));
5063 if (MgOWNER(mg) != thr)
5064 croak("panic: unlock_condpair unlocking mutex that we don't own");
5066 COND_SIGNAL(MgOWNERCONDP(mg));
5067 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5068 (unsigned long)thr, (unsigned long)svv);)
5069 MUTEX_UNLOCK(MgMUTEXP(mg));
5071 #endif /* USE_THREADS */
5084 mg = condpair_magic(sv);
5085 MUTEX_LOCK(MgMUTEXP(mg));
5086 if (MgOWNER(mg) == thr)
5087 MUTEX_UNLOCK(MgMUTEXP(mg));
5090 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5092 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5093 (unsigned long)thr, (unsigned long)sv);)
5094 MUTEX_UNLOCK(MgMUTEXP(mg));
5095 save_destructor(unlock_condpair, sv);
5097 #endif /* USE_THREADS */
5098 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5099 || SvTYPE(retsv) == SVt_PVCV) {
5100 retsv = refto(retsv);
5111 if (PL_op->op_private & OPpLVAL_INTRO)
5112 PUSHs(*save_threadsv(PL_op->op_targ));
5114 PUSHs(THREADSV(PL_op->op_targ));
5117 DIE("tried to access per-thread data in non-threaded perl");
5118 #endif /* USE_THREADS */