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));
3552 #if SHORTSIZE > SIZE16
3564 #if SHORTSIZE != SIZE16
3567 COPYNN(s, &ashort, sizeof(short));
3570 sv_setiv(sv, (IV)ashort);
3571 PUSHs(sv_2mortal(sv));
3579 #if SHORTSIZE > SIZE16
3585 sv_setiv(sv, (IV)ashort);
3586 PUSHs(sv_2mortal(sv));
3594 #if SHORTSIZE == SIZE16
3595 along = (strend - s) / SIZE16;
3597 unatint = natint && datumtype == 'S';
3598 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3603 #if SHORTSIZE != SIZE16
3606 COPYNN(s, &aushort, sizeof(unsigned short));
3607 s += sizeof(unsigned short);
3615 COPY16(s, &aushort);
3618 if (datumtype == 'n')
3619 aushort = PerlSock_ntohs(aushort);
3622 if (datumtype == 'v')
3623 aushort = vtohs(aushort);
3632 #if SHORTSIZE != SIZE16
3635 COPYNN(s, &aushort, sizeof(unsigned short));
3636 s += sizeof(unsigned short);
3638 sv_setiv(sv, (UV)aushort);
3639 PUSHs(sv_2mortal(sv));
3646 COPY16(s, &aushort);
3650 if (datumtype == 'n')
3651 aushort = PerlSock_ntohs(aushort);
3654 if (datumtype == 'v')
3655 aushort = vtohs(aushort);
3657 sv_setiv(sv, (UV)aushort);
3658 PUSHs(sv_2mortal(sv));
3664 along = (strend - s) / sizeof(int);
3669 Copy(s, &aint, 1, int);
3672 cdouble += (double)aint;
3681 Copy(s, &aint, 1, int);
3685 /* Without the dummy below unpack("i", pack("i",-1))
3686 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3687 * cc with optimization turned on */
3689 sv_setiv(sv, (IV)aint) :
3691 sv_setiv(sv, (IV)aint);
3692 PUSHs(sv_2mortal(sv));
3697 along = (strend - s) / sizeof(unsigned int);
3702 Copy(s, &auint, 1, unsigned int);
3703 s += sizeof(unsigned int);
3705 cdouble += (double)auint;
3714 Copy(s, &auint, 1, unsigned int);
3715 s += sizeof(unsigned int);
3718 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3719 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
3720 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
3721 * with optimization turned on.
3722 * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
3723 * does not have this problem even with -O4)
3726 sv_setuv(sv, (UV)auint) :
3728 sv_setuv(sv, (UV)auint);
3729 PUSHs(sv_2mortal(sv));
3734 #if LONGSIZE == SIZE32
3735 along = (strend - s) / SIZE32;
3737 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3742 #if LONGSIZE != SIZE32
3745 COPYNN(s, &along, sizeof(long));
3748 cdouble += (double)along;
3758 #if LONGSIZE > SIZE32
3759 if (along > 2147483647)
3760 along -= 4294967296;
3764 cdouble += (double)along;
3773 #if LONGSIZE != SIZE32
3776 COPYNN(s, &along, sizeof(long));
3779 sv_setiv(sv, (IV)along);
3780 PUSHs(sv_2mortal(sv));
3788 #if LONGSIZE > SIZE32
3789 if (along > 2147483647)
3790 along -= 4294967296;
3794 sv_setiv(sv, (IV)along);
3795 PUSHs(sv_2mortal(sv));
3803 #if LONGSIZE == SIZE32
3804 along = (strend - s) / SIZE32;
3806 unatint = natint && datumtype == 'L';
3807 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3812 #if LONGSIZE != SIZE32
3815 COPYNN(s, &aulong, sizeof(unsigned long));
3816 s += sizeof(unsigned long);
3818 cdouble += (double)aulong;
3830 if (datumtype == 'N')
3831 aulong = PerlSock_ntohl(aulong);
3834 if (datumtype == 'V')
3835 aulong = vtohl(aulong);
3838 cdouble += (double)aulong;
3847 #if LONGSIZE != SIZE32
3850 COPYNN(s, &aulong, sizeof(unsigned long));
3851 s += sizeof(unsigned long);
3853 sv_setuv(sv, (UV)aulong);
3854 PUSHs(sv_2mortal(sv));
3864 if (datumtype == 'N')
3865 aulong = PerlSock_ntohl(aulong);
3868 if (datumtype == 'V')
3869 aulong = vtohl(aulong);
3872 sv_setuv(sv, (UV)aulong);
3873 PUSHs(sv_2mortal(sv));
3879 along = (strend - s) / sizeof(char*);
3885 if (sizeof(char*) > strend - s)
3888 Copy(s, &aptr, 1, char*);
3894 PUSHs(sv_2mortal(sv));
3904 while ((len > 0) && (s < strend)) {
3905 auv = (auv << 7) | (*s & 0x7f);
3906 if (!(*s++ & 0x80)) {
3910 PUSHs(sv_2mortal(sv));
3914 else if (++bytes >= sizeof(UV)) { /* promote to string */
3918 sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3919 while (s < strend) {
3920 sv = mul128(sv, *s & 0x7f);
3921 if (!(*s++ & 0x80)) {
3930 PUSHs(sv_2mortal(sv));
3935 if ((s >= strend) && bytes)
3936 croak("Unterminated compressed integer");
3941 if (sizeof(char*) > strend - s)
3944 Copy(s, &aptr, 1, char*);
3949 sv_setpvn(sv, aptr, len);
3950 PUSHs(sv_2mortal(sv));
3954 along = (strend - s) / sizeof(Quad_t);
3960 if (s + sizeof(Quad_t) > strend)
3963 Copy(s, &aquad, 1, Quad_t);
3964 s += sizeof(Quad_t);
3967 if (aquad >= IV_MIN && aquad <= IV_MAX)
3968 sv_setiv(sv, (IV)aquad);
3970 sv_setnv(sv, (double)aquad);
3971 PUSHs(sv_2mortal(sv));
3975 along = (strend - s) / sizeof(Quad_t);
3981 if (s + sizeof(Uquad_t) > strend)
3984 Copy(s, &auquad, 1, Uquad_t);
3985 s += sizeof(Uquad_t);
3988 if (auquad <= UV_MAX)
3989 sv_setuv(sv, (UV)auquad);
3991 sv_setnv(sv, (double)auquad);
3992 PUSHs(sv_2mortal(sv));
3996 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3999 along = (strend - s) / sizeof(float);
4004 Copy(s, &afloat, 1, float);
4013 Copy(s, &afloat, 1, float);
4016 sv_setnv(sv, (double)afloat);
4017 PUSHs(sv_2mortal(sv));
4023 along = (strend - s) / sizeof(double);
4028 Copy(s, &adouble, 1, double);
4029 s += sizeof(double);
4037 Copy(s, &adouble, 1, double);
4038 s += sizeof(double);
4040 sv_setnv(sv, (double)adouble);
4041 PUSHs(sv_2mortal(sv));
4047 * Initialise the decode mapping. By using a table driven
4048 * algorithm, the code will be character-set independent
4049 * (and just as fast as doing character arithmetic)
4051 if (PL_uudmap['M'] == 0) {
4054 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4055 PL_uudmap[PL_uuemap[i]] = i;
4057 * Because ' ' and '`' map to the same value,
4058 * we need to decode them both the same.
4063 along = (strend - s) * 3 / 4;
4064 sv = NEWSV(42, along);
4067 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4072 len = PL_uudmap[*s++] & 077;
4074 if (s < strend && ISUUCHAR(*s))
4075 a = PL_uudmap[*s++] & 077;
4078 if (s < strend && ISUUCHAR(*s))
4079 b = PL_uudmap[*s++] & 077;
4082 if (s < strend && ISUUCHAR(*s))
4083 c = PL_uudmap[*s++] & 077;
4086 if (s < strend && ISUUCHAR(*s))
4087 d = PL_uudmap[*s++] & 077;
4090 hunk[0] = (a << 2) | (b >> 4);
4091 hunk[1] = (b << 4) | (c >> 2);
4092 hunk[2] = (c << 6) | d;
4093 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4098 else if (s[1] == '\n') /* possible checksum byte */
4101 XPUSHs(sv_2mortal(sv));
4106 if (strchr("fFdD", datumtype) ||
4107 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4111 while (checksum >= 16) {
4115 while (checksum >= 4) {
4121 along = (1 << checksum) - 1;
4122 while (cdouble < 0.0)
4124 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4125 sv_setnv(sv, cdouble);
4128 if (checksum < 32) {
4129 aulong = (1 << checksum) - 1;
4132 sv_setuv(sv, (UV)culong);
4134 XPUSHs(sv_2mortal(sv));
4138 if (SP == oldsp && gimme == G_SCALAR)
4139 PUSHs(&PL_sv_undef);
4144 doencodes(register SV *sv, register char *s, register I32 len)
4148 *hunk = PL_uuemap[len];
4149 sv_catpvn(sv, hunk, 1);
4152 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4153 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4154 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4155 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4156 sv_catpvn(sv, hunk, 4);
4161 char r = (len > 1 ? s[1] : '\0');
4162 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4163 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4164 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4165 hunk[3] = PL_uuemap[0];
4166 sv_catpvn(sv, hunk, 4);
4168 sv_catpvn(sv, "\n", 1);
4172 is_an_int(char *s, STRLEN l)
4175 SV *result = newSVpv("", l);
4176 char *result_c = SvPV(result, n_a); /* convenience */
4177 char *out = result_c;
4187 SvREFCNT_dec(result);
4210 SvREFCNT_dec(result);
4216 SvCUR_set(result, out - result_c);
4221 div128(SV *pnum, bool *done)
4222 /* must be '\0' terminated */
4226 char *s = SvPV(pnum, len);
4235 i = m * 10 + (*t - '0');
4237 r = (i >> 7); /* r < 10 */
4244 SvCUR_set(pnum, (STRLEN) (t - s));
4251 djSP; dMARK; dORIGMARK; dTARGET;
4252 register SV *cat = TARG;
4255 register char *pat = SvPVx(*++MARK, fromlen);
4256 register char *patend = pat + fromlen;
4261 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4262 static char *space10 = " ";
4264 /* These must not be in registers: */
4279 #ifdef PERL_NATINT_PACK
4280 int natint; /* native integer */
4285 sv_setpvn(cat, "", 0);
4286 while (pat < patend) {
4287 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4288 datumtype = *pat++ & 0xFF;
4289 #ifdef PERL_NATINT_PACK
4292 if (isSPACE(datumtype))
4295 char *natstr = "sSiIlL";
4297 if (strchr(natstr, datumtype)) {
4298 #ifdef PERL_NATINT_PACK
4304 croak("'_' allowed only after types %s", natstr);
4307 len = strchr("@Xxu", datumtype) ? 0 : items;
4310 else if (isDIGIT(*pat)) {
4312 while (isDIGIT(*pat))
4313 len = (len * 10) + (*pat++ - '0');
4319 croak("Invalid type in pack: '%c'", (int)datumtype);
4320 case ',': /* grandfather in commas but with a warning */
4321 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4322 warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4325 DIE("%% may only be used in unpack");
4336 if (SvCUR(cat) < len)
4337 DIE("X outside of string");
4344 sv_catpvn(cat, null10, 10);
4347 sv_catpvn(cat, null10, len);
4353 aptr = SvPV(fromstr, fromlen);
4357 sv_catpvn(cat, aptr, len);
4359 sv_catpvn(cat, aptr, fromlen);
4361 if (datumtype == 'A') {
4363 sv_catpvn(cat, space10, 10);
4366 sv_catpvn(cat, space10, len);
4370 sv_catpvn(cat, null10, 10);
4373 sv_catpvn(cat, null10, len);
4380 char *savepat = pat;
4385 aptr = SvPV(fromstr, fromlen);
4390 SvCUR(cat) += (len+7)/8;
4391 SvGROW(cat, SvCUR(cat) + 1);
4392 aptr = SvPVX(cat) + aint;
4397 if (datumtype == 'B') {
4398 for (len = 0; len++ < aint;) {
4399 items |= *pat++ & 1;
4403 *aptr++ = items & 0xff;
4409 for (len = 0; len++ < aint;) {
4415 *aptr++ = items & 0xff;
4421 if (datumtype == 'B')
4422 items <<= 7 - (aint & 7);
4424 items >>= 7 - (aint & 7);
4425 *aptr++ = items & 0xff;
4427 pat = SvPVX(cat) + SvCUR(cat);
4438 char *savepat = pat;
4443 aptr = SvPV(fromstr, fromlen);
4448 SvCUR(cat) += (len+1)/2;
4449 SvGROW(cat, SvCUR(cat) + 1);
4450 aptr = SvPVX(cat) + aint;
4455 if (datumtype == 'H') {
4456 for (len = 0; len++ < aint;) {
4458 items |= ((*pat++ & 15) + 9) & 15;
4460 items |= *pat++ & 15;
4464 *aptr++ = items & 0xff;
4470 for (len = 0; len++ < aint;) {
4472 items |= (((*pat++ & 15) + 9) & 15) << 4;
4474 items |= (*pat++ & 15) << 4;
4478 *aptr++ = items & 0xff;
4484 *aptr++ = items & 0xff;
4485 pat = SvPVX(cat) + SvCUR(cat);
4497 aint = SvIV(fromstr);
4499 sv_catpvn(cat, &achar, sizeof(char));
4505 auint = SvUV(fromstr);
4506 SvGROW(cat, SvCUR(cat) + 10);
4507 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4512 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4517 afloat = (float)SvNV(fromstr);
4518 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4525 adouble = (double)SvNV(fromstr);
4526 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4532 ashort = (I16)SvIV(fromstr);
4534 ashort = PerlSock_htons(ashort);
4536 CAT16(cat, &ashort);
4542 ashort = (I16)SvIV(fromstr);
4544 ashort = htovs(ashort);
4546 CAT16(cat, &ashort);
4550 #if SHORTSIZE != SIZE16
4552 unsigned short aushort;
4556 aushort = SvUV(fromstr);
4557 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4567 aushort = (U16)SvUV(fromstr);
4568 CAT16(cat, &aushort);
4574 #if SHORTSIZE != SIZE16
4578 ashort = SvIV(fromstr);
4579 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4587 ashort = (I16)SvIV(fromstr);
4588 CAT16(cat, &ashort);
4595 auint = SvUV(fromstr);
4596 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4602 adouble = floor(SvNV(fromstr));
4605 croak("Cannot compress negative numbers");
4611 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4612 adouble <= UV_MAX_cxux
4619 char buf[1 + sizeof(UV)];
4620 char *in = buf + sizeof(buf);
4621 UV auv = U_V(adouble);;
4624 *--in = (auv & 0x7f) | 0x80;
4627 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4628 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4630 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4631 char *from, *result, *in;
4636 /* Copy string and check for compliance */
4637 from = SvPV(fromstr, len);
4638 if ((norm = is_an_int(from, len)) == NULL)
4639 croak("can compress only unsigned integer");
4641 New('w', result, len, char);
4645 *--in = div128(norm, &done) | 0x80;
4646 result[len - 1] &= 0x7F; /* clear continue bit */
4647 sv_catpvn(cat, in, (result + len) - in);
4649 SvREFCNT_dec(norm); /* free norm */
4651 else if (SvNOKp(fromstr)) {
4652 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4653 char *in = buf + sizeof(buf);
4656 double next = floor(adouble / 128);
4657 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4658 if (--in < buf) /* this cannot happen ;-) */
4659 croak ("Cannot compress integer");
4661 } while (adouble > 0);
4662 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4663 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4666 croak("Cannot compress non integer");
4672 aint = SvIV(fromstr);
4673 sv_catpvn(cat, (char*)&aint, sizeof(int));
4679 aulong = SvUV(fromstr);
4681 aulong = PerlSock_htonl(aulong);
4683 CAT32(cat, &aulong);
4689 aulong = SvUV(fromstr);
4691 aulong = htovl(aulong);
4693 CAT32(cat, &aulong);
4697 #if LONGSIZE != SIZE32
4701 aulong = SvUV(fromstr);
4702 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4710 aulong = SvUV(fromstr);
4711 CAT32(cat, &aulong);
4716 #if LONGSIZE != SIZE32
4720 along = SvIV(fromstr);
4721 sv_catpvn(cat, (char *)&along, sizeof(long));
4729 along = SvIV(fromstr);
4738 auquad = (Uquad_t)SvIV(fromstr);
4739 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4745 aquad = (Quad_t)SvIV(fromstr);
4746 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4749 #endif /* HAS_QUAD */
4751 len = 1; /* assume SV is correct length */
4756 if (fromstr == &PL_sv_undef)
4760 /* XXX better yet, could spirit away the string to
4761 * a safe spot and hang on to it until the result
4762 * of pack() (and all copies of the result) are
4765 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4767 "Attempt to pack pointer to temporary value");
4768 if (SvPOK(fromstr) || SvNIOK(fromstr))
4769 aptr = SvPV(fromstr,n_a);
4771 aptr = SvPV_force(fromstr,n_a);
4773 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4778 aptr = SvPV(fromstr, fromlen);
4779 SvGROW(cat, fromlen * 4 / 3);
4784 while (fromlen > 0) {
4791 doencodes(cat, aptr, todo);
4810 register I32 limit = POPi; /* note, negative is forever */
4813 register char *s = SvPV(sv, len);
4814 char *strend = s + len;
4816 register REGEXP *rx;
4820 I32 maxiters = (strend - s) + 10;
4823 I32 origlimit = limit;
4826 AV *oldstack = PL_curstack;
4827 I32 gimme = GIMME_V;
4828 I32 oldsave = PL_savestack_ix;
4829 I32 make_mortal = 1;
4830 MAGIC *mg = (MAGIC *) NULL;
4833 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4838 DIE("panic: do_split");
4839 rx = pm->op_pmregexp;
4841 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4842 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4844 if (pm->op_pmreplroot)
4845 ary = GvAVn((GV*)pm->op_pmreplroot);
4846 else if (gimme != G_ARRAY)
4848 ary = (AV*)PL_curpad[0];
4850 ary = GvAVn(PL_defgv);
4851 #endif /* USE_THREADS */
4854 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4860 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4862 XPUSHs(SvTIED_obj((SV*)ary, mg));
4867 for (i = AvFILLp(ary); i >= 0; i--)
4868 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4870 /* temporarily switch stacks */
4871 SWITCHSTACK(PL_curstack, ary);
4875 base = SP - PL_stack_base;
4877 if (pm->op_pmflags & PMf_SKIPWHITE) {
4878 if (pm->op_pmflags & PMf_LOCALE) {
4879 while (isSPACE_LC(*s))
4887 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4888 SAVEINT(PL_multiline);
4889 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4893 limit = maxiters + 2;
4894 if (pm->op_pmflags & PMf_WHITE) {
4897 while (m < strend &&
4898 !((pm->op_pmflags & PMf_LOCALE)
4899 ? isSPACE_LC(*m) : isSPACE(*m)))
4904 dstr = NEWSV(30, m-s);
4905 sv_setpvn(dstr, s, m-s);
4911 while (s < strend &&
4912 ((pm->op_pmflags & PMf_LOCALE)
4913 ? isSPACE_LC(*s) : isSPACE(*s)))
4917 else if (strEQ("^", rx->precomp)) {
4920 for (m = s; m < strend && *m != '\n'; m++) ;
4924 dstr = NEWSV(30, m-s);
4925 sv_setpvn(dstr, s, m-s);
4932 else if (rx->check_substr && !rx->nparens
4933 && (rx->reganch & ROPT_CHECK_ALL)
4934 && !(rx->reganch & ROPT_ANCH)) {
4935 i = SvCUR(rx->check_substr);
4936 if (i == 1 && !SvTAIL(rx->check_substr)) {
4937 i = *SvPVX(rx->check_substr);
4940 for (m = s; m < strend && *m != i; m++) ;
4943 dstr = NEWSV(30, m-s);
4944 sv_setpvn(dstr, s, m-s);
4953 while (s < strend && --limit &&
4954 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4955 rx->check_substr, 0)) )
4958 dstr = NEWSV(31, m-s);
4959 sv_setpvn(dstr, s, m-s);
4968 maxiters += (strend - s) * rx->nparens;
4969 while (s < strend && --limit &&
4970 CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
4972 TAINT_IF(RX_MATCH_TAINTED(rx));
4974 && rx->subbase != orig) {
4979 strend = s + (strend - m);
4982 dstr = NEWSV(32, m-s);
4983 sv_setpvn(dstr, s, m-s);
4988 for (i = 1; i <= rx->nparens; i++) {
4992 dstr = NEWSV(33, m-s);
4993 sv_setpvn(dstr, s, m-s);
4996 dstr = NEWSV(33, 0);
5006 LEAVE_SCOPE(oldsave);
5007 iters = (SP - PL_stack_base) - base;
5008 if (iters > maxiters)
5011 /* keep field after final delim? */
5012 if (s < strend || (iters && origlimit)) {
5013 dstr = NEWSV(34, strend-s);
5014 sv_setpvn(dstr, s, strend-s);
5020 else if (!origlimit) {
5021 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5027 SWITCHSTACK(ary, oldstack);
5028 if (SvSMAGICAL(ary)) {
5033 if (gimme == G_ARRAY) {
5035 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5043 perl_call_method("PUSH",G_SCALAR|G_DISCARD);
5046 if (gimme == G_ARRAY) {
5047 /* EXTEND should not be needed - we just popped them */
5049 for (i=0; i < iters; i++) {
5050 SV **svp = av_fetch(ary, i, FALSE);
5051 PUSHs((svp) ? *svp : &PL_sv_undef);
5058 if (gimme == G_ARRAY)
5061 if (iters || !pm->op_pmreplroot) {
5071 unlock_condpair(void *svv)
5074 MAGIC *mg = mg_find((SV*)svv, 'm');
5077 croak("panic: unlock_condpair unlocking non-mutex");
5078 MUTEX_LOCK(MgMUTEXP(mg));
5079 if (MgOWNER(mg) != thr)
5080 croak("panic: unlock_condpair unlocking mutex that we don't own");
5082 COND_SIGNAL(MgOWNERCONDP(mg));
5083 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5084 (unsigned long)thr, (unsigned long)svv);)
5085 MUTEX_UNLOCK(MgMUTEXP(mg));
5087 #endif /* USE_THREADS */
5100 mg = condpair_magic(sv);
5101 MUTEX_LOCK(MgMUTEXP(mg));
5102 if (MgOWNER(mg) == thr)
5103 MUTEX_UNLOCK(MgMUTEXP(mg));
5106 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5108 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5109 (unsigned long)thr, (unsigned long)sv);)
5110 MUTEX_UNLOCK(MgMUTEXP(mg));
5111 save_destructor(unlock_condpair, sv);
5113 #endif /* USE_THREADS */
5114 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5115 || SvTYPE(retsv) == SVt_PVCV) {
5116 retsv = refto(retsv);
5127 if (PL_op->op_private & OPpLVAL_INTRO)
5128 PUSHs(*save_threadsv(PL_op->op_targ));
5130 PUSHs(THREADSV(PL_op->op_targ));
5133 DIE("tried to access per-thread data in non-threaded perl");
5134 #endif /* USE_THREADS */