3 * Copyright (c) 1991-2000, 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
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if LONGSIZE > 4 && defined(_CRAY)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
89 /* XXX I can't imagine anyone who doesn't have this actually _needs_
90 it, since pid_t is an integral type.
93 #ifdef NEED_GETPID_PROTO
94 extern Pid_t getpid (void);
100 if (GIMME_V == G_SCALAR)
101 XPUSHs(&PL_sv_undef);
115 if (PL_op->op_private & OPpLVAL_INTRO)
116 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
118 if (PL_op->op_flags & OPf_REF) {
122 if (GIMME == G_ARRAY) {
123 I32 maxarg = AvFILL((AV*)TARG) + 1;
125 if (SvMAGICAL(TARG)) {
127 for (i=0; i < maxarg; i++) {
128 SV **svp = av_fetch((AV*)TARG, i, FALSE);
129 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
133 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
138 SV* sv = sv_newmortal();
139 I32 maxarg = AvFILL((AV*)TARG) + 1;
140 sv_setiv(sv, maxarg);
152 if (PL_op->op_private & OPpLVAL_INTRO)
153 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
154 if (PL_op->op_flags & OPf_REF)
157 if (gimme == G_ARRAY) {
160 else if (gimme == G_SCALAR) {
161 SV* sv = sv_newmortal();
162 if (HvFILL((HV*)TARG))
163 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
164 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
174 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
185 tryAMAGICunDEREF(to_gv);
188 if (SvTYPE(sv) == SVt_PVIO) {
189 GV *gv = (GV*) sv_newmortal();
190 gv_init(gv, 0, "", 0, 0);
191 GvIOp(gv) = (IO *)sv;
192 (void)SvREFCNT_inc(sv);
195 else if (SvTYPE(sv) != SVt_PVGV)
196 DIE(aTHX_ "Not a GLOB reference");
199 if (SvTYPE(sv) != SVt_PVGV) {
203 if (SvGMAGICAL(sv)) {
208 if (!SvOK(sv) && sv != &PL_sv_undef) {
209 /* If this is a 'my' scalar and flag is set then vivify
212 if (PL_op->op_private & OPpDEREF) {
215 if (cUNOP->op_targ) {
217 SV *namesv = PL_curpad[cUNOP->op_targ];
218 name = SvPV(namesv, len);
219 gv = (GV*)NEWSV(0,0);
220 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
223 name = CopSTASHPV(PL_curcop);
226 sv_upgrade(sv, SVt_RV);
232 if (PL_op->op_flags & OPf_REF ||
233 PL_op->op_private & HINT_STRICT_REFS)
234 DIE(aTHX_ PL_no_usym, "a symbol");
235 if (ckWARN(WARN_UNINITIALIZED))
240 if ((PL_op->op_flags & OPf_SPECIAL) &&
241 !(PL_op->op_flags & OPf_MOD))
243 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
245 && (!is_gv_magical(sym,len,0)
246 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
252 if (PL_op->op_private & HINT_STRICT_REFS)
253 DIE(aTHX_ PL_no_symref, sym, "a symbol");
254 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
258 if (PL_op->op_private & OPpLVAL_INTRO)
259 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
270 tryAMAGICunDEREF(to_sv);
273 switch (SvTYPE(sv)) {
277 DIE(aTHX_ "Not a SCALAR reference");
285 if (SvTYPE(gv) != SVt_PVGV) {
286 if (SvGMAGICAL(sv)) {
292 if (PL_op->op_flags & OPf_REF ||
293 PL_op->op_private & HINT_STRICT_REFS)
294 DIE(aTHX_ PL_no_usym, "a SCALAR");
295 if (ckWARN(WARN_UNINITIALIZED))
300 if ((PL_op->op_flags & OPf_SPECIAL) &&
301 !(PL_op->op_flags & OPf_MOD))
303 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
305 && (!is_gv_magical(sym,len,0)
306 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
312 if (PL_op->op_private & HINT_STRICT_REFS)
313 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
314 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
319 if (PL_op->op_flags & OPf_MOD) {
320 if (PL_op->op_private & OPpLVAL_INTRO)
321 sv = save_scalar((GV*)TOPs);
322 else if (PL_op->op_private & OPpDEREF)
323 vivify_ref(sv, PL_op->op_private & OPpDEREF);
333 SV *sv = AvARYLEN(av);
335 AvARYLEN(av) = sv = NEWSV(0,0);
336 sv_upgrade(sv, SVt_IV);
337 sv_magic(sv, (SV*)av, '#', Nullch, 0);
345 djSP; dTARGET; dPOPss;
347 if (PL_op->op_flags & OPf_MOD) {
348 if (SvTYPE(TARG) < SVt_PVLV) {
349 sv_upgrade(TARG, SVt_PVLV);
350 sv_magic(TARG, Nullsv, '.', Nullch, 0);
354 if (LvTARG(TARG) != sv) {
356 SvREFCNT_dec(LvTARG(TARG));
357 LvTARG(TARG) = SvREFCNT_inc(sv);
359 PUSHs(TARG); /* no SvSETMAGIC */
365 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
366 mg = mg_find(sv, 'g');
367 if (mg && mg->mg_len >= 0) {
371 PUSHi(i + PL_curcop->cop_arybase);
385 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
386 /* (But not in defined().) */
387 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
390 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
391 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
392 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
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 (n && str[0] == ';' && 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(newSVpvn(str, n - 1));
450 else if (code) /* Non-Overridable */
452 else { /* None such */
454 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
458 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
460 ret = sv_2mortal(newSVpvn(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);
503 S_refto(pTHX_ SV *sv)
507 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
510 if (!(sv = LvTARG(sv)))
513 (void)SvREFCNT_inc(sv);
515 else if (SvTYPE(sv) == SVt_PVAV) {
516 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
519 (void)SvREFCNT_inc(sv);
521 else if (SvPADTMP(sv))
525 (void)SvREFCNT_inc(sv);
528 sv_upgrade(rv, SVt_RV);
542 if (sv && SvGMAGICAL(sv))
545 if (!sv || !SvROK(sv))
549 pv = sv_reftype(sv,TRUE);
550 PUSHp(pv, strlen(pv));
560 stash = CopSTASH(PL_curcop);
564 char *ptr = SvPV(ssv,len);
565 if (ckWARN(WARN_MISC) && len == 0)
566 Perl_warner(aTHX_ WARN_MISC,
567 "Explicit blessing to '' (assuming package main)");
568 stash = gv_stashpvn(ptr, len, TRUE);
571 (void)sv_bless(TOPs, stash);
585 elem = SvPV(sv, n_a);
589 switch (elem ? *elem : '\0')
592 if (strEQ(elem, "ARRAY"))
593 tmpRef = (SV*)GvAV(gv);
596 if (strEQ(elem, "CODE"))
597 tmpRef = (SV*)GvCVu(gv);
600 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
601 tmpRef = (SV*)GvIOp(gv);
603 if (strEQ(elem, "FORMAT"))
604 tmpRef = (SV*)GvFORM(gv);
607 if (strEQ(elem, "GLOB"))
611 if (strEQ(elem, "HASH"))
612 tmpRef = (SV*)GvHV(gv);
615 if (strEQ(elem, "IO"))
616 tmpRef = (SV*)GvIOp(gv);
619 if (strEQ(elem, "NAME"))
620 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
623 if (strEQ(elem, "PACKAGE"))
624 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
627 if (strEQ(elem, "SCALAR"))
641 /* Pattern matching */
646 register unsigned char *s;
649 register I32 *sfirst;
653 if (sv == PL_lastscream) {
659 SvSCREAM_off(PL_lastscream);
660 SvREFCNT_dec(PL_lastscream);
662 PL_lastscream = SvREFCNT_inc(sv);
665 s = (unsigned char*)(SvPV(sv, len));
669 if (pos > PL_maxscream) {
670 if (PL_maxscream < 0) {
671 PL_maxscream = pos + 80;
672 New(301, PL_screamfirst, 256, I32);
673 New(302, PL_screamnext, PL_maxscream, I32);
676 PL_maxscream = pos + pos / 4;
677 Renew(PL_screamnext, PL_maxscream, I32);
681 sfirst = PL_screamfirst;
682 snext = PL_screamnext;
684 if (!sfirst || !snext)
685 DIE(aTHX_ "do_study: out of memory");
687 for (ch = 256; ch; --ch)
694 snext[pos] = sfirst[ch] - pos;
701 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
710 if (PL_op->op_flags & OPf_STACKED)
716 TARG = sv_newmortal();
721 /* Lvalue operators. */
733 djSP; dMARK; dTARGET;
743 SETi(do_chomp(TOPs));
749 djSP; dMARK; dTARGET;
750 register I32 count = 0;
753 count += do_chomp(POPs);
764 if (!sv || !SvANY(sv))
766 switch (SvTYPE(sv)) {
768 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
772 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
776 if (CvROOT(sv) || CvXSUB(sv))
793 if (!PL_op->op_private) {
802 if (SvTHINKFIRST(sv))
805 switch (SvTYPE(sv)) {
815 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
816 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
817 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
821 /* let user-undef'd sub keep its identity */
822 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
829 SvSetMagicSV(sv, &PL_sv_undef);
833 Newz(602, gp, 1, GP);
834 GvGP(sv) = gp_ref(gp);
835 GvSV(sv) = NEWSV(72,0);
836 GvLINE(sv) = CopLINE(PL_curcop);
842 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
845 SvPV_set(sv, Nullch);
858 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
859 DIE(aTHX_ PL_no_modify);
860 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
861 SvIVX(TOPs) != IV_MIN)
864 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
875 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
876 DIE(aTHX_ PL_no_modify);
877 sv_setsv(TARG, TOPs);
878 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
879 SvIVX(TOPs) != IV_MAX)
882 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
896 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
897 DIE(aTHX_ PL_no_modify);
898 sv_setsv(TARG, TOPs);
899 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
900 SvIVX(TOPs) != IV_MIN)
903 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
912 /* Ordinary operators. */
916 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
919 SETn( Perl_pow( left, right) );
926 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
929 SETn( left * right );
936 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
941 DIE(aTHX_ "Illegal division by zero");
943 /* insure that 20./5. == 4. */
946 if ((NV)I_V(left) == left &&
947 (NV)I_V(right) == right &&
948 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
952 value = left / right;
956 value = left / right;
965 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
975 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
977 right = (right_neg = (i < 0)) ? -i : i;
982 right_neg = dright < 0;
987 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
989 left = (left_neg = (i < 0)) ? -i : i;
997 left_neg = dleft < 0;
1006 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1008 # define CAST_D2UV(d) U_V(d)
1010 # define CAST_D2UV(d) ((UV)(d))
1012 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1013 * or, in other words, precision of UV more than of NV.
1014 * But in fact the approach below turned out to be an
1015 * optimization - floor() may be slow */
1016 if (dright <= UV_MAX && dleft <= UV_MAX) {
1017 right = CAST_D2UV(dright);
1018 left = CAST_D2UV(dleft);
1023 /* Backward-compatibility clause: */
1024 dright = Perl_floor(dright + 0.5);
1025 dleft = Perl_floor(dleft + 0.5);
1028 DIE(aTHX_ "Illegal modulus zero");
1030 dans = Perl_fmod(dleft, dright);
1031 if ((left_neg != right_neg) && dans)
1032 dans = dright - dans;
1035 sv_setnv(TARG, dans);
1042 DIE(aTHX_ "Illegal modulus zero");
1045 if ((left_neg != right_neg) && ans)
1048 /* XXX may warn: unary minus operator applied to unsigned type */
1049 /* could change -foo to be (~foo)+1 instead */
1050 if (ans <= ~((UV)IV_MAX)+1)
1051 sv_setiv(TARG, ~ans+1);
1053 sv_setnv(TARG, -(NV)ans);
1056 sv_setuv(TARG, ans);
1065 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1067 register I32 count = POPi;
1068 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1070 I32 items = SP - MARK;
1073 max = items * count;
1082 repeatcpy((char*)(MARK + items), (char*)MARK,
1083 items * sizeof(SV*), count - 1);
1086 else if (count <= 0)
1089 else { /* Note: mark already snarfed by pp_list */
1092 bool isutf = DO_UTF8(tmpstr);
1094 SvSetSV(TARG, tmpstr);
1095 SvPV_force(TARG, len);
1100 SvGROW(TARG, (count * len) + 1);
1101 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1102 SvCUR(TARG) *= count;
1104 *SvEND(TARG) = '\0';
1107 (void)SvPOK_only_UTF8(TARG);
1109 (void)SvPOK_only(TARG);
1118 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1121 SETn( left - right );
1128 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1131 if (PL_op->op_private & HINT_INTEGER) {
1145 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1148 if (PL_op->op_private & HINT_INTEGER) {
1162 djSP; tryAMAGICbinSET(lt,0);
1165 SETs(boolSV(TOPn < value));
1172 djSP; tryAMAGICbinSET(gt,0);
1175 SETs(boolSV(TOPn > value));
1182 djSP; tryAMAGICbinSET(le,0);
1185 SETs(boolSV(TOPn <= value));
1192 djSP; tryAMAGICbinSET(ge,0);
1195 SETs(boolSV(TOPn >= value));
1202 djSP; tryAMAGICbinSET(ne,0);
1205 SETs(boolSV(TOPn != value));
1212 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1218 if (Perl_isnan(left) || Perl_isnan(right)) {
1222 value = (left > right) - (left < right);
1226 else if (left < right)
1228 else if (left > right)
1242 djSP; tryAMAGICbinSET(slt,0);
1245 int cmp = ((PL_op->op_private & OPpLOCALE)
1246 ? sv_cmp_locale(left, right)
1247 : sv_cmp(left, right));
1248 SETs(boolSV(cmp < 0));
1255 djSP; tryAMAGICbinSET(sgt,0);
1258 int cmp = ((PL_op->op_private & OPpLOCALE)
1259 ? sv_cmp_locale(left, right)
1260 : sv_cmp(left, right));
1261 SETs(boolSV(cmp > 0));
1268 djSP; tryAMAGICbinSET(sle,0);
1271 int cmp = ((PL_op->op_private & OPpLOCALE)
1272 ? sv_cmp_locale(left, right)
1273 : sv_cmp(left, right));
1274 SETs(boolSV(cmp <= 0));
1281 djSP; tryAMAGICbinSET(sge,0);
1284 int cmp = ((PL_op->op_private & OPpLOCALE)
1285 ? sv_cmp_locale(left, right)
1286 : sv_cmp(left, right));
1287 SETs(boolSV(cmp >= 0));
1294 djSP; tryAMAGICbinSET(seq,0);
1297 SETs(boolSV(sv_eq(left, right)));
1304 djSP; tryAMAGICbinSET(sne,0);
1307 SETs(boolSV(!sv_eq(left, right)));
1314 djSP; dTARGET; tryAMAGICbin(scmp,0);
1317 int cmp = ((PL_op->op_private & OPpLOCALE)
1318 ? sv_cmp_locale(left, right)
1319 : sv_cmp(left, right));
1327 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1330 if (SvNIOKp(left) || SvNIOKp(right)) {
1331 if (PL_op->op_private & HINT_INTEGER) {
1332 IV i = SvIV(left) & SvIV(right);
1336 UV u = SvUV(left) & SvUV(right);
1341 do_vop(PL_op->op_type, TARG, left, right);
1350 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1353 if (SvNIOKp(left) || SvNIOKp(right)) {
1354 if (PL_op->op_private & HINT_INTEGER) {
1355 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1359 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1364 do_vop(PL_op->op_type, TARG, left, right);
1373 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1376 if (SvNIOKp(left) || SvNIOKp(right)) {
1377 if (PL_op->op_private & HINT_INTEGER) {
1378 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1382 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1387 do_vop(PL_op->op_type, TARG, left, right);
1396 djSP; dTARGET; tryAMAGICun(neg);
1401 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1403 if (SvIVX(sv) == IV_MIN) {
1404 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1407 else if (SvUVX(sv) <= IV_MAX) {
1412 else if (SvIVX(sv) != IV_MIN) {
1419 else if (SvPOKp(sv)) {
1421 char *s = SvPV(sv, len);
1422 if (isIDFIRST(*s)) {
1423 sv_setpvn(TARG, "-", 1);
1426 else if (*s == '+' || *s == '-') {
1428 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1430 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1431 sv_setpvn(TARG, "-", 1);
1435 sv_setnv(TARG, -SvNV(sv));
1446 djSP; tryAMAGICunSET(not);
1447 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1453 djSP; dTARGET; tryAMAGICun(compl);
1457 if (PL_op->op_private & HINT_INTEGER) {
1467 register char *tmps;
1468 register long *tmpl;
1473 tmps = SvPV_force(TARG, len);
1476 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1479 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1483 for ( ; anum > 0; anum--, tmps++)
1492 /* integer versions of some of the above */
1496 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1499 SETi( left * right );
1506 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1510 DIE(aTHX_ "Illegal division by zero");
1511 value = POPi / value;
1519 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1523 DIE(aTHX_ "Illegal modulus zero");
1524 SETi( left % right );
1531 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1534 SETi( left + right );
1541 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1544 SETi( left - right );
1551 djSP; tryAMAGICbinSET(lt,0);
1554 SETs(boolSV(left < right));
1561 djSP; tryAMAGICbinSET(gt,0);
1564 SETs(boolSV(left > right));
1571 djSP; tryAMAGICbinSET(le,0);
1574 SETs(boolSV(left <= right));
1581 djSP; tryAMAGICbinSET(ge,0);
1584 SETs(boolSV(left >= right));
1591 djSP; tryAMAGICbinSET(eq,0);
1594 SETs(boolSV(left == right));
1601 djSP; tryAMAGICbinSET(ne,0);
1604 SETs(boolSV(left != right));
1611 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1618 else if (left < right)
1629 djSP; dTARGET; tryAMAGICun(neg);
1634 /* High falutin' math. */
1638 djSP; dTARGET; tryAMAGICbin(atan2,0);
1641 SETn(Perl_atan2(left, right));
1648 djSP; dTARGET; tryAMAGICun(sin);
1652 value = Perl_sin(value);
1660 djSP; dTARGET; tryAMAGICun(cos);
1664 value = Perl_cos(value);
1670 /* Support Configure command-line overrides for rand() functions.
1671 After 5.005, perhaps we should replace this by Configure support
1672 for drand48(), random(), or rand(). For 5.005, though, maintain
1673 compatibility by calling rand() but allow the user to override it.
1674 See INSTALL for details. --Andy Dougherty 15 July 1998
1676 /* Now it's after 5.005, and Configure supports drand48() and random(),
1677 in addition to rand(). So the overrides should not be needed any more.
1678 --Jarkko Hietaniemi 27 September 1998
1681 #ifndef HAS_DRAND48_PROTO
1682 extern double drand48 (void);
1695 if (!PL_srand_called) {
1696 (void)seedDrand01((Rand_seed_t)seed());
1697 PL_srand_called = TRUE;
1712 (void)seedDrand01((Rand_seed_t)anum);
1713 PL_srand_called = TRUE;
1722 * This is really just a quick hack which grabs various garbage
1723 * values. It really should be a real hash algorithm which
1724 * spreads the effect of every input bit onto every output bit,
1725 * if someone who knows about such things would bother to write it.
1726 * Might be a good idea to add that function to CORE as well.
1727 * No numbers below come from careful analysis or anything here,
1728 * except they are primes and SEED_C1 > 1E6 to get a full-width
1729 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1730 * probably be bigger too.
1733 # define SEED_C1 1000003
1734 #define SEED_C4 73819
1736 # define SEED_C1 25747
1737 #define SEED_C4 20639
1741 #define SEED_C5 26107
1744 #ifndef PERL_NO_DEV_RANDOM
1749 # include <starlet.h>
1750 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1751 * in 100-ns units, typically incremented ever 10 ms. */
1752 unsigned int when[2];
1754 # ifdef HAS_GETTIMEOFDAY
1755 struct timeval when;
1761 /* This test is an escape hatch, this symbol isn't set by Configure. */
1762 #ifndef PERL_NO_DEV_RANDOM
1763 #ifndef PERL_RANDOM_DEVICE
1764 /* /dev/random isn't used by default because reads from it will block
1765 * if there isn't enough entropy available. You can compile with
1766 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1767 * is enough real entropy to fill the seed. */
1768 # define PERL_RANDOM_DEVICE "/dev/urandom"
1770 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1772 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1781 _ckvmssts(sys$gettim(when));
1782 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1784 # ifdef HAS_GETTIMEOFDAY
1785 gettimeofday(&when,(struct timezone *) 0);
1786 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1789 u = (U32)SEED_C1 * when;
1792 u += SEED_C3 * (U32)PerlProc_getpid();
1793 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1794 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1795 u += SEED_C5 * (U32)PTR2UV(&when);
1802 djSP; dTARGET; tryAMAGICun(exp);
1806 value = Perl_exp(value);
1814 djSP; dTARGET; tryAMAGICun(log);
1819 RESTORE_NUMERIC_STANDARD();
1820 DIE(aTHX_ "Can't take log of %g", value);
1822 value = Perl_log(value);
1830 djSP; dTARGET; tryAMAGICun(sqrt);
1835 RESTORE_NUMERIC_STANDARD();
1836 DIE(aTHX_ "Can't take sqrt of %g", value);
1838 value = Perl_sqrt(value);
1851 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1857 (void)Perl_modf(value, &value);
1859 (void)Perl_modf(-value, &value);
1874 djSP; dTARGET; tryAMAGICun(abs);
1879 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1880 (iv = SvIVX(TOPs)) != IV_MIN) {
1902 argtype = 1; /* allow underscores */
1903 XPUSHn(scan_hex(tmps, 99, &argtype));
1916 while (*tmps && isSPACE(*tmps))
1920 argtype = 1; /* allow underscores */
1922 value = scan_hex(++tmps, 99, &argtype);
1923 else if (*tmps == 'b')
1924 value = scan_bin(++tmps, 99, &argtype);
1926 value = scan_oct(tmps, 99, &argtype);
1939 SETi(sv_len_utf8(sv));
1955 I32 lvalue = PL_op->op_flags & OPf_MOD;
1957 I32 arybase = PL_curcop->cop_arybase;
1961 SvTAINTED_off(TARG); /* decontaminate */
1962 SvUTF8_off(TARG); /* decontaminate */
1966 repl = SvPV(sv, repl_len);
1973 tmps = SvPV(sv, curlen);
1975 utfcurlen = sv_len_utf8(sv);
1976 if (utfcurlen == curlen)
1984 if (pos >= arybase) {
2002 else if (len >= 0) {
2004 if (rem > (I32)curlen)
2019 Perl_croak(aTHX_ "substr outside of string");
2020 if (ckWARN(WARN_SUBSTR))
2021 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2026 sv_pos_u2b(sv, &pos, &rem);
2028 sv_setpvn(TARG, tmps, rem);
2032 sv_insert(sv, pos, rem, repl, repl_len);
2033 else if (lvalue) { /* it's an lvalue! */
2034 if (!SvGMAGICAL(sv)) {
2038 if (ckWARN(WARN_SUBSTR))
2039 Perl_warner(aTHX_ WARN_SUBSTR,
2040 "Attempt to use reference as lvalue in substr");
2042 if (SvOK(sv)) /* is it defined ? */
2043 (void)SvPOK_only_UTF8(sv);
2045 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2048 if (SvTYPE(TARG) < SVt_PVLV) {
2049 sv_upgrade(TARG, SVt_PVLV);
2050 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2054 if (LvTARG(TARG) != sv) {
2056 SvREFCNT_dec(LvTARG(TARG));
2057 LvTARG(TARG) = SvREFCNT_inc(sv);
2059 LvTARGOFF(TARG) = pos;
2060 LvTARGLEN(TARG) = rem;
2064 PUSHs(TARG); /* avoid SvSETMAGIC here */
2071 register I32 size = POPi;
2072 register I32 offset = POPi;
2073 register SV *src = POPs;
2074 I32 lvalue = PL_op->op_flags & OPf_MOD;
2076 SvTAINTED_off(TARG); /* decontaminate */
2077 if (lvalue) { /* it's an lvalue! */
2078 if (SvTYPE(TARG) < SVt_PVLV) {
2079 sv_upgrade(TARG, SVt_PVLV);
2080 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2083 if (LvTARG(TARG) != src) {
2085 SvREFCNT_dec(LvTARG(TARG));
2086 LvTARG(TARG) = SvREFCNT_inc(src);
2088 LvTARGOFF(TARG) = offset;
2089 LvTARGLEN(TARG) = size;
2092 sv_setuv(TARG, do_vecget(src, offset, size));
2107 I32 arybase = PL_curcop->cop_arybase;
2112 offset = POPi - arybase;
2115 tmps = SvPV(big, biglen);
2116 if (offset > 0 && DO_UTF8(big))
2117 sv_pos_u2b(big, &offset, 0);
2120 else if (offset > biglen)
2122 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2123 (unsigned char*)tmps + biglen, little, 0)))
2126 retval = tmps2 - tmps;
2127 if (retval > 0 && DO_UTF8(big))
2128 sv_pos_b2u(big, &retval);
2129 PUSHi(retval + arybase);
2144 I32 arybase = PL_curcop->cop_arybase;
2150 tmps2 = SvPV(little, llen);
2151 tmps = SvPV(big, blen);
2155 if (offset > 0 && DO_UTF8(big))
2156 sv_pos_u2b(big, &offset, 0);
2157 offset = offset - arybase + llen;
2161 else if (offset > blen)
2163 if (!(tmps2 = rninstr(tmps, tmps + offset,
2164 tmps2, tmps2 + llen)))
2167 retval = tmps2 - tmps;
2168 if (retval > 0 && DO_UTF8(big))
2169 sv_pos_b2u(big, &retval);
2170 PUSHi(retval + arybase);
2176 djSP; dMARK; dORIGMARK; dTARGET;
2177 do_sprintf(TARG, SP-MARK, MARK+1);
2178 TAINT_IF(SvTAINTED(TARG));
2190 U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
2193 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2194 value = utf8_to_uv(tmps, &retlen);
2196 value = (UV)(*tmps & 255);
2207 (void)SvUPGRADE(TARG,SVt_PV);
2209 if (value > 255 && !IN_BYTE) {
2210 SvGROW(TARG, UTF8_MAXLEN+1);
2212 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2213 SvCUR_set(TARG, tmps - SvPVX(TARG));
2215 (void)SvPOK_only(TARG);
2226 (void)SvPOK_only(TARG);
2233 djSP; dTARGET; dPOPTOPssrl;
2236 char *tmps = SvPV(left, n_a);
2238 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2240 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2244 "The crypt() function is unimplemented due to excessive paranoia.");
2257 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2259 U8 tmpbuf[UTF8_MAXLEN];
2261 UV uv = utf8_to_uv(s, &ulen);
2263 if (PL_op->op_private & OPpLOCALE) {
2266 uv = toTITLE_LC_uni(uv);
2269 uv = toTITLE_utf8(s);
2271 tend = uv_to_utf8(tmpbuf, uv);
2273 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2275 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2276 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2281 s = (U8*)SvPV_force(sv, slen);
2282 Copy(tmpbuf, s, ulen, U8);
2286 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2288 SvUTF8_off(TARG); /* decontaminate */
2293 s = (U8*)SvPV_force(sv, slen);
2295 if (PL_op->op_private & OPpLOCALE) {
2298 *s = toUPPER_LC(*s);
2316 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2318 U8 tmpbuf[UTF8_MAXLEN];
2320 UV uv = utf8_to_uv(s, &ulen);
2322 if (PL_op->op_private & OPpLOCALE) {
2325 uv = toLOWER_LC_uni(uv);
2328 uv = toLOWER_utf8(s);
2330 tend = uv_to_utf8(tmpbuf, uv);
2332 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2334 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2335 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2340 s = (U8*)SvPV_force(sv, slen);
2341 Copy(tmpbuf, s, ulen, U8);
2345 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2347 SvUTF8_off(TARG); /* decontaminate */
2352 s = (U8*)SvPV_force(sv, slen);
2354 if (PL_op->op_private & OPpLOCALE) {
2357 *s = toLOWER_LC(*s);
2381 s = (U8*)SvPV(sv,len);
2383 SvUTF8_off(TARG); /* decontaminate */
2384 sv_setpvn(TARG, "", 0);
2388 (void)SvUPGRADE(TARG, SVt_PV);
2389 SvGROW(TARG, (len * 2) + 1);
2390 (void)SvPOK_only(TARG);
2391 d = (U8*)SvPVX(TARG);
2393 if (PL_op->op_private & OPpLOCALE) {
2397 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2403 d = uv_to_utf8(d, toUPPER_utf8( s ));
2409 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2414 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2416 SvUTF8_off(TARG); /* decontaminate */
2421 s = (U8*)SvPV_force(sv, len);
2423 register U8 *send = s + len;
2425 if (PL_op->op_private & OPpLOCALE) {
2428 for (; s < send; s++)
2429 *s = toUPPER_LC(*s);
2432 for (; s < send; s++)
2455 s = (U8*)SvPV(sv,len);
2457 SvUTF8_off(TARG); /* decontaminate */
2458 sv_setpvn(TARG, "", 0);
2462 (void)SvUPGRADE(TARG, SVt_PV);
2463 SvGROW(TARG, (len * 2) + 1);
2464 (void)SvPOK_only(TARG);
2465 d = (U8*)SvPVX(TARG);
2467 if (PL_op->op_private & OPpLOCALE) {
2471 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2477 d = uv_to_utf8(d, toLOWER_utf8(s));
2483 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2488 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2490 SvUTF8_off(TARG); /* decontaminate */
2496 s = (U8*)SvPV_force(sv, len);
2498 register U8 *send = s + len;
2500 if (PL_op->op_private & OPpLOCALE) {
2503 for (; s < send; s++)
2504 *s = toLOWER_LC(*s);
2507 for (; s < send; s++)
2522 register char *s = SvPV(sv,len);
2525 SvUTF8_off(TARG); /* decontaminate */
2527 (void)SvUPGRADE(TARG, SVt_PV);
2528 SvGROW(TARG, (len * 2) + 1);
2533 STRLEN ulen = UTF8SKIP(s);
2557 SvCUR_set(TARG, d - SvPVX(TARG));
2558 (void)SvPOK_only_UTF8(TARG);
2561 sv_setpvn(TARG, s, len);
2563 if (SvSMAGICAL(TARG))
2572 djSP; dMARK; dORIGMARK;
2574 register AV* av = (AV*)POPs;
2575 register I32 lval = PL_op->op_flags & OPf_MOD;
2576 I32 arybase = PL_curcop->cop_arybase;
2579 if (SvTYPE(av) == SVt_PVAV) {
2580 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2582 for (svp = MARK + 1; svp <= SP; svp++) {
2587 if (max > AvMAX(av))
2590 while (++MARK <= SP) {
2591 elem = SvIVx(*MARK);
2595 svp = av_fetch(av, elem, lval);
2597 if (!svp || *svp == &PL_sv_undef)
2598 DIE(aTHX_ PL_no_aelem, elem);
2599 if (PL_op->op_private & OPpLVAL_INTRO)
2600 save_aelem(av, elem, svp);
2602 *MARK = svp ? *svp : &PL_sv_undef;
2605 if (GIMME != G_ARRAY) {
2613 /* Associative arrays. */
2618 HV *hash = (HV*)POPs;
2620 I32 gimme = GIMME_V;
2621 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2624 /* might clobber stack_sp */
2625 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2630 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2631 if (gimme == G_ARRAY) {
2634 /* might clobber stack_sp */
2636 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2641 else if (gimme == G_SCALAR)
2660 I32 gimme = GIMME_V;
2661 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2665 if (PL_op->op_private & OPpSLICE) {
2669 hvtype = SvTYPE(hv);
2670 if (hvtype == SVt_PVHV) { /* hash element */
2671 while (++MARK <= SP) {
2672 sv = hv_delete_ent(hv, *MARK, discard, 0);
2673 *MARK = sv ? sv : &PL_sv_undef;
2676 else if (hvtype == SVt_PVAV) {
2677 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2678 while (++MARK <= SP) {
2679 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2680 *MARK = sv ? sv : &PL_sv_undef;
2683 else { /* pseudo-hash element */
2684 while (++MARK <= SP) {
2685 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2686 *MARK = sv ? sv : &PL_sv_undef;
2691 DIE(aTHX_ "Not a HASH reference");
2694 else if (gimme == G_SCALAR) {
2703 if (SvTYPE(hv) == SVt_PVHV)
2704 sv = hv_delete_ent(hv, keysv, discard, 0);
2705 else if (SvTYPE(hv) == SVt_PVAV) {
2706 if (PL_op->op_flags & OPf_SPECIAL)
2707 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2709 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2712 DIE(aTHX_ "Not a HASH reference");
2727 if (PL_op->op_private & OPpEXISTS_SUB) {
2731 cv = sv_2cv(sv, &hv, &gv, FALSE);
2734 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2740 if (SvTYPE(hv) == SVt_PVHV) {
2741 if (hv_exists_ent(hv, tmpsv, 0))
2744 else if (SvTYPE(hv) == SVt_PVAV) {
2745 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2746 if (av_exists((AV*)hv, SvIV(tmpsv)))
2749 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2753 DIE(aTHX_ "Not a HASH reference");
2760 djSP; dMARK; dORIGMARK;
2761 register HV *hv = (HV*)POPs;
2762 register I32 lval = PL_op->op_flags & OPf_MOD;
2763 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2765 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2766 DIE(aTHX_ "Can't localize pseudo-hash element");
2768 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2769 while (++MARK <= SP) {
2773 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2774 svp = he ? &HeVAL(he) : 0;
2777 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2780 if (!svp || *svp == &PL_sv_undef) {
2782 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2784 if (PL_op->op_private & OPpLVAL_INTRO)
2785 save_helem(hv, keysv, svp);
2787 *MARK = svp ? *svp : &PL_sv_undef;
2790 if (GIMME != G_ARRAY) {
2798 /* List operators. */
2803 if (GIMME != G_ARRAY) {
2805 *MARK = *SP; /* unwanted list, return last item */
2807 *MARK = &PL_sv_undef;
2816 SV **lastrelem = PL_stack_sp;
2817 SV **lastlelem = PL_stack_base + POPMARK;
2818 SV **firstlelem = PL_stack_base + POPMARK + 1;
2819 register SV **firstrelem = lastlelem + 1;
2820 I32 arybase = PL_curcop->cop_arybase;
2821 I32 lval = PL_op->op_flags & OPf_MOD;
2822 I32 is_something_there = lval;
2824 register I32 max = lastrelem - lastlelem;
2825 register SV **lelem;
2828 if (GIMME != G_ARRAY) {
2829 ix = SvIVx(*lastlelem);
2834 if (ix < 0 || ix >= max)
2835 *firstlelem = &PL_sv_undef;
2837 *firstlelem = firstrelem[ix];
2843 SP = firstlelem - 1;
2847 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2853 if (ix < 0 || ix >= max)
2854 *lelem = &PL_sv_undef;
2856 is_something_there = TRUE;
2857 if (!(*lelem = firstrelem[ix]))
2858 *lelem = &PL_sv_undef;
2861 if (is_something_there)
2864 SP = firstlelem - 1;
2870 djSP; dMARK; dORIGMARK;
2871 I32 items = SP - MARK;
2872 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2873 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2880 djSP; dMARK; dORIGMARK;
2881 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2885 SV *val = NEWSV(46, 0);
2887 sv_setsv(val, *++MARK);
2888 else if (ckWARN(WARN_MISC))
2889 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2890 (void)hv_store_ent(hv,key,val,0);
2899 djSP; dMARK; dORIGMARK;
2900 register AV *ary = (AV*)*++MARK;
2904 register I32 offset;
2905 register I32 length;
2912 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2913 *MARK-- = SvTIED_obj((SV*)ary, mg);
2917 call_method("SPLICE",GIMME_V);
2926 offset = i = SvIVx(*MARK);
2928 offset += AvFILLp(ary) + 1;
2930 offset -= PL_curcop->cop_arybase;
2932 DIE(aTHX_ PL_no_aelem, i);
2934 length = SvIVx(*MARK++);
2936 length += AvFILLp(ary) - offset + 1;
2942 length = AvMAX(ary) + 1; /* close enough to infinity */
2946 length = AvMAX(ary) + 1;
2948 if (offset > AvFILLp(ary) + 1)
2949 offset = AvFILLp(ary) + 1;
2950 after = AvFILLp(ary) + 1 - (offset + length);
2951 if (after < 0) { /* not that much array */
2952 length += after; /* offset+length now in array */
2958 /* At this point, MARK .. SP-1 is our new LIST */
2961 diff = newlen - length;
2962 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2965 if (diff < 0) { /* shrinking the area */
2967 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2968 Copy(MARK, tmparyval, newlen, SV*);
2971 MARK = ORIGMARK + 1;
2972 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2973 MEXTEND(MARK, length);
2974 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2976 EXTEND_MORTAL(length);
2977 for (i = length, dst = MARK; i; i--) {
2978 sv_2mortal(*dst); /* free them eventualy */
2985 *MARK = AvARRAY(ary)[offset+length-1];
2988 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2989 SvREFCNT_dec(*dst++); /* free them now */
2992 AvFILLp(ary) += diff;
2994 /* pull up or down? */
2996 if (offset < after) { /* easier to pull up */
2997 if (offset) { /* esp. if nothing to pull */
2998 src = &AvARRAY(ary)[offset-1];
2999 dst = src - diff; /* diff is negative */
3000 for (i = offset; i > 0; i--) /* can't trust Copy */
3004 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3008 if (after) { /* anything to pull down? */
3009 src = AvARRAY(ary) + offset + length;
3010 dst = src + diff; /* diff is negative */
3011 Move(src, dst, after, SV*);
3013 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3014 /* avoid later double free */
3018 dst[--i] = &PL_sv_undef;
3021 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3023 *dst = NEWSV(46, 0);
3024 sv_setsv(*dst++, *src++);
3026 Safefree(tmparyval);
3029 else { /* no, expanding (or same) */
3031 New(452, tmparyval, length, SV*); /* so remember deletion */
3032 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3035 if (diff > 0) { /* expanding */
3037 /* push up or down? */
3039 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3043 Move(src, dst, offset, SV*);
3045 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3047 AvFILLp(ary) += diff;
3050 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3051 av_extend(ary, AvFILLp(ary) + diff);
3052 AvFILLp(ary) += diff;
3055 dst = AvARRAY(ary) + AvFILLp(ary);
3057 for (i = after; i; i--) {
3064 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3065 *dst = NEWSV(46, 0);
3066 sv_setsv(*dst++, *src++);
3068 MARK = ORIGMARK + 1;
3069 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3071 Copy(tmparyval, MARK, length, SV*);
3073 EXTEND_MORTAL(length);
3074 for (i = length, dst = MARK; i; i--) {
3075 sv_2mortal(*dst); /* free them eventualy */
3079 Safefree(tmparyval);
3083 else if (length--) {
3084 *MARK = tmparyval[length];
3087 while (length-- > 0)
3088 SvREFCNT_dec(tmparyval[length]);
3090 Safefree(tmparyval);
3093 *MARK = &PL_sv_undef;
3101 djSP; dMARK; dORIGMARK; dTARGET;
3102 register AV *ary = (AV*)*++MARK;
3103 register SV *sv = &PL_sv_undef;
3106 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3107 *MARK-- = SvTIED_obj((SV*)ary, mg);
3111 call_method("PUSH",G_SCALAR|G_DISCARD);
3116 /* Why no pre-extend of ary here ? */
3117 for (++MARK; MARK <= SP; MARK++) {
3120 sv_setsv(sv, *MARK);
3125 PUSHi( AvFILL(ary) + 1 );
3133 SV *sv = av_pop(av);
3135 (void)sv_2mortal(sv);
3144 SV *sv = av_shift(av);
3149 (void)sv_2mortal(sv);
3156 djSP; dMARK; dORIGMARK; dTARGET;
3157 register AV *ary = (AV*)*++MARK;
3162 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3163 *MARK-- = SvTIED_obj((SV*)ary, mg);
3167 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3172 av_unshift(ary, SP - MARK);
3175 sv_setsv(sv, *++MARK);
3176 (void)av_store(ary, i++, sv);
3180 PUSHi( AvFILL(ary) + 1 );
3190 if (GIMME == G_ARRAY) {
3197 /* safe as long as stack cannot get extended in the above */
3202 register char *down;
3207 SvUTF8_off(TARG); /* decontaminate */
3209 do_join(TARG, &PL_sv_no, MARK, SP);
3211 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3212 up = SvPV_force(TARG, len);
3214 if (DO_UTF8(TARG)) { /* first reverse each character */
3215 U8* s = (U8*)SvPVX(TARG);
3216 U8* send = (U8*)(s + len);
3225 down = (char*)(s - 1);
3226 if (s > send || !((*down & 0xc0) == 0x80)) {
3227 if (ckWARN_d(WARN_UTF8))
3228 Perl_warner(aTHX_ WARN_UTF8,
3229 "Malformed UTF-8 character");
3241 down = SvPVX(TARG) + len - 1;
3247 (void)SvPOK_only_UTF8(TARG);
3256 S_mul128(pTHX_ SV *sv, U8 m)
3259 char *s = SvPV(sv, len);
3263 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3264 SV *tmpNew = newSVpvn("0000000000", 10);
3266 sv_catsv(tmpNew, sv);
3267 SvREFCNT_dec(sv); /* free old sv */
3272 while (!*t) /* trailing '\0'? */
3275 i = ((*t - '0') << 7) + m;
3276 *(t--) = '0' + (i % 10);
3282 /* Explosives and implosives. */
3284 #if 'I' == 73 && 'J' == 74
3285 /* On an ASCII/ISO kind of system */
3286 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3289 Some other sort of character set - use memchr() so we don't match
3292 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3299 I32 start_sp_offset = SP - PL_stack_base;
3300 I32 gimme = GIMME_V;
3304 register char *pat = SvPV(left, llen);
3305 register char *s = SvPV(right, rlen);
3306 char *strend = s + rlen;
3308 register char *patend = pat + llen;
3314 /* These must not be in registers: */
3331 register U32 culong;
3335 #ifdef PERL_NATINT_PACK
3336 int natint; /* native integer */
3337 int unatint; /* unsigned native integer */
3340 if (gimme != G_ARRAY) { /* arrange to do first one only */
3342 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3343 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3345 while (isDIGIT(*patend) || *patend == '*')
3351 while (pat < patend) {
3353 datumtype = *pat++ & 0xFF;
3354 #ifdef PERL_NATINT_PACK
3357 if (isSPACE(datumtype))
3359 if (datumtype == '#') {
3360 while (pat < patend && *pat != '\n')
3365 char *natstr = "sSiIlL";
3367 if (strchr(natstr, datumtype)) {
3368 #ifdef PERL_NATINT_PACK
3374 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3379 else if (*pat == '*') {
3380 len = strend - strbeg; /* long enough */
3384 else if (isDIGIT(*pat)) {
3386 while (isDIGIT(*pat)) {
3387 len = (len * 10) + (*pat++ - '0');
3389 DIE(aTHX_ "Repeat count in unpack overflows");
3393 len = (datumtype != '@');
3397 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3398 case ',': /* grandfather in commas but with a warning */
3399 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3400 Perl_warner(aTHX_ WARN_UNPACK,
3401 "Invalid type in unpack: '%c'", (int)datumtype);
3404 if (len == 1 && pat[-1] != '1')
3413 if (len > strend - strbeg)
3414 DIE(aTHX_ "@ outside of string");
3418 if (len > s - strbeg)
3419 DIE(aTHX_ "X outside of string");
3423 if (len > strend - s)
3424 DIE(aTHX_ "x outside of string");
3428 if (start_sp_offset >= SP - PL_stack_base)
3429 DIE(aTHX_ "/ must follow a numeric type");
3432 pat++; /* ignore '*' for compatibility with pack */
3434 DIE(aTHX_ "/ cannot take a count" );
3441 if (len > strend - s)
3444 goto uchar_checksum;
3445 sv = NEWSV(35, len);
3446 sv_setpvn(sv, s, len);
3448 if (datumtype == 'A' || datumtype == 'Z') {
3449 aptr = s; /* borrow register */
3450 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3455 else { /* 'A' strips both nulls and spaces */
3456 s = SvPVX(sv) + len - 1;
3457 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3461 SvCUR_set(sv, s - SvPVX(sv));
3462 s = aptr; /* unborrow register */
3464 XPUSHs(sv_2mortal(sv));
3468 if (star || len > (strend - s) * 8)
3469 len = (strend - s) * 8;
3472 Newz(601, PL_bitcount, 256, char);
3473 for (bits = 1; bits < 256; bits++) {
3474 if (bits & 1) PL_bitcount[bits]++;
3475 if (bits & 2) PL_bitcount[bits]++;
3476 if (bits & 4) PL_bitcount[bits]++;
3477 if (bits & 8) PL_bitcount[bits]++;
3478 if (bits & 16) PL_bitcount[bits]++;
3479 if (bits & 32) PL_bitcount[bits]++;
3480 if (bits & 64) PL_bitcount[bits]++;
3481 if (bits & 128) PL_bitcount[bits]++;
3485 culong += PL_bitcount[*(unsigned char*)s++];
3490 if (datumtype == 'b') {
3492 if (bits & 1) culong++;
3498 if (bits & 128) culong++;
3505 sv = NEWSV(35, len + 1);
3509 if (datumtype == 'b') {
3511 for (len = 0; len < aint; len++) {
3512 if (len & 7) /*SUPPRESS 595*/
3516 *str++ = '0' + (bits & 1);
3521 for (len = 0; len < aint; len++) {
3526 *str++ = '0' + ((bits & 128) != 0);
3530 XPUSHs(sv_2mortal(sv));
3534 if (star || len > (strend - s) * 2)
3535 len = (strend - s) * 2;
3536 sv = NEWSV(35, len + 1);
3540 if (datumtype == 'h') {
3542 for (len = 0; len < aint; len++) {
3547 *str++ = PL_hexdigit[bits & 15];
3552 for (len = 0; len < aint; len++) {
3557 *str++ = PL_hexdigit[(bits >> 4) & 15];
3561 XPUSHs(sv_2mortal(sv));
3564 if (len > strend - s)
3569 if (aint >= 128) /* fake up signed chars */
3579 if (aint >= 128) /* fake up signed chars */
3582 sv_setiv(sv, (IV)aint);
3583 PUSHs(sv_2mortal(sv));
3588 if (len > strend - s)
3603 sv_setiv(sv, (IV)auint);
3604 PUSHs(sv_2mortal(sv));
3609 if (len > strend - s)
3612 while (len-- > 0 && s < strend) {
3613 auint = utf8_to_uv((U8*)s, &along);
3616 cdouble += (NV)auint;
3624 while (len-- > 0 && s < strend) {
3625 auint = utf8_to_uv((U8*)s, &along);
3628 sv_setuv(sv, (UV)auint);
3629 PUSHs(sv_2mortal(sv));
3634 #if SHORTSIZE == SIZE16
3635 along = (strend - s) / SIZE16;
3637 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3642 #if SHORTSIZE != SIZE16
3646 COPYNN(s, &ashort, sizeof(short));
3657 #if SHORTSIZE > SIZE16
3669 #if SHORTSIZE != SIZE16
3673 COPYNN(s, &ashort, sizeof(short));
3676 sv_setiv(sv, (IV)ashort);
3677 PUSHs(sv_2mortal(sv));
3685 #if SHORTSIZE > SIZE16
3691 sv_setiv(sv, (IV)ashort);
3692 PUSHs(sv_2mortal(sv));
3700 #if SHORTSIZE == SIZE16
3701 along = (strend - s) / SIZE16;
3703 unatint = natint && datumtype == 'S';
3704 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3709 #if SHORTSIZE != SIZE16
3711 unsigned short aushort;
3713 COPYNN(s, &aushort, sizeof(unsigned short));
3714 s += sizeof(unsigned short);
3722 COPY16(s, &aushort);
3725 if (datumtype == 'n')
3726 aushort = PerlSock_ntohs(aushort);
3729 if (datumtype == 'v')
3730 aushort = vtohs(aushort);
3739 #if SHORTSIZE != SIZE16
3741 unsigned short aushort;
3743 COPYNN(s, &aushort, sizeof(unsigned short));
3744 s += sizeof(unsigned short);
3746 sv_setiv(sv, (UV)aushort);
3747 PUSHs(sv_2mortal(sv));
3754 COPY16(s, &aushort);
3758 if (datumtype == 'n')
3759 aushort = PerlSock_ntohs(aushort);
3762 if (datumtype == 'v')
3763 aushort = vtohs(aushort);
3765 sv_setiv(sv, (UV)aushort);
3766 PUSHs(sv_2mortal(sv));
3772 along = (strend - s) / sizeof(int);
3777 Copy(s, &aint, 1, int);
3780 cdouble += (NV)aint;
3789 Copy(s, &aint, 1, int);
3793 /* Without the dummy below unpack("i", pack("i",-1))
3794 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3795 * cc with optimization turned on.
3797 * The bug was detected in
3798 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3799 * with optimization (-O4) turned on.
3800 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3801 * does not have this problem even with -O4.
3803 * This bug was reported as DECC_BUGS 1431
3804 * and tracked internally as GEM_BUGS 7775.
3806 * The bug is fixed in
3807 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3808 * UNIX V4.0F support: DEC C V5.9-006 or later
3809 * UNIX V4.0E support: DEC C V5.8-011 or later
3812 * See also few lines later for the same bug.
3815 sv_setiv(sv, (IV)aint) :
3817 sv_setiv(sv, (IV)aint);
3818 PUSHs(sv_2mortal(sv));
3823 along = (strend - s) / sizeof(unsigned int);
3828 Copy(s, &auint, 1, unsigned int);
3829 s += sizeof(unsigned int);
3831 cdouble += (NV)auint;
3840 Copy(s, &auint, 1, unsigned int);
3841 s += sizeof(unsigned int);
3844 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3845 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3846 * See details few lines earlier. */
3848 sv_setuv(sv, (UV)auint) :
3850 sv_setuv(sv, (UV)auint);
3851 PUSHs(sv_2mortal(sv));
3856 #if LONGSIZE == SIZE32
3857 along = (strend - s) / SIZE32;
3859 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3864 #if LONGSIZE != SIZE32
3868 COPYNN(s, &along, sizeof(long));
3871 cdouble += (NV)along;
3881 #if LONGSIZE > SIZE32
3882 if (along > 2147483647)
3883 along -= 4294967296;
3887 cdouble += (NV)along;
3896 #if LONGSIZE != SIZE32
3900 COPYNN(s, &along, sizeof(long));
3903 sv_setiv(sv, (IV)along);
3904 PUSHs(sv_2mortal(sv));
3912 #if LONGSIZE > SIZE32
3913 if (along > 2147483647)
3914 along -= 4294967296;
3918 sv_setiv(sv, (IV)along);
3919 PUSHs(sv_2mortal(sv));
3927 #if LONGSIZE == SIZE32
3928 along = (strend - s) / SIZE32;
3930 unatint = natint && datumtype == 'L';
3931 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3936 #if LONGSIZE != SIZE32
3938 unsigned long aulong;
3940 COPYNN(s, &aulong, sizeof(unsigned long));
3941 s += sizeof(unsigned long);
3943 cdouble += (NV)aulong;
3955 if (datumtype == 'N')
3956 aulong = PerlSock_ntohl(aulong);
3959 if (datumtype == 'V')
3960 aulong = vtohl(aulong);
3963 cdouble += (NV)aulong;
3972 #if LONGSIZE != SIZE32
3974 unsigned long aulong;
3976 COPYNN(s, &aulong, sizeof(unsigned long));
3977 s += sizeof(unsigned long);
3979 sv_setuv(sv, (UV)aulong);
3980 PUSHs(sv_2mortal(sv));
3990 if (datumtype == 'N')
3991 aulong = PerlSock_ntohl(aulong);
3994 if (datumtype == 'V')
3995 aulong = vtohl(aulong);
3998 sv_setuv(sv, (UV)aulong);
3999 PUSHs(sv_2mortal(sv));
4005 along = (strend - s) / sizeof(char*);
4011 if (sizeof(char*) > strend - s)
4014 Copy(s, &aptr, 1, char*);
4020 PUSHs(sv_2mortal(sv));
4030 while ((len > 0) && (s < strend)) {
4031 auv = (auv << 7) | (*s & 0x7f);
4032 if (!(*s++ & 0x80)) {
4036 PUSHs(sv_2mortal(sv));
4040 else if (++bytes >= sizeof(UV)) { /* promote to string */
4044 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4045 while (s < strend) {
4046 sv = mul128(sv, *s & 0x7f);
4047 if (!(*s++ & 0x80)) {
4056 PUSHs(sv_2mortal(sv));
4061 if ((s >= strend) && bytes)
4062 DIE(aTHX_ "Unterminated compressed integer");
4067 if (sizeof(char*) > strend - s)
4070 Copy(s, &aptr, 1, char*);
4075 sv_setpvn(sv, aptr, len);
4076 PUSHs(sv_2mortal(sv));
4080 along = (strend - s) / sizeof(Quad_t);
4086 if (s + sizeof(Quad_t) > strend)
4089 Copy(s, &aquad, 1, Quad_t);
4090 s += sizeof(Quad_t);
4093 if (aquad >= IV_MIN && aquad <= IV_MAX)
4094 sv_setiv(sv, (IV)aquad);
4096 sv_setnv(sv, (NV)aquad);
4097 PUSHs(sv_2mortal(sv));
4101 along = (strend - s) / sizeof(Quad_t);
4107 if (s + sizeof(Uquad_t) > strend)
4110 Copy(s, &auquad, 1, Uquad_t);
4111 s += sizeof(Uquad_t);
4114 if (auquad <= UV_MAX)
4115 sv_setuv(sv, (UV)auquad);
4117 sv_setnv(sv, (NV)auquad);
4118 PUSHs(sv_2mortal(sv));
4122 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4125 along = (strend - s) / sizeof(float);
4130 Copy(s, &afloat, 1, float);
4139 Copy(s, &afloat, 1, float);
4142 sv_setnv(sv, (NV)afloat);
4143 PUSHs(sv_2mortal(sv));
4149 along = (strend - s) / sizeof(double);
4154 Copy(s, &adouble, 1, double);
4155 s += sizeof(double);
4163 Copy(s, &adouble, 1, double);
4164 s += sizeof(double);
4166 sv_setnv(sv, (NV)adouble);
4167 PUSHs(sv_2mortal(sv));
4173 * Initialise the decode mapping. By using a table driven
4174 * algorithm, the code will be character-set independent
4175 * (and just as fast as doing character arithmetic)
4177 if (PL_uudmap['M'] == 0) {
4180 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4181 PL_uudmap[(U8)PL_uuemap[i]] = i;
4183 * Because ' ' and '`' map to the same value,
4184 * we need to decode them both the same.
4189 along = (strend - s) * 3 / 4;
4190 sv = NEWSV(42, along);
4193 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4198 len = PL_uudmap[*(U8*)s++] & 077;
4200 if (s < strend && ISUUCHAR(*s))
4201 a = PL_uudmap[*(U8*)s++] & 077;
4204 if (s < strend && ISUUCHAR(*s))
4205 b = PL_uudmap[*(U8*)s++] & 077;
4208 if (s < strend && ISUUCHAR(*s))
4209 c = PL_uudmap[*(U8*)s++] & 077;
4212 if (s < strend && ISUUCHAR(*s))
4213 d = PL_uudmap[*(U8*)s++] & 077;
4216 hunk[0] = (a << 2) | (b >> 4);
4217 hunk[1] = (b << 4) | (c >> 2);
4218 hunk[2] = (c << 6) | d;
4219 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4224 else if (s[1] == '\n') /* possible checksum byte */
4227 XPUSHs(sv_2mortal(sv));
4232 if (strchr("fFdD", datumtype) ||
4233 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4237 while (checksum >= 16) {
4241 while (checksum >= 4) {
4247 along = (1 << checksum) - 1;
4248 while (cdouble < 0.0)
4250 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4251 sv_setnv(sv, cdouble);
4254 if (checksum < 32) {
4255 aulong = (1 << checksum) - 1;
4258 sv_setuv(sv, (UV)culong);
4260 XPUSHs(sv_2mortal(sv));
4264 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4265 PUSHs(&PL_sv_undef);
4270 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4274 *hunk = PL_uuemap[len];
4275 sv_catpvn(sv, hunk, 1);
4278 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4279 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4280 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4281 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4282 sv_catpvn(sv, hunk, 4);
4287 char r = (len > 1 ? s[1] : '\0');
4288 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4289 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4290 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4291 hunk[3] = PL_uuemap[0];
4292 sv_catpvn(sv, hunk, 4);
4294 sv_catpvn(sv, "\n", 1);
4298 S_is_an_int(pTHX_ char *s, STRLEN l)
4301 SV *result = newSVpvn(s, l);
4302 char *result_c = SvPV(result, n_a); /* convenience */
4303 char *out = result_c;
4313 SvREFCNT_dec(result);
4336 SvREFCNT_dec(result);
4342 SvCUR_set(result, out - result_c);
4346 /* pnum must be '\0' terminated */
4348 S_div128(pTHX_ SV *pnum, bool *done)
4351 char *s = SvPV(pnum, len);
4360 i = m * 10 + (*t - '0');
4362 r = (i >> 7); /* r < 10 */
4369 SvCUR_set(pnum, (STRLEN) (t - s));
4376 djSP; dMARK; dORIGMARK; dTARGET;
4377 register SV *cat = TARG;
4380 register char *pat = SvPVx(*++MARK, fromlen);
4382 register char *patend = pat + fromlen;
4387 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4388 static char *space10 = " ";
4390 /* These must not be in registers: */
4405 #ifdef PERL_NATINT_PACK
4406 int natint; /* native integer */
4411 sv_setpvn(cat, "", 0);
4413 while (pat < patend) {
4414 SV *lengthcode = Nullsv;
4415 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4416 datumtype = *pat++ & 0xFF;
4417 #ifdef PERL_NATINT_PACK
4420 if (isSPACE(datumtype)) {
4424 if (datumtype == 'U' && pat == patcopy+1)
4426 if (datumtype == '#') {
4427 while (pat < patend && *pat != '\n')
4432 char *natstr = "sSiIlL";
4434 if (strchr(natstr, datumtype)) {
4435 #ifdef PERL_NATINT_PACK
4441 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4444 len = strchr("@Xxu", datumtype) ? 0 : items;
4447 else if (isDIGIT(*pat)) {
4449 while (isDIGIT(*pat)) {
4450 len = (len * 10) + (*pat++ - '0');
4452 DIE(aTHX_ "Repeat count in pack overflows");
4459 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4460 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4461 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4462 ? *MARK : &PL_sv_no)
4463 + (*pat == 'Z' ? 1 : 0)));
4467 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4468 case ',': /* grandfather in commas but with a warning */
4469 if (commas++ == 0 && ckWARN(WARN_PACK))
4470 Perl_warner(aTHX_ WARN_PACK,
4471 "Invalid type in pack: '%c'", (int)datumtype);
4474 DIE(aTHX_ "%% may only be used in unpack");
4485 if (SvCUR(cat) < len)
4486 DIE(aTHX_ "X outside of string");
4493 sv_catpvn(cat, null10, 10);
4496 sv_catpvn(cat, null10, len);
4502 aptr = SvPV(fromstr, fromlen);
4503 if (pat[-1] == '*') {
4505 if (datumtype == 'Z')
4508 if (fromlen >= len) {
4509 sv_catpvn(cat, aptr, len);
4510 if (datumtype == 'Z')
4511 *(SvEND(cat)-1) = '\0';
4514 sv_catpvn(cat, aptr, fromlen);
4516 if (datumtype == 'A') {
4518 sv_catpvn(cat, space10, 10);
4521 sv_catpvn(cat, space10, len);
4525 sv_catpvn(cat, null10, 10);
4528 sv_catpvn(cat, null10, len);
4540 str = SvPV(fromstr, fromlen);
4544 SvCUR(cat) += (len+7)/8;
4545 SvGROW(cat, SvCUR(cat) + 1);
4546 aptr = SvPVX(cat) + aint;
4551 if (datumtype == 'B') {
4552 for (len = 0; len++ < aint;) {
4553 items |= *str++ & 1;
4557 *aptr++ = items & 0xff;
4563 for (len = 0; len++ < aint;) {
4569 *aptr++ = items & 0xff;
4575 if (datumtype == 'B')
4576 items <<= 7 - (aint & 7);
4578 items >>= 7 - (aint & 7);
4579 *aptr++ = items & 0xff;
4581 str = SvPVX(cat) + SvCUR(cat);
4596 str = SvPV(fromstr, fromlen);
4600 SvCUR(cat) += (len+1)/2;
4601 SvGROW(cat, SvCUR(cat) + 1);
4602 aptr = SvPVX(cat) + aint;
4607 if (datumtype == 'H') {
4608 for (len = 0; len++ < aint;) {
4610 items |= ((*str++ & 15) + 9) & 15;
4612 items |= *str++ & 15;
4616 *aptr++ = items & 0xff;
4622 for (len = 0; len++ < aint;) {
4624 items |= (((*str++ & 15) + 9) & 15) << 4;
4626 items |= (*str++ & 15) << 4;
4630 *aptr++ = items & 0xff;
4636 *aptr++ = items & 0xff;
4637 str = SvPVX(cat) + SvCUR(cat);
4648 aint = SvIV(fromstr);
4650 sv_catpvn(cat, &achar, sizeof(char));
4656 auint = SvUV(fromstr);
4657 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4658 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4663 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4668 afloat = (float)SvNV(fromstr);
4669 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4676 adouble = (double)SvNV(fromstr);
4677 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4683 ashort = (I16)SvIV(fromstr);
4685 ashort = PerlSock_htons(ashort);
4687 CAT16(cat, &ashort);
4693 ashort = (I16)SvIV(fromstr);
4695 ashort = htovs(ashort);
4697 CAT16(cat, &ashort);
4701 #if SHORTSIZE != SIZE16
4703 unsigned short aushort;
4707 aushort = SvUV(fromstr);
4708 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4718 aushort = (U16)SvUV(fromstr);
4719 CAT16(cat, &aushort);
4725 #if SHORTSIZE != SIZE16
4731 ashort = SvIV(fromstr);
4732 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4740 ashort = (I16)SvIV(fromstr);
4741 CAT16(cat, &ashort);
4748 auint = SvUV(fromstr);
4749 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4755 adouble = Perl_floor(SvNV(fromstr));
4758 DIE(aTHX_ "Cannot compress negative numbers");
4761 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4762 adouble <= 0xffffffff
4764 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4765 adouble <= UV_MAX_cxux
4772 char buf[1 + sizeof(UV)];
4773 char *in = buf + sizeof(buf);
4774 UV auv = U_V(adouble);
4777 *--in = (auv & 0x7f) | 0x80;
4780 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4781 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4783 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4784 char *from, *result, *in;
4789 /* Copy string and check for compliance */
4790 from = SvPV(fromstr, len);
4791 if ((norm = is_an_int(from, len)) == NULL)
4792 DIE(aTHX_ "can compress only unsigned integer");
4794 New('w', result, len, char);
4798 *--in = div128(norm, &done) | 0x80;
4799 result[len - 1] &= 0x7F; /* clear continue bit */
4800 sv_catpvn(cat, in, (result + len) - in);
4802 SvREFCNT_dec(norm); /* free norm */
4804 else if (SvNOKp(fromstr)) {
4805 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4806 char *in = buf + sizeof(buf);
4809 double next = floor(adouble / 128);
4810 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4811 if (--in < buf) /* this cannot happen ;-) */
4812 DIE(aTHX_ "Cannot compress integer");
4814 } while (adouble > 0);
4815 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4816 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4819 DIE(aTHX_ "Cannot compress non integer");
4825 aint = SvIV(fromstr);
4826 sv_catpvn(cat, (char*)&aint, sizeof(int));
4832 aulong = SvUV(fromstr);
4834 aulong = PerlSock_htonl(aulong);
4836 CAT32(cat, &aulong);
4842 aulong = SvUV(fromstr);
4844 aulong = htovl(aulong);
4846 CAT32(cat, &aulong);
4850 #if LONGSIZE != SIZE32
4852 unsigned long aulong;
4856 aulong = SvUV(fromstr);
4857 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4865 aulong = SvUV(fromstr);
4866 CAT32(cat, &aulong);
4871 #if LONGSIZE != SIZE32
4877 along = SvIV(fromstr);
4878 sv_catpvn(cat, (char *)&along, sizeof(long));
4886 along = SvIV(fromstr);
4895 auquad = (Uquad_t)SvUV(fromstr);
4896 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4902 aquad = (Quad_t)SvIV(fromstr);
4903 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4908 len = 1; /* assume SV is correct length */
4913 if (fromstr == &PL_sv_undef)
4917 /* XXX better yet, could spirit away the string to
4918 * a safe spot and hang on to it until the result
4919 * of pack() (and all copies of the result) are
4922 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4923 || (SvPADTMP(fromstr)
4924 && !SvREADONLY(fromstr))))
4926 Perl_warner(aTHX_ WARN_PACK,
4927 "Attempt to pack pointer to temporary value");
4929 if (SvPOK(fromstr) || SvNIOK(fromstr))
4930 aptr = SvPV(fromstr,n_a);
4932 aptr = SvPV_force(fromstr,n_a);
4934 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4939 aptr = SvPV(fromstr, fromlen);
4940 SvGROW(cat, fromlen * 4 / 3);
4945 while (fromlen > 0) {
4952 doencodes(cat, aptr, todo);
4971 register I32 limit = POPi; /* note, negative is forever */
4974 register char *s = SvPV(sv, len);
4975 char *strend = s + len;
4977 register REGEXP *rx;
4981 I32 maxiters = (strend - s) + 10;
4984 I32 origlimit = limit;
4987 AV *oldstack = PL_curstack;
4988 I32 gimme = GIMME_V;
4989 I32 oldsave = PL_savestack_ix;
4990 I32 make_mortal = 1;
4991 MAGIC *mg = (MAGIC *) NULL;
4994 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4999 DIE(aTHX_ "panic: do_split");
5000 rx = pm->op_pmregexp;
5002 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5003 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5005 if (pm->op_pmreplroot) {
5007 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5009 ary = GvAVn((GV*)pm->op_pmreplroot);
5012 else if (gimme != G_ARRAY)
5014 ary = (AV*)PL_curpad[0];
5016 ary = GvAVn(PL_defgv);
5017 #endif /* USE_THREADS */
5020 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5026 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5028 XPUSHs(SvTIED_obj((SV*)ary, mg));
5034 for (i = AvFILLp(ary); i >= 0; i--)
5035 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5037 /* temporarily switch stacks */
5038 SWITCHSTACK(PL_curstack, ary);
5042 base = SP - PL_stack_base;
5044 if (pm->op_pmflags & PMf_SKIPWHITE) {
5045 if (pm->op_pmflags & PMf_LOCALE) {
5046 while (isSPACE_LC(*s))
5054 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5055 SAVEINT(PL_multiline);
5056 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5060 limit = maxiters + 2;
5061 if (pm->op_pmflags & PMf_WHITE) {
5064 while (m < strend &&
5065 !((pm->op_pmflags & PMf_LOCALE)
5066 ? isSPACE_LC(*m) : isSPACE(*m)))
5071 dstr = NEWSV(30, m-s);
5072 sv_setpvn(dstr, s, m-s);
5078 while (s < strend &&
5079 ((pm->op_pmflags & PMf_LOCALE)
5080 ? isSPACE_LC(*s) : isSPACE(*s)))
5084 else if (strEQ("^", rx->precomp)) {
5087 for (m = s; m < strend && *m != '\n'; m++) ;
5091 dstr = NEWSV(30, m-s);
5092 sv_setpvn(dstr, s, m-s);
5099 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5100 && (rx->reganch & ROPT_CHECK_ALL)
5101 && !(rx->reganch & ROPT_ANCH)) {
5102 int tail = (rx->reganch & RE_INTUIT_TAIL);
5103 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5107 if (len == 1 && !tail) {
5111 for (m = s; m < strend && *m != c; m++) ;
5114 dstr = NEWSV(30, m-s);
5115 sv_setpvn(dstr, s, m-s);
5124 while (s < strend && --limit &&
5125 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5126 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5129 dstr = NEWSV(31, m-s);
5130 sv_setpvn(dstr, s, m-s);
5134 s = m + len; /* Fake \n at the end */
5139 maxiters += (strend - s) * rx->nparens;
5140 while (s < strend && --limit
5141 /* && (!rx->check_substr
5142 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5144 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5145 1 /* minend */, sv, NULL, 0))
5147 TAINT_IF(RX_MATCH_TAINTED(rx));
5148 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5153 strend = s + (strend - m);
5155 m = rx->startp[0] + orig;
5156 dstr = NEWSV(32, m-s);
5157 sv_setpvn(dstr, s, m-s);
5162 for (i = 1; i <= rx->nparens; i++) {
5163 s = rx->startp[i] + orig;
5164 m = rx->endp[i] + orig;
5166 dstr = NEWSV(33, m-s);
5167 sv_setpvn(dstr, s, m-s);
5170 dstr = NEWSV(33, 0);
5176 s = rx->endp[0] + orig;
5180 LEAVE_SCOPE(oldsave);
5181 iters = (SP - PL_stack_base) - base;
5182 if (iters > maxiters)
5183 DIE(aTHX_ "Split loop");
5185 /* keep field after final delim? */
5186 if (s < strend || (iters && origlimit)) {
5187 dstr = NEWSV(34, strend-s);
5188 sv_setpvn(dstr, s, strend-s);
5194 else if (!origlimit) {
5195 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5201 SWITCHSTACK(ary, oldstack);
5202 if (SvSMAGICAL(ary)) {
5207 if (gimme == G_ARRAY) {
5209 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5217 call_method("PUSH",G_SCALAR|G_DISCARD);
5220 if (gimme == G_ARRAY) {
5221 /* EXTEND should not be needed - we just popped them */
5223 for (i=0; i < iters; i++) {
5224 SV **svp = av_fetch(ary, i, FALSE);
5225 PUSHs((svp) ? *svp : &PL_sv_undef);
5232 if (gimme == G_ARRAY)
5235 if (iters || !pm->op_pmreplroot) {
5245 Perl_unlock_condpair(pTHX_ void *svv)
5248 MAGIC *mg = mg_find((SV*)svv, 'm');
5251 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5252 MUTEX_LOCK(MgMUTEXP(mg));
5253 if (MgOWNER(mg) != thr)
5254 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5256 COND_SIGNAL(MgOWNERCONDP(mg));
5257 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5258 PTR2UV(thr), PTR2UV(svv));)
5259 MUTEX_UNLOCK(MgMUTEXP(mg));
5261 #endif /* USE_THREADS */
5270 #endif /* USE_THREADS */
5271 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5272 || SvTYPE(retsv) == SVt_PVCV) {
5273 retsv = refto(retsv);
5284 if (PL_op->op_private & OPpLVAL_INTRO)
5285 PUSHs(*save_threadsv(PL_op->op_targ));
5287 PUSHs(THREADSV(PL_op->op_targ));
5290 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5291 #endif /* USE_THREADS */