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);
604 if (strEQ(elem, "GLOB"))
608 if (strEQ(elem, "HASH"))
609 tmpRef = (SV*)GvHV(gv);
612 if (strEQ(elem, "IO"))
613 tmpRef = (SV*)GvIOp(gv);
616 if (strEQ(elem, "NAME"))
617 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
620 if (strEQ(elem, "PACKAGE"))
621 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
624 if (strEQ(elem, "SCALAR"))
638 /* Pattern matching */
643 register unsigned char *s;
646 register I32 *sfirst;
650 if (sv == PL_lastscream) {
656 SvSCREAM_off(PL_lastscream);
657 SvREFCNT_dec(PL_lastscream);
659 PL_lastscream = SvREFCNT_inc(sv);
662 s = (unsigned char*)(SvPV(sv, len));
666 if (pos > PL_maxscream) {
667 if (PL_maxscream < 0) {
668 PL_maxscream = pos + 80;
669 New(301, PL_screamfirst, 256, I32);
670 New(302, PL_screamnext, PL_maxscream, I32);
673 PL_maxscream = pos + pos / 4;
674 Renew(PL_screamnext, PL_maxscream, I32);
678 sfirst = PL_screamfirst;
679 snext = PL_screamnext;
681 if (!sfirst || !snext)
682 DIE(aTHX_ "do_study: out of memory");
684 for (ch = 256; ch; --ch)
691 snext[pos] = sfirst[ch] - pos;
698 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
707 if (PL_op->op_flags & OPf_STACKED)
713 TARG = sv_newmortal();
718 /* Lvalue operators. */
730 djSP; dMARK; dTARGET;
740 SETi(do_chomp(TOPs));
746 djSP; dMARK; dTARGET;
747 register I32 count = 0;
750 count += do_chomp(POPs);
761 if (!sv || !SvANY(sv))
763 switch (SvTYPE(sv)) {
765 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
769 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
773 if (CvROOT(sv) || CvXSUB(sv))
790 if (!PL_op->op_private) {
799 if (SvTHINKFIRST(sv))
802 switch (SvTYPE(sv)) {
812 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
813 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
814 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
818 /* let user-undef'd sub keep its identity */
819 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
826 SvSetMagicSV(sv, &PL_sv_undef);
830 Newz(602, gp, 1, GP);
831 GvGP(sv) = gp_ref(gp);
832 GvSV(sv) = NEWSV(72,0);
833 GvLINE(sv) = CopLINE(PL_curcop);
839 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
842 SvPV_set(sv, Nullch);
855 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
856 DIE(aTHX_ PL_no_modify);
857 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
858 SvIVX(TOPs) != IV_MIN)
861 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
873 DIE(aTHX_ PL_no_modify);
874 sv_setsv(TARG, TOPs);
875 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
876 SvIVX(TOPs) != IV_MAX)
879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
893 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
894 DIE(aTHX_ PL_no_modify);
895 sv_setsv(TARG, TOPs);
896 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
897 SvIVX(TOPs) != IV_MIN)
900 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
909 /* Ordinary operators. */
913 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
916 SETn( Perl_pow( left, right) );
923 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
926 SETn( left * right );
933 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
938 DIE(aTHX_ "Illegal division by zero");
940 /* insure that 20./5. == 4. */
943 if ((NV)I_V(left) == left &&
944 (NV)I_V(right) == right &&
945 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
949 value = left / right;
953 value = left / right;
962 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
972 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
974 right = (right_neg = (i < 0)) ? -i : i;
979 right_neg = dright < 0;
984 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
986 left = (left_neg = (i < 0)) ? -i : i;
994 left_neg = dleft < 0;
1003 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1005 # define CAST_D2UV(d) U_V(d)
1007 # define CAST_D2UV(d) ((UV)(d))
1009 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1010 * or, in other words, precision of UV more than of NV.
1011 * But in fact the approach below turned out to be an
1012 * optimization - floor() may be slow */
1013 if (dright <= UV_MAX && dleft <= UV_MAX) {
1014 right = CAST_D2UV(dright);
1015 left = CAST_D2UV(dleft);
1020 /* Backward-compatibility clause: */
1021 dright = Perl_floor(dright + 0.5);
1022 dleft = Perl_floor(dleft + 0.5);
1025 DIE(aTHX_ "Illegal modulus zero");
1027 dans = Perl_fmod(dleft, dright);
1028 if ((left_neg != right_neg) && dans)
1029 dans = dright - dans;
1032 sv_setnv(TARG, dans);
1039 DIE(aTHX_ "Illegal modulus zero");
1042 if ((left_neg != right_neg) && ans)
1045 /* XXX may warn: unary minus operator applied to unsigned type */
1046 /* could change -foo to be (~foo)+1 instead */
1047 if (ans <= ~((UV)IV_MAX)+1)
1048 sv_setiv(TARG, ~ans+1);
1050 sv_setnv(TARG, -(NV)ans);
1053 sv_setuv(TARG, ans);
1062 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1064 register I32 count = POPi;
1065 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1067 I32 items = SP - MARK;
1070 max = items * count;
1079 repeatcpy((char*)(MARK + items), (char*)MARK,
1080 items * sizeof(SV*), count - 1);
1083 else if (count <= 0)
1086 else { /* Note: mark already snarfed by pp_list */
1089 bool isutf = DO_UTF8(tmpstr);
1091 SvSetSV(TARG, tmpstr);
1092 SvPV_force(TARG, len);
1097 SvGROW(TARG, (count * len) + 1);
1098 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1099 SvCUR(TARG) *= count;
1101 *SvEND(TARG) = '\0';
1104 (void)SvPOK_only_UTF8(TARG);
1106 (void)SvPOK_only(TARG);
1115 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1118 SETn( left - right );
1125 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1128 if (PL_op->op_private & HINT_INTEGER) {
1142 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1145 if (PL_op->op_private & HINT_INTEGER) {
1159 djSP; tryAMAGICbinSET(lt,0);
1162 SETs(boolSV(TOPn < value));
1169 djSP; tryAMAGICbinSET(gt,0);
1172 SETs(boolSV(TOPn > value));
1179 djSP; tryAMAGICbinSET(le,0);
1182 SETs(boolSV(TOPn <= value));
1189 djSP; tryAMAGICbinSET(ge,0);
1192 SETs(boolSV(TOPn >= value));
1199 djSP; tryAMAGICbinSET(ne,0);
1202 SETs(boolSV(TOPn != value));
1209 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1215 if (Perl_isnan(left) || Perl_isnan(right)) {
1219 value = (left > right) - (left < right);
1223 else if (left < right)
1225 else if (left > right)
1239 djSP; tryAMAGICbinSET(slt,0);
1242 int cmp = ((PL_op->op_private & OPpLOCALE)
1243 ? sv_cmp_locale(left, right)
1244 : sv_cmp(left, right));
1245 SETs(boolSV(cmp < 0));
1252 djSP; tryAMAGICbinSET(sgt,0);
1255 int cmp = ((PL_op->op_private & OPpLOCALE)
1256 ? sv_cmp_locale(left, right)
1257 : sv_cmp(left, right));
1258 SETs(boolSV(cmp > 0));
1265 djSP; tryAMAGICbinSET(sle,0);
1268 int cmp = ((PL_op->op_private & OPpLOCALE)
1269 ? sv_cmp_locale(left, right)
1270 : sv_cmp(left, right));
1271 SETs(boolSV(cmp <= 0));
1278 djSP; tryAMAGICbinSET(sge,0);
1281 int cmp = ((PL_op->op_private & OPpLOCALE)
1282 ? sv_cmp_locale(left, right)
1283 : sv_cmp(left, right));
1284 SETs(boolSV(cmp >= 0));
1291 djSP; tryAMAGICbinSET(seq,0);
1294 SETs(boolSV(sv_eq(left, right)));
1301 djSP; tryAMAGICbinSET(sne,0);
1304 SETs(boolSV(!sv_eq(left, right)));
1311 djSP; dTARGET; tryAMAGICbin(scmp,0);
1314 int cmp = ((PL_op->op_private & OPpLOCALE)
1315 ? sv_cmp_locale(left, right)
1316 : sv_cmp(left, right));
1324 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1327 if (SvNIOKp(left) || SvNIOKp(right)) {
1328 if (PL_op->op_private & HINT_INTEGER) {
1329 IV i = SvIV(left) & SvIV(right);
1333 UV u = SvUV(left) & SvUV(right);
1338 do_vop(PL_op->op_type, TARG, left, right);
1347 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1350 if (SvNIOKp(left) || SvNIOKp(right)) {
1351 if (PL_op->op_private & HINT_INTEGER) {
1352 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1356 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1361 do_vop(PL_op->op_type, TARG, left, right);
1370 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1373 if (SvNIOKp(left) || SvNIOKp(right)) {
1374 if (PL_op->op_private & HINT_INTEGER) {
1375 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1379 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1384 do_vop(PL_op->op_type, TARG, left, right);
1393 djSP; dTARGET; tryAMAGICun(neg);
1398 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1400 if (SvIVX(sv) == IV_MIN) {
1401 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1404 else if (SvUVX(sv) <= IV_MAX) {
1409 else if (SvIVX(sv) != IV_MIN) {
1416 else if (SvPOKp(sv)) {
1418 char *s = SvPV(sv, len);
1419 if (isIDFIRST(*s)) {
1420 sv_setpvn(TARG, "-", 1);
1423 else if (*s == '+' || *s == '-') {
1425 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1427 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1428 sv_setpvn(TARG, "-", 1);
1432 sv_setnv(TARG, -SvNV(sv));
1443 djSP; tryAMAGICunSET(not);
1444 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1450 djSP; dTARGET; tryAMAGICun(compl);
1454 if (PL_op->op_private & HINT_INTEGER) {
1464 register char *tmps;
1465 register long *tmpl;
1470 tmps = SvPV_force(TARG, len);
1473 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1476 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1480 for ( ; anum > 0; anum--, tmps++)
1489 /* integer versions of some of the above */
1493 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1496 SETi( left * right );
1503 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1507 DIE(aTHX_ "Illegal division by zero");
1508 value = POPi / value;
1516 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1520 DIE(aTHX_ "Illegal modulus zero");
1521 SETi( left % right );
1528 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1531 SETi( left + right );
1538 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1541 SETi( left - right );
1548 djSP; tryAMAGICbinSET(lt,0);
1551 SETs(boolSV(left < right));
1558 djSP; tryAMAGICbinSET(gt,0);
1561 SETs(boolSV(left > right));
1568 djSP; tryAMAGICbinSET(le,0);
1571 SETs(boolSV(left <= right));
1578 djSP; tryAMAGICbinSET(ge,0);
1581 SETs(boolSV(left >= right));
1588 djSP; tryAMAGICbinSET(eq,0);
1591 SETs(boolSV(left == right));
1598 djSP; tryAMAGICbinSET(ne,0);
1601 SETs(boolSV(left != right));
1608 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1615 else if (left < right)
1626 djSP; dTARGET; tryAMAGICun(neg);
1631 /* High falutin' math. */
1635 djSP; dTARGET; tryAMAGICbin(atan2,0);
1638 SETn(Perl_atan2(left, right));
1645 djSP; dTARGET; tryAMAGICun(sin);
1649 value = Perl_sin(value);
1657 djSP; dTARGET; tryAMAGICun(cos);
1661 value = Perl_cos(value);
1667 /* Support Configure command-line overrides for rand() functions.
1668 After 5.005, perhaps we should replace this by Configure support
1669 for drand48(), random(), or rand(). For 5.005, though, maintain
1670 compatibility by calling rand() but allow the user to override it.
1671 See INSTALL for details. --Andy Dougherty 15 July 1998
1673 /* Now it's after 5.005, and Configure supports drand48() and random(),
1674 in addition to rand(). So the overrides should not be needed any more.
1675 --Jarkko Hietaniemi 27 September 1998
1678 #ifndef HAS_DRAND48_PROTO
1679 extern double drand48 (void);
1692 if (!PL_srand_called) {
1693 (void)seedDrand01((Rand_seed_t)seed());
1694 PL_srand_called = TRUE;
1709 (void)seedDrand01((Rand_seed_t)anum);
1710 PL_srand_called = TRUE;
1719 * This is really just a quick hack which grabs various garbage
1720 * values. It really should be a real hash algorithm which
1721 * spreads the effect of every input bit onto every output bit,
1722 * if someone who knows about such things would bother to write it.
1723 * Might be a good idea to add that function to CORE as well.
1724 * No numbers below come from careful analysis or anything here,
1725 * except they are primes and SEED_C1 > 1E6 to get a full-width
1726 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1727 * probably be bigger too.
1730 # define SEED_C1 1000003
1731 #define SEED_C4 73819
1733 # define SEED_C1 25747
1734 #define SEED_C4 20639
1738 #define SEED_C5 26107
1741 #ifndef PERL_NO_DEV_RANDOM
1746 # include <starlet.h>
1747 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1748 * in 100-ns units, typically incremented ever 10 ms. */
1749 unsigned int when[2];
1751 # ifdef HAS_GETTIMEOFDAY
1752 struct timeval when;
1758 /* This test is an escape hatch, this symbol isn't set by Configure. */
1759 #ifndef PERL_NO_DEV_RANDOM
1760 #ifndef PERL_RANDOM_DEVICE
1761 /* /dev/random isn't used by default because reads from it will block
1762 * if there isn't enough entropy available. You can compile with
1763 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1764 * is enough real entropy to fill the seed. */
1765 # define PERL_RANDOM_DEVICE "/dev/urandom"
1767 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1769 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1778 _ckvmssts(sys$gettim(when));
1779 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1781 # ifdef HAS_GETTIMEOFDAY
1782 gettimeofday(&when,(struct timezone *) 0);
1783 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1786 u = (U32)SEED_C1 * when;
1789 u += SEED_C3 * (U32)PerlProc_getpid();
1790 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1791 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1792 u += SEED_C5 * (U32)PTR2UV(&when);
1799 djSP; dTARGET; tryAMAGICun(exp);
1803 value = Perl_exp(value);
1811 djSP; dTARGET; tryAMAGICun(log);
1816 RESTORE_NUMERIC_STANDARD();
1817 DIE(aTHX_ "Can't take log of %g", value);
1819 value = Perl_log(value);
1827 djSP; dTARGET; tryAMAGICun(sqrt);
1832 RESTORE_NUMERIC_STANDARD();
1833 DIE(aTHX_ "Can't take sqrt of %g", value);
1835 value = Perl_sqrt(value);
1848 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1854 (void)Perl_modf(value, &value);
1856 (void)Perl_modf(-value, &value);
1871 djSP; dTARGET; tryAMAGICun(abs);
1876 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1877 (iv = SvIVX(TOPs)) != IV_MIN) {
1899 argtype = 1; /* allow underscores */
1900 XPUSHn(scan_hex(tmps, 99, &argtype));
1913 while (*tmps && isSPACE(*tmps))
1917 argtype = 1; /* allow underscores */
1919 value = scan_hex(++tmps, 99, &argtype);
1920 else if (*tmps == 'b')
1921 value = scan_bin(++tmps, 99, &argtype);
1923 value = scan_oct(tmps, 99, &argtype);
1936 SETi(sv_len_utf8(sv));
1952 I32 lvalue = PL_op->op_flags & OPf_MOD;
1954 I32 arybase = PL_curcop->cop_arybase;
1958 SvTAINTED_off(TARG); /* decontaminate */
1959 SvUTF8_off(TARG); /* decontaminate */
1963 repl = SvPV(sv, repl_len);
1970 tmps = SvPV(sv, curlen);
1972 utfcurlen = sv_len_utf8(sv);
1973 if (utfcurlen == curlen)
1981 if (pos >= arybase) {
1999 else if (len >= 0) {
2001 if (rem > (I32)curlen)
2016 Perl_croak(aTHX_ "substr outside of string");
2017 if (ckWARN(WARN_SUBSTR))
2018 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2023 sv_pos_u2b(sv, &pos, &rem);
2025 sv_setpvn(TARG, tmps, rem);
2029 sv_insert(sv, pos, rem, repl, repl_len);
2030 else if (lvalue) { /* it's an lvalue! */
2031 if (!SvGMAGICAL(sv)) {
2035 if (ckWARN(WARN_SUBSTR))
2036 Perl_warner(aTHX_ WARN_SUBSTR,
2037 "Attempt to use reference as lvalue in substr");
2039 if (SvOK(sv)) /* is it defined ? */
2040 (void)SvPOK_only_UTF8(sv);
2042 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2045 if (SvTYPE(TARG) < SVt_PVLV) {
2046 sv_upgrade(TARG, SVt_PVLV);
2047 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2051 if (LvTARG(TARG) != sv) {
2053 SvREFCNT_dec(LvTARG(TARG));
2054 LvTARG(TARG) = SvREFCNT_inc(sv);
2056 LvTARGOFF(TARG) = pos;
2057 LvTARGLEN(TARG) = rem;
2061 PUSHs(TARG); /* avoid SvSETMAGIC here */
2068 register I32 size = POPi;
2069 register I32 offset = POPi;
2070 register SV *src = POPs;
2071 I32 lvalue = PL_op->op_flags & OPf_MOD;
2073 SvTAINTED_off(TARG); /* decontaminate */
2074 if (lvalue) { /* it's an lvalue! */
2075 if (SvTYPE(TARG) < SVt_PVLV) {
2076 sv_upgrade(TARG, SVt_PVLV);
2077 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2080 if (LvTARG(TARG) != src) {
2082 SvREFCNT_dec(LvTARG(TARG));
2083 LvTARG(TARG) = SvREFCNT_inc(src);
2085 LvTARGOFF(TARG) = offset;
2086 LvTARGLEN(TARG) = size;
2089 sv_setuv(TARG, do_vecget(src, offset, size));
2104 I32 arybase = PL_curcop->cop_arybase;
2109 offset = POPi - arybase;
2112 tmps = SvPV(big, biglen);
2113 if (offset > 0 && DO_UTF8(big))
2114 sv_pos_u2b(big, &offset, 0);
2117 else if (offset > biglen)
2119 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2120 (unsigned char*)tmps + biglen, little, 0)))
2123 retval = tmps2 - tmps;
2124 if (retval > 0 && DO_UTF8(big))
2125 sv_pos_b2u(big, &retval);
2126 PUSHi(retval + arybase);
2141 I32 arybase = PL_curcop->cop_arybase;
2147 tmps2 = SvPV(little, llen);
2148 tmps = SvPV(big, blen);
2152 if (offset > 0 && DO_UTF8(big))
2153 sv_pos_u2b(big, &offset, 0);
2154 offset = offset - arybase + llen;
2158 else if (offset > blen)
2160 if (!(tmps2 = rninstr(tmps, tmps + offset,
2161 tmps2, tmps2 + llen)))
2164 retval = tmps2 - tmps;
2165 if (retval > 0 && DO_UTF8(big))
2166 sv_pos_b2u(big, &retval);
2167 PUSHi(retval + arybase);
2173 djSP; dMARK; dORIGMARK; dTARGET;
2174 do_sprintf(TARG, SP-MARK, MARK+1);
2175 TAINT_IF(SvTAINTED(TARG));
2187 U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
2190 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2191 value = utf8_to_uv(tmps, &retlen);
2193 value = (UV)(*tmps & 255);
2204 (void)SvUPGRADE(TARG,SVt_PV);
2206 if (value > 255 && !IN_BYTE) {
2207 SvGROW(TARG, UTF8_MAXLEN+1);
2209 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2210 SvCUR_set(TARG, tmps - SvPVX(TARG));
2212 (void)SvPOK_only(TARG);
2223 (void)SvPOK_only(TARG);
2230 djSP; dTARGET; dPOPTOPssrl;
2233 char *tmps = SvPV(left, n_a);
2235 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2237 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2241 "The crypt() function is unimplemented due to excessive paranoia.");
2254 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2256 U8 tmpbuf[UTF8_MAXLEN];
2258 UV uv = utf8_to_uv(s, &ulen);
2260 if (PL_op->op_private & OPpLOCALE) {
2263 uv = toTITLE_LC_uni(uv);
2266 uv = toTITLE_utf8(s);
2268 tend = uv_to_utf8(tmpbuf, uv);
2270 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2272 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2273 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2278 s = (U8*)SvPV_force(sv, slen);
2279 Copy(tmpbuf, s, ulen, U8);
2283 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2285 SvUTF8_off(TARG); /* decontaminate */
2290 s = (U8*)SvPV_force(sv, slen);
2292 if (PL_op->op_private & OPpLOCALE) {
2295 *s = toUPPER_LC(*s);
2313 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2315 U8 tmpbuf[UTF8_MAXLEN];
2317 UV uv = utf8_to_uv(s, &ulen);
2319 if (PL_op->op_private & OPpLOCALE) {
2322 uv = toLOWER_LC_uni(uv);
2325 uv = toLOWER_utf8(s);
2327 tend = uv_to_utf8(tmpbuf, uv);
2329 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2331 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2332 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2337 s = (U8*)SvPV_force(sv, slen);
2338 Copy(tmpbuf, s, ulen, U8);
2342 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2344 SvUTF8_off(TARG); /* decontaminate */
2349 s = (U8*)SvPV_force(sv, slen);
2351 if (PL_op->op_private & OPpLOCALE) {
2354 *s = toLOWER_LC(*s);
2378 s = (U8*)SvPV(sv,len);
2380 SvUTF8_off(TARG); /* decontaminate */
2381 sv_setpvn(TARG, "", 0);
2385 (void)SvUPGRADE(TARG, SVt_PV);
2386 SvGROW(TARG, (len * 2) + 1);
2387 (void)SvPOK_only(TARG);
2388 d = (U8*)SvPVX(TARG);
2390 if (PL_op->op_private & OPpLOCALE) {
2394 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2400 d = uv_to_utf8(d, toUPPER_utf8( s ));
2406 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2411 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2413 SvUTF8_off(TARG); /* decontaminate */
2418 s = (U8*)SvPV_force(sv, len);
2420 register U8 *send = s + len;
2422 if (PL_op->op_private & OPpLOCALE) {
2425 for (; s < send; s++)
2426 *s = toUPPER_LC(*s);
2429 for (; s < send; s++)
2452 s = (U8*)SvPV(sv,len);
2454 SvUTF8_off(TARG); /* decontaminate */
2455 sv_setpvn(TARG, "", 0);
2459 (void)SvUPGRADE(TARG, SVt_PV);
2460 SvGROW(TARG, (len * 2) + 1);
2461 (void)SvPOK_only(TARG);
2462 d = (U8*)SvPVX(TARG);
2464 if (PL_op->op_private & OPpLOCALE) {
2468 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2474 d = uv_to_utf8(d, toLOWER_utf8(s));
2480 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2485 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2487 SvUTF8_off(TARG); /* decontaminate */
2493 s = (U8*)SvPV_force(sv, len);
2495 register U8 *send = s + len;
2497 if (PL_op->op_private & OPpLOCALE) {
2500 for (; s < send; s++)
2501 *s = toLOWER_LC(*s);
2504 for (; s < send; s++)
2519 register char *s = SvPV(sv,len);
2522 SvUTF8_off(TARG); /* decontaminate */
2524 (void)SvUPGRADE(TARG, SVt_PV);
2525 SvGROW(TARG, (len * 2) + 1);
2530 STRLEN ulen = UTF8SKIP(s);
2554 SvCUR_set(TARG, d - SvPVX(TARG));
2555 (void)SvPOK_only_UTF8(TARG);
2558 sv_setpvn(TARG, s, len);
2560 if (SvSMAGICAL(TARG))
2569 djSP; dMARK; dORIGMARK;
2571 register AV* av = (AV*)POPs;
2572 register I32 lval = PL_op->op_flags & OPf_MOD;
2573 I32 arybase = PL_curcop->cop_arybase;
2576 if (SvTYPE(av) == SVt_PVAV) {
2577 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2579 for (svp = MARK + 1; svp <= SP; svp++) {
2584 if (max > AvMAX(av))
2587 while (++MARK <= SP) {
2588 elem = SvIVx(*MARK);
2592 svp = av_fetch(av, elem, lval);
2594 if (!svp || *svp == &PL_sv_undef)
2595 DIE(aTHX_ PL_no_aelem, elem);
2596 if (PL_op->op_private & OPpLVAL_INTRO)
2597 save_aelem(av, elem, svp);
2599 *MARK = svp ? *svp : &PL_sv_undef;
2602 if (GIMME != G_ARRAY) {
2610 /* Associative arrays. */
2615 HV *hash = (HV*)POPs;
2617 I32 gimme = GIMME_V;
2618 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2621 /* might clobber stack_sp */
2622 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2627 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2628 if (gimme == G_ARRAY) {
2631 /* might clobber stack_sp */
2633 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2638 else if (gimme == G_SCALAR)
2657 I32 gimme = GIMME_V;
2658 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2662 if (PL_op->op_private & OPpSLICE) {
2666 hvtype = SvTYPE(hv);
2667 if (hvtype == SVt_PVHV) { /* hash element */
2668 while (++MARK <= SP) {
2669 sv = hv_delete_ent(hv, *MARK, discard, 0);
2670 *MARK = sv ? sv : &PL_sv_undef;
2673 else if (hvtype == SVt_PVAV) {
2674 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2675 while (++MARK <= SP) {
2676 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2677 *MARK = sv ? sv : &PL_sv_undef;
2680 else { /* pseudo-hash element */
2681 while (++MARK <= SP) {
2682 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2683 *MARK = sv ? sv : &PL_sv_undef;
2688 DIE(aTHX_ "Not a HASH reference");
2691 else if (gimme == G_SCALAR) {
2700 if (SvTYPE(hv) == SVt_PVHV)
2701 sv = hv_delete_ent(hv, keysv, discard, 0);
2702 else if (SvTYPE(hv) == SVt_PVAV) {
2703 if (PL_op->op_flags & OPf_SPECIAL)
2704 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2706 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2709 DIE(aTHX_ "Not a HASH reference");
2724 if (PL_op->op_private & OPpEXISTS_SUB) {
2728 cv = sv_2cv(sv, &hv, &gv, FALSE);
2731 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2737 if (SvTYPE(hv) == SVt_PVHV) {
2738 if (hv_exists_ent(hv, tmpsv, 0))
2741 else if (SvTYPE(hv) == SVt_PVAV) {
2742 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2743 if (av_exists((AV*)hv, SvIV(tmpsv)))
2746 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2750 DIE(aTHX_ "Not a HASH reference");
2757 djSP; dMARK; dORIGMARK;
2758 register HV *hv = (HV*)POPs;
2759 register I32 lval = PL_op->op_flags & OPf_MOD;
2760 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2762 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2763 DIE(aTHX_ "Can't localize pseudo-hash element");
2765 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2766 while (++MARK <= SP) {
2770 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2771 svp = he ? &HeVAL(he) : 0;
2774 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2777 if (!svp || *svp == &PL_sv_undef) {
2779 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2781 if (PL_op->op_private & OPpLVAL_INTRO)
2782 save_helem(hv, keysv, svp);
2784 *MARK = svp ? *svp : &PL_sv_undef;
2787 if (GIMME != G_ARRAY) {
2795 /* List operators. */
2800 if (GIMME != G_ARRAY) {
2802 *MARK = *SP; /* unwanted list, return last item */
2804 *MARK = &PL_sv_undef;
2813 SV **lastrelem = PL_stack_sp;
2814 SV **lastlelem = PL_stack_base + POPMARK;
2815 SV **firstlelem = PL_stack_base + POPMARK + 1;
2816 register SV **firstrelem = lastlelem + 1;
2817 I32 arybase = PL_curcop->cop_arybase;
2818 I32 lval = PL_op->op_flags & OPf_MOD;
2819 I32 is_something_there = lval;
2821 register I32 max = lastrelem - lastlelem;
2822 register SV **lelem;
2825 if (GIMME != G_ARRAY) {
2826 ix = SvIVx(*lastlelem);
2831 if (ix < 0 || ix >= max)
2832 *firstlelem = &PL_sv_undef;
2834 *firstlelem = firstrelem[ix];
2840 SP = firstlelem - 1;
2844 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2850 if (ix < 0 || ix >= max)
2851 *lelem = &PL_sv_undef;
2853 is_something_there = TRUE;
2854 if (!(*lelem = firstrelem[ix]))
2855 *lelem = &PL_sv_undef;
2858 if (is_something_there)
2861 SP = firstlelem - 1;
2867 djSP; dMARK; dORIGMARK;
2868 I32 items = SP - MARK;
2869 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2870 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2877 djSP; dMARK; dORIGMARK;
2878 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2882 SV *val = NEWSV(46, 0);
2884 sv_setsv(val, *++MARK);
2885 else if (ckWARN(WARN_MISC))
2886 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2887 (void)hv_store_ent(hv,key,val,0);
2896 djSP; dMARK; dORIGMARK;
2897 register AV *ary = (AV*)*++MARK;
2901 register I32 offset;
2902 register I32 length;
2909 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2910 *MARK-- = SvTIED_obj((SV*)ary, mg);
2914 call_method("SPLICE",GIMME_V);
2923 offset = i = SvIVx(*MARK);
2925 offset += AvFILLp(ary) + 1;
2927 offset -= PL_curcop->cop_arybase;
2929 DIE(aTHX_ PL_no_aelem, i);
2931 length = SvIVx(*MARK++);
2933 length += AvFILLp(ary) - offset + 1;
2939 length = AvMAX(ary) + 1; /* close enough to infinity */
2943 length = AvMAX(ary) + 1;
2945 if (offset > AvFILLp(ary) + 1)
2946 offset = AvFILLp(ary) + 1;
2947 after = AvFILLp(ary) + 1 - (offset + length);
2948 if (after < 0) { /* not that much array */
2949 length += after; /* offset+length now in array */
2955 /* At this point, MARK .. SP-1 is our new LIST */
2958 diff = newlen - length;
2959 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2962 if (diff < 0) { /* shrinking the area */
2964 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2965 Copy(MARK, tmparyval, newlen, SV*);
2968 MARK = ORIGMARK + 1;
2969 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2970 MEXTEND(MARK, length);
2971 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2973 EXTEND_MORTAL(length);
2974 for (i = length, dst = MARK; i; i--) {
2975 sv_2mortal(*dst); /* free them eventualy */
2982 *MARK = AvARRAY(ary)[offset+length-1];
2985 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2986 SvREFCNT_dec(*dst++); /* free them now */
2989 AvFILLp(ary) += diff;
2991 /* pull up or down? */
2993 if (offset < after) { /* easier to pull up */
2994 if (offset) { /* esp. if nothing to pull */
2995 src = &AvARRAY(ary)[offset-1];
2996 dst = src - diff; /* diff is negative */
2997 for (i = offset; i > 0; i--) /* can't trust Copy */
3001 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3005 if (after) { /* anything to pull down? */
3006 src = AvARRAY(ary) + offset + length;
3007 dst = src + diff; /* diff is negative */
3008 Move(src, dst, after, SV*);
3010 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3011 /* avoid later double free */
3015 dst[--i] = &PL_sv_undef;
3018 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3020 *dst = NEWSV(46, 0);
3021 sv_setsv(*dst++, *src++);
3023 Safefree(tmparyval);
3026 else { /* no, expanding (or same) */
3028 New(452, tmparyval, length, SV*); /* so remember deletion */
3029 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3032 if (diff > 0) { /* expanding */
3034 /* push up or down? */
3036 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3040 Move(src, dst, offset, SV*);
3042 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3044 AvFILLp(ary) += diff;
3047 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3048 av_extend(ary, AvFILLp(ary) + diff);
3049 AvFILLp(ary) += diff;
3052 dst = AvARRAY(ary) + AvFILLp(ary);
3054 for (i = after; i; i--) {
3061 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3062 *dst = NEWSV(46, 0);
3063 sv_setsv(*dst++, *src++);
3065 MARK = ORIGMARK + 1;
3066 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3068 Copy(tmparyval, MARK, length, SV*);
3070 EXTEND_MORTAL(length);
3071 for (i = length, dst = MARK; i; i--) {
3072 sv_2mortal(*dst); /* free them eventualy */
3076 Safefree(tmparyval);
3080 else if (length--) {
3081 *MARK = tmparyval[length];
3084 while (length-- > 0)
3085 SvREFCNT_dec(tmparyval[length]);
3087 Safefree(tmparyval);
3090 *MARK = &PL_sv_undef;
3098 djSP; dMARK; dORIGMARK; dTARGET;
3099 register AV *ary = (AV*)*++MARK;
3100 register SV *sv = &PL_sv_undef;
3103 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3104 *MARK-- = SvTIED_obj((SV*)ary, mg);
3108 call_method("PUSH",G_SCALAR|G_DISCARD);
3113 /* Why no pre-extend of ary here ? */
3114 for (++MARK; MARK <= SP; MARK++) {
3117 sv_setsv(sv, *MARK);
3122 PUSHi( AvFILL(ary) + 1 );
3130 SV *sv = av_pop(av);
3132 (void)sv_2mortal(sv);
3141 SV *sv = av_shift(av);
3146 (void)sv_2mortal(sv);
3153 djSP; dMARK; dORIGMARK; dTARGET;
3154 register AV *ary = (AV*)*++MARK;
3159 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3160 *MARK-- = SvTIED_obj((SV*)ary, mg);
3164 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3169 av_unshift(ary, SP - MARK);
3172 sv_setsv(sv, *++MARK);
3173 (void)av_store(ary, i++, sv);
3177 PUSHi( AvFILL(ary) + 1 );
3187 if (GIMME == G_ARRAY) {
3194 /* safe as long as stack cannot get extended in the above */
3199 register char *down;
3204 SvUTF8_off(TARG); /* decontaminate */
3206 do_join(TARG, &PL_sv_no, MARK, SP);
3208 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3209 up = SvPV_force(TARG, len);
3211 if (DO_UTF8(TARG)) { /* first reverse each character */
3212 U8* s = (U8*)SvPVX(TARG);
3213 U8* send = (U8*)(s + len);
3222 down = (char*)(s - 1);
3223 if (s > send || !((*down & 0xc0) == 0x80)) {
3224 if (ckWARN_d(WARN_UTF8))
3225 Perl_warner(aTHX_ WARN_UTF8,
3226 "Malformed UTF-8 character");
3238 down = SvPVX(TARG) + len - 1;
3244 (void)SvPOK_only_UTF8(TARG);
3253 S_mul128(pTHX_ SV *sv, U8 m)
3256 char *s = SvPV(sv, len);
3260 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3261 SV *tmpNew = newSVpvn("0000000000", 10);
3263 sv_catsv(tmpNew, sv);
3264 SvREFCNT_dec(sv); /* free old sv */
3269 while (!*t) /* trailing '\0'? */
3272 i = ((*t - '0') << 7) + m;
3273 *(t--) = '0' + (i % 10);
3279 /* Explosives and implosives. */
3281 #if 'I' == 73 && 'J' == 74
3282 /* On an ASCII/ISO kind of system */
3283 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3286 Some other sort of character set - use memchr() so we don't match
3289 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3296 I32 start_sp_offset = SP - PL_stack_base;
3297 I32 gimme = GIMME_V;
3301 register char *pat = SvPV(left, llen);
3302 register char *s = SvPV(right, rlen);
3303 char *strend = s + rlen;
3305 register char *patend = pat + llen;
3311 /* These must not be in registers: */
3328 register U32 culong;
3332 #ifdef PERL_NATINT_PACK
3333 int natint; /* native integer */
3334 int unatint; /* unsigned native integer */
3337 if (gimme != G_ARRAY) { /* arrange to do first one only */
3339 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3340 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3342 while (isDIGIT(*patend) || *patend == '*')
3348 while (pat < patend) {
3350 datumtype = *pat++ & 0xFF;
3351 #ifdef PERL_NATINT_PACK
3354 if (isSPACE(datumtype))
3356 if (datumtype == '#') {
3357 while (pat < patend && *pat != '\n')
3362 char *natstr = "sSiIlL";
3364 if (strchr(natstr, datumtype)) {
3365 #ifdef PERL_NATINT_PACK
3371 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3376 else if (*pat == '*') {
3377 len = strend - strbeg; /* long enough */
3381 else if (isDIGIT(*pat)) {
3383 while (isDIGIT(*pat)) {
3384 len = (len * 10) + (*pat++ - '0');
3386 DIE(aTHX_ "Repeat count in unpack overflows");
3390 len = (datumtype != '@');
3394 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3395 case ',': /* grandfather in commas but with a warning */
3396 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3397 Perl_warner(aTHX_ WARN_UNPACK,
3398 "Invalid type in unpack: '%c'", (int)datumtype);
3401 if (len == 1 && pat[-1] != '1')
3410 if (len > strend - strbeg)
3411 DIE(aTHX_ "@ outside of string");
3415 if (len > s - strbeg)
3416 DIE(aTHX_ "X outside of string");
3420 if (len > strend - s)
3421 DIE(aTHX_ "x outside of string");
3425 if (start_sp_offset >= SP - PL_stack_base)
3426 DIE(aTHX_ "/ must follow a numeric type");
3429 pat++; /* ignore '*' for compatibility with pack */
3431 DIE(aTHX_ "/ cannot take a count" );
3438 if (len > strend - s)
3441 goto uchar_checksum;
3442 sv = NEWSV(35, len);
3443 sv_setpvn(sv, s, len);
3445 if (datumtype == 'A' || datumtype == 'Z') {
3446 aptr = s; /* borrow register */
3447 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3452 else { /* 'A' strips both nulls and spaces */
3453 s = SvPVX(sv) + len - 1;
3454 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3458 SvCUR_set(sv, s - SvPVX(sv));
3459 s = aptr; /* unborrow register */
3461 XPUSHs(sv_2mortal(sv));
3465 if (star || len > (strend - s) * 8)
3466 len = (strend - s) * 8;
3469 Newz(601, PL_bitcount, 256, char);
3470 for (bits = 1; bits < 256; bits++) {
3471 if (bits & 1) PL_bitcount[bits]++;
3472 if (bits & 2) PL_bitcount[bits]++;
3473 if (bits & 4) PL_bitcount[bits]++;
3474 if (bits & 8) PL_bitcount[bits]++;
3475 if (bits & 16) PL_bitcount[bits]++;
3476 if (bits & 32) PL_bitcount[bits]++;
3477 if (bits & 64) PL_bitcount[bits]++;
3478 if (bits & 128) PL_bitcount[bits]++;
3482 culong += PL_bitcount[*(unsigned char*)s++];
3487 if (datumtype == 'b') {
3489 if (bits & 1) culong++;
3495 if (bits & 128) culong++;
3502 sv = NEWSV(35, len + 1);
3506 if (datumtype == 'b') {
3508 for (len = 0; len < aint; len++) {
3509 if (len & 7) /*SUPPRESS 595*/
3513 *str++ = '0' + (bits & 1);
3518 for (len = 0; len < aint; len++) {
3523 *str++ = '0' + ((bits & 128) != 0);
3527 XPUSHs(sv_2mortal(sv));
3531 if (star || len > (strend - s) * 2)
3532 len = (strend - s) * 2;
3533 sv = NEWSV(35, len + 1);
3537 if (datumtype == 'h') {
3539 for (len = 0; len < aint; len++) {
3544 *str++ = PL_hexdigit[bits & 15];
3549 for (len = 0; len < aint; len++) {
3554 *str++ = PL_hexdigit[(bits >> 4) & 15];
3558 XPUSHs(sv_2mortal(sv));
3561 if (len > strend - s)
3566 if (aint >= 128) /* fake up signed chars */
3576 if (aint >= 128) /* fake up signed chars */
3579 sv_setiv(sv, (IV)aint);
3580 PUSHs(sv_2mortal(sv));
3585 if (len > strend - s)
3600 sv_setiv(sv, (IV)auint);
3601 PUSHs(sv_2mortal(sv));
3606 if (len > strend - s)
3609 while (len-- > 0 && s < strend) {
3610 auint = utf8_to_uv((U8*)s, &along);
3613 cdouble += (NV)auint;
3621 while (len-- > 0 && s < strend) {
3622 auint = utf8_to_uv((U8*)s, &along);
3625 sv_setuv(sv, (UV)auint);
3626 PUSHs(sv_2mortal(sv));
3631 #if SHORTSIZE == SIZE16
3632 along = (strend - s) / SIZE16;
3634 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3639 #if SHORTSIZE != SIZE16
3643 COPYNN(s, &ashort, sizeof(short));
3654 #if SHORTSIZE > SIZE16
3666 #if SHORTSIZE != SIZE16
3670 COPYNN(s, &ashort, sizeof(short));
3673 sv_setiv(sv, (IV)ashort);
3674 PUSHs(sv_2mortal(sv));
3682 #if SHORTSIZE > SIZE16
3688 sv_setiv(sv, (IV)ashort);
3689 PUSHs(sv_2mortal(sv));
3697 #if SHORTSIZE == SIZE16
3698 along = (strend - s) / SIZE16;
3700 unatint = natint && datumtype == 'S';
3701 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3706 #if SHORTSIZE != SIZE16
3708 unsigned short aushort;
3710 COPYNN(s, &aushort, sizeof(unsigned short));
3711 s += sizeof(unsigned short);
3719 COPY16(s, &aushort);
3722 if (datumtype == 'n')
3723 aushort = PerlSock_ntohs(aushort);
3726 if (datumtype == 'v')
3727 aushort = vtohs(aushort);
3736 #if SHORTSIZE != SIZE16
3738 unsigned short aushort;
3740 COPYNN(s, &aushort, sizeof(unsigned short));
3741 s += sizeof(unsigned short);
3743 sv_setiv(sv, (UV)aushort);
3744 PUSHs(sv_2mortal(sv));
3751 COPY16(s, &aushort);
3755 if (datumtype == 'n')
3756 aushort = PerlSock_ntohs(aushort);
3759 if (datumtype == 'v')
3760 aushort = vtohs(aushort);
3762 sv_setiv(sv, (UV)aushort);
3763 PUSHs(sv_2mortal(sv));
3769 along = (strend - s) / sizeof(int);
3774 Copy(s, &aint, 1, int);
3777 cdouble += (NV)aint;
3786 Copy(s, &aint, 1, int);
3790 /* Without the dummy below unpack("i", pack("i",-1))
3791 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3792 * cc with optimization turned on.
3794 * The bug was detected in
3795 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3796 * with optimization (-O4) turned on.
3797 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3798 * does not have this problem even with -O4.
3800 * This bug was reported as DECC_BUGS 1431
3801 * and tracked internally as GEM_BUGS 7775.
3803 * The bug is fixed in
3804 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3805 * UNIX V4.0F support: DEC C V5.9-006 or later
3806 * UNIX V4.0E support: DEC C V5.8-011 or later
3809 * See also few lines later for the same bug.
3812 sv_setiv(sv, (IV)aint) :
3814 sv_setiv(sv, (IV)aint);
3815 PUSHs(sv_2mortal(sv));
3820 along = (strend - s) / sizeof(unsigned int);
3825 Copy(s, &auint, 1, unsigned int);
3826 s += sizeof(unsigned int);
3828 cdouble += (NV)auint;
3837 Copy(s, &auint, 1, unsigned int);
3838 s += sizeof(unsigned int);
3841 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3842 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3843 * See details few lines earlier. */
3845 sv_setuv(sv, (UV)auint) :
3847 sv_setuv(sv, (UV)auint);
3848 PUSHs(sv_2mortal(sv));
3853 #if LONGSIZE == SIZE32
3854 along = (strend - s) / SIZE32;
3856 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3861 #if LONGSIZE != SIZE32
3865 COPYNN(s, &along, sizeof(long));
3868 cdouble += (NV)along;
3878 #if LONGSIZE > SIZE32
3879 if (along > 2147483647)
3880 along -= 4294967296;
3884 cdouble += (NV)along;
3893 #if LONGSIZE != SIZE32
3897 COPYNN(s, &along, sizeof(long));
3900 sv_setiv(sv, (IV)along);
3901 PUSHs(sv_2mortal(sv));
3909 #if LONGSIZE > SIZE32
3910 if (along > 2147483647)
3911 along -= 4294967296;
3915 sv_setiv(sv, (IV)along);
3916 PUSHs(sv_2mortal(sv));
3924 #if LONGSIZE == SIZE32
3925 along = (strend - s) / SIZE32;
3927 unatint = natint && datumtype == 'L';
3928 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3933 #if LONGSIZE != SIZE32
3935 unsigned long aulong;
3937 COPYNN(s, &aulong, sizeof(unsigned long));
3938 s += sizeof(unsigned long);
3940 cdouble += (NV)aulong;
3952 if (datumtype == 'N')
3953 aulong = PerlSock_ntohl(aulong);
3956 if (datumtype == 'V')
3957 aulong = vtohl(aulong);
3960 cdouble += (NV)aulong;
3969 #if LONGSIZE != SIZE32
3971 unsigned long aulong;
3973 COPYNN(s, &aulong, sizeof(unsigned long));
3974 s += sizeof(unsigned long);
3976 sv_setuv(sv, (UV)aulong);
3977 PUSHs(sv_2mortal(sv));
3987 if (datumtype == 'N')
3988 aulong = PerlSock_ntohl(aulong);
3991 if (datumtype == 'V')
3992 aulong = vtohl(aulong);
3995 sv_setuv(sv, (UV)aulong);
3996 PUSHs(sv_2mortal(sv));
4002 along = (strend - s) / sizeof(char*);
4008 if (sizeof(char*) > strend - s)
4011 Copy(s, &aptr, 1, char*);
4017 PUSHs(sv_2mortal(sv));
4027 while ((len > 0) && (s < strend)) {
4028 auv = (auv << 7) | (*s & 0x7f);
4029 if (!(*s++ & 0x80)) {
4033 PUSHs(sv_2mortal(sv));
4037 else if (++bytes >= sizeof(UV)) { /* promote to string */
4041 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4042 while (s < strend) {
4043 sv = mul128(sv, *s & 0x7f);
4044 if (!(*s++ & 0x80)) {
4053 PUSHs(sv_2mortal(sv));
4058 if ((s >= strend) && bytes)
4059 DIE(aTHX_ "Unterminated compressed integer");
4064 if (sizeof(char*) > strend - s)
4067 Copy(s, &aptr, 1, char*);
4072 sv_setpvn(sv, aptr, len);
4073 PUSHs(sv_2mortal(sv));
4077 along = (strend - s) / sizeof(Quad_t);
4083 if (s + sizeof(Quad_t) > strend)
4086 Copy(s, &aquad, 1, Quad_t);
4087 s += sizeof(Quad_t);
4090 if (aquad >= IV_MIN && aquad <= IV_MAX)
4091 sv_setiv(sv, (IV)aquad);
4093 sv_setnv(sv, (NV)aquad);
4094 PUSHs(sv_2mortal(sv));
4098 along = (strend - s) / sizeof(Quad_t);
4104 if (s + sizeof(Uquad_t) > strend)
4107 Copy(s, &auquad, 1, Uquad_t);
4108 s += sizeof(Uquad_t);
4111 if (auquad <= UV_MAX)
4112 sv_setuv(sv, (UV)auquad);
4114 sv_setnv(sv, (NV)auquad);
4115 PUSHs(sv_2mortal(sv));
4119 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4122 along = (strend - s) / sizeof(float);
4127 Copy(s, &afloat, 1, float);
4136 Copy(s, &afloat, 1, float);
4139 sv_setnv(sv, (NV)afloat);
4140 PUSHs(sv_2mortal(sv));
4146 along = (strend - s) / sizeof(double);
4151 Copy(s, &adouble, 1, double);
4152 s += sizeof(double);
4160 Copy(s, &adouble, 1, double);
4161 s += sizeof(double);
4163 sv_setnv(sv, (NV)adouble);
4164 PUSHs(sv_2mortal(sv));
4170 * Initialise the decode mapping. By using a table driven
4171 * algorithm, the code will be character-set independent
4172 * (and just as fast as doing character arithmetic)
4174 if (PL_uudmap['M'] == 0) {
4177 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4178 PL_uudmap[(U8)PL_uuemap[i]] = i;
4180 * Because ' ' and '`' map to the same value,
4181 * we need to decode them both the same.
4186 along = (strend - s) * 3 / 4;
4187 sv = NEWSV(42, along);
4190 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4195 len = PL_uudmap[*(U8*)s++] & 077;
4197 if (s < strend && ISUUCHAR(*s))
4198 a = PL_uudmap[*(U8*)s++] & 077;
4201 if (s < strend && ISUUCHAR(*s))
4202 b = PL_uudmap[*(U8*)s++] & 077;
4205 if (s < strend && ISUUCHAR(*s))
4206 c = PL_uudmap[*(U8*)s++] & 077;
4209 if (s < strend && ISUUCHAR(*s))
4210 d = PL_uudmap[*(U8*)s++] & 077;
4213 hunk[0] = (a << 2) | (b >> 4);
4214 hunk[1] = (b << 4) | (c >> 2);
4215 hunk[2] = (c << 6) | d;
4216 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4221 else if (s[1] == '\n') /* possible checksum byte */
4224 XPUSHs(sv_2mortal(sv));
4229 if (strchr("fFdD", datumtype) ||
4230 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4234 while (checksum >= 16) {
4238 while (checksum >= 4) {
4244 along = (1 << checksum) - 1;
4245 while (cdouble < 0.0)
4247 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4248 sv_setnv(sv, cdouble);
4251 if (checksum < 32) {
4252 aulong = (1 << checksum) - 1;
4255 sv_setuv(sv, (UV)culong);
4257 XPUSHs(sv_2mortal(sv));
4261 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4262 PUSHs(&PL_sv_undef);
4267 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4271 *hunk = PL_uuemap[len];
4272 sv_catpvn(sv, hunk, 1);
4275 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4276 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4277 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4278 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4279 sv_catpvn(sv, hunk, 4);
4284 char r = (len > 1 ? s[1] : '\0');
4285 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4286 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4287 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4288 hunk[3] = PL_uuemap[0];
4289 sv_catpvn(sv, hunk, 4);
4291 sv_catpvn(sv, "\n", 1);
4295 S_is_an_int(pTHX_ char *s, STRLEN l)
4298 SV *result = newSVpvn(s, l);
4299 char *result_c = SvPV(result, n_a); /* convenience */
4300 char *out = result_c;
4310 SvREFCNT_dec(result);
4333 SvREFCNT_dec(result);
4339 SvCUR_set(result, out - result_c);
4343 /* pnum must be '\0' terminated */
4345 S_div128(pTHX_ SV *pnum, bool *done)
4348 char *s = SvPV(pnum, len);
4357 i = m * 10 + (*t - '0');
4359 r = (i >> 7); /* r < 10 */
4366 SvCUR_set(pnum, (STRLEN) (t - s));
4373 djSP; dMARK; dORIGMARK; dTARGET;
4374 register SV *cat = TARG;
4377 register char *pat = SvPVx(*++MARK, fromlen);
4379 register char *patend = pat + fromlen;
4384 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4385 static char *space10 = " ";
4387 /* These must not be in registers: */
4402 #ifdef PERL_NATINT_PACK
4403 int natint; /* native integer */
4408 sv_setpvn(cat, "", 0);
4410 while (pat < patend) {
4411 SV *lengthcode = Nullsv;
4412 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4413 datumtype = *pat++ & 0xFF;
4414 #ifdef PERL_NATINT_PACK
4417 if (isSPACE(datumtype)) {
4421 if (datumtype == 'U' && pat==patcopy+1)
4423 if (datumtype == '#') {
4424 while (pat < patend && *pat != '\n')
4429 char *natstr = "sSiIlL";
4431 if (strchr(natstr, datumtype)) {
4432 #ifdef PERL_NATINT_PACK
4438 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4441 len = strchr("@Xxu", datumtype) ? 0 : items;
4444 else if (isDIGIT(*pat)) {
4446 while (isDIGIT(*pat)) {
4447 len = (len * 10) + (*pat++ - '0');
4449 DIE(aTHX_ "Repeat count in pack overflows");
4456 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4457 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4458 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4459 ? *MARK : &PL_sv_no)
4460 + (*pat == 'Z' ? 1 : 0)));
4464 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4465 case ',': /* grandfather in commas but with a warning */
4466 if (commas++ == 0 && ckWARN(WARN_PACK))
4467 Perl_warner(aTHX_ WARN_PACK,
4468 "Invalid type in pack: '%c'", (int)datumtype);
4471 DIE(aTHX_ "%% may only be used in unpack");
4482 if (SvCUR(cat) < len)
4483 DIE(aTHX_ "X outside of string");
4490 sv_catpvn(cat, null10, 10);
4493 sv_catpvn(cat, null10, len);
4499 aptr = SvPV(fromstr, fromlen);
4500 if (pat[-1] == '*') {
4502 if (datumtype == 'Z')
4505 if (fromlen >= len) {
4506 sv_catpvn(cat, aptr, len);
4507 if (datumtype == 'Z')
4508 *(SvEND(cat)-1) = '\0';
4511 sv_catpvn(cat, aptr, fromlen);
4513 if (datumtype == 'A') {
4515 sv_catpvn(cat, space10, 10);
4518 sv_catpvn(cat, space10, len);
4522 sv_catpvn(cat, null10, 10);
4525 sv_catpvn(cat, null10, len);
4537 str = SvPV(fromstr, fromlen);
4541 SvCUR(cat) += (len+7)/8;
4542 SvGROW(cat, SvCUR(cat) + 1);
4543 aptr = SvPVX(cat) + aint;
4548 if (datumtype == 'B') {
4549 for (len = 0; len++ < aint;) {
4550 items |= *str++ & 1;
4554 *aptr++ = items & 0xff;
4560 for (len = 0; len++ < aint;) {
4566 *aptr++ = items & 0xff;
4572 if (datumtype == 'B')
4573 items <<= 7 - (aint & 7);
4575 items >>= 7 - (aint & 7);
4576 *aptr++ = items & 0xff;
4578 str = SvPVX(cat) + SvCUR(cat);
4593 str = SvPV(fromstr, fromlen);
4597 SvCUR(cat) += (len+1)/2;
4598 SvGROW(cat, SvCUR(cat) + 1);
4599 aptr = SvPVX(cat) + aint;
4604 if (datumtype == 'H') {
4605 for (len = 0; len++ < aint;) {
4607 items |= ((*str++ & 15) + 9) & 15;
4609 items |= *str++ & 15;
4613 *aptr++ = items & 0xff;
4619 for (len = 0; len++ < aint;) {
4621 items |= (((*str++ & 15) + 9) & 15) << 4;
4623 items |= (*str++ & 15) << 4;
4627 *aptr++ = items & 0xff;
4633 *aptr++ = items & 0xff;
4634 str = SvPVX(cat) + SvCUR(cat);
4645 aint = SvIV(fromstr);
4647 sv_catpvn(cat, &achar, sizeof(char));
4653 auint = SvUV(fromstr);
4654 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4655 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4660 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4665 afloat = (float)SvNV(fromstr);
4666 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4673 adouble = (double)SvNV(fromstr);
4674 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4680 ashort = (I16)SvIV(fromstr);
4682 ashort = PerlSock_htons(ashort);
4684 CAT16(cat, &ashort);
4690 ashort = (I16)SvIV(fromstr);
4692 ashort = htovs(ashort);
4694 CAT16(cat, &ashort);
4698 #if SHORTSIZE != SIZE16
4700 unsigned short aushort;
4704 aushort = SvUV(fromstr);
4705 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4715 aushort = (U16)SvUV(fromstr);
4716 CAT16(cat, &aushort);
4722 #if SHORTSIZE != SIZE16
4728 ashort = SvIV(fromstr);
4729 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4737 ashort = (I16)SvIV(fromstr);
4738 CAT16(cat, &ashort);
4745 auint = SvUV(fromstr);
4746 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4752 adouble = Perl_floor(SvNV(fromstr));
4755 DIE(aTHX_ "Cannot compress negative numbers");
4758 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4759 adouble <= 0xffffffff
4761 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4762 adouble <= UV_MAX_cxux
4769 char buf[1 + sizeof(UV)];
4770 char *in = buf + sizeof(buf);
4771 UV auv = U_V(adouble);
4774 *--in = (auv & 0x7f) | 0x80;
4777 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4778 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4780 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4781 char *from, *result, *in;
4786 /* Copy string and check for compliance */
4787 from = SvPV(fromstr, len);
4788 if ((norm = is_an_int(from, len)) == NULL)
4789 DIE(aTHX_ "can compress only unsigned integer");
4791 New('w', result, len, char);
4795 *--in = div128(norm, &done) | 0x80;
4796 result[len - 1] &= 0x7F; /* clear continue bit */
4797 sv_catpvn(cat, in, (result + len) - in);
4799 SvREFCNT_dec(norm); /* free norm */
4801 else if (SvNOKp(fromstr)) {
4802 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4803 char *in = buf + sizeof(buf);
4806 double next = floor(adouble / 128);
4807 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4808 if (--in < buf) /* this cannot happen ;-) */
4809 DIE(aTHX_ "Cannot compress integer");
4811 } while (adouble > 0);
4812 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4813 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4816 DIE(aTHX_ "Cannot compress non integer");
4822 aint = SvIV(fromstr);
4823 sv_catpvn(cat, (char*)&aint, sizeof(int));
4829 aulong = SvUV(fromstr);
4831 aulong = PerlSock_htonl(aulong);
4833 CAT32(cat, &aulong);
4839 aulong = SvUV(fromstr);
4841 aulong = htovl(aulong);
4843 CAT32(cat, &aulong);
4847 #if LONGSIZE != SIZE32
4849 unsigned long aulong;
4853 aulong = SvUV(fromstr);
4854 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4862 aulong = SvUV(fromstr);
4863 CAT32(cat, &aulong);
4868 #if LONGSIZE != SIZE32
4874 along = SvIV(fromstr);
4875 sv_catpvn(cat, (char *)&along, sizeof(long));
4883 along = SvIV(fromstr);
4892 auquad = (Uquad_t)SvUV(fromstr);
4893 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4899 aquad = (Quad_t)SvIV(fromstr);
4900 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4905 len = 1; /* assume SV is correct length */
4910 if (fromstr == &PL_sv_undef)
4914 /* XXX better yet, could spirit away the string to
4915 * a safe spot and hang on to it until the result
4916 * of pack() (and all copies of the result) are
4919 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4920 || (SvPADTMP(fromstr)
4921 && !SvREADONLY(fromstr))))
4923 Perl_warner(aTHX_ WARN_PACK,
4924 "Attempt to pack pointer to temporary value");
4926 if (SvPOK(fromstr) || SvNIOK(fromstr))
4927 aptr = SvPV(fromstr,n_a);
4929 aptr = SvPV_force(fromstr,n_a);
4931 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4936 aptr = SvPV(fromstr, fromlen);
4937 SvGROW(cat, fromlen * 4 / 3);
4942 while (fromlen > 0) {
4949 doencodes(cat, aptr, todo);
4968 register I32 limit = POPi; /* note, negative is forever */
4971 register char *s = SvPV(sv, len);
4972 char *strend = s + len;
4974 register REGEXP *rx;
4978 I32 maxiters = (strend - s) + 10;
4981 I32 origlimit = limit;
4984 AV *oldstack = PL_curstack;
4985 I32 gimme = GIMME_V;
4986 I32 oldsave = PL_savestack_ix;
4987 I32 make_mortal = 1;
4988 MAGIC *mg = (MAGIC *) NULL;
4991 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4996 DIE(aTHX_ "panic: do_split");
4997 rx = pm->op_pmregexp;
4999 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5000 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5002 if (pm->op_pmreplroot) {
5004 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5006 ary = GvAVn((GV*)pm->op_pmreplroot);
5009 else if (gimme != G_ARRAY)
5011 ary = (AV*)PL_curpad[0];
5013 ary = GvAVn(PL_defgv);
5014 #endif /* USE_THREADS */
5017 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5023 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5025 XPUSHs(SvTIED_obj((SV*)ary, mg));
5031 for (i = AvFILLp(ary); i >= 0; i--)
5032 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5034 /* temporarily switch stacks */
5035 SWITCHSTACK(PL_curstack, ary);
5039 base = SP - PL_stack_base;
5041 if (pm->op_pmflags & PMf_SKIPWHITE) {
5042 if (pm->op_pmflags & PMf_LOCALE) {
5043 while (isSPACE_LC(*s))
5051 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5052 SAVEINT(PL_multiline);
5053 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5057 limit = maxiters + 2;
5058 if (pm->op_pmflags & PMf_WHITE) {
5061 while (m < strend &&
5062 !((pm->op_pmflags & PMf_LOCALE)
5063 ? isSPACE_LC(*m) : isSPACE(*m)))
5068 dstr = NEWSV(30, m-s);
5069 sv_setpvn(dstr, s, m-s);
5075 while (s < strend &&
5076 ((pm->op_pmflags & PMf_LOCALE)
5077 ? isSPACE_LC(*s) : isSPACE(*s)))
5081 else if (strEQ("^", rx->precomp)) {
5084 for (m = s; m < strend && *m != '\n'; m++) ;
5088 dstr = NEWSV(30, m-s);
5089 sv_setpvn(dstr, s, m-s);
5096 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5097 && (rx->reganch & ROPT_CHECK_ALL)
5098 && !(rx->reganch & ROPT_ANCH)) {
5099 int tail = (rx->reganch & RE_INTUIT_TAIL);
5100 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5104 if (len == 1 && !tail) {
5108 for (m = s; m < strend && *m != c; m++) ;
5111 dstr = NEWSV(30, m-s);
5112 sv_setpvn(dstr, s, m-s);
5121 while (s < strend && --limit &&
5122 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5123 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5126 dstr = NEWSV(31, m-s);
5127 sv_setpvn(dstr, s, m-s);
5131 s = m + len; /* Fake \n at the end */
5136 maxiters += (strend - s) * rx->nparens;
5137 while (s < strend && --limit
5138 /* && (!rx->check_substr
5139 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5141 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5142 1 /* minend */, sv, NULL, 0))
5144 TAINT_IF(RX_MATCH_TAINTED(rx));
5145 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5150 strend = s + (strend - m);
5152 m = rx->startp[0] + orig;
5153 dstr = NEWSV(32, m-s);
5154 sv_setpvn(dstr, s, m-s);
5159 for (i = 1; i <= rx->nparens; i++) {
5160 s = rx->startp[i] + orig;
5161 m = rx->endp[i] + orig;
5163 dstr = NEWSV(33, m-s);
5164 sv_setpvn(dstr, s, m-s);
5167 dstr = NEWSV(33, 0);
5173 s = rx->endp[0] + orig;
5177 LEAVE_SCOPE(oldsave);
5178 iters = (SP - PL_stack_base) - base;
5179 if (iters > maxiters)
5180 DIE(aTHX_ "Split loop");
5182 /* keep field after final delim? */
5183 if (s < strend || (iters && origlimit)) {
5184 dstr = NEWSV(34, strend-s);
5185 sv_setpvn(dstr, s, strend-s);
5191 else if (!origlimit) {
5192 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5198 SWITCHSTACK(ary, oldstack);
5199 if (SvSMAGICAL(ary)) {
5204 if (gimme == G_ARRAY) {
5206 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5214 call_method("PUSH",G_SCALAR|G_DISCARD);
5217 if (gimme == G_ARRAY) {
5218 /* EXTEND should not be needed - we just popped them */
5220 for (i=0; i < iters; i++) {
5221 SV **svp = av_fetch(ary, i, FALSE);
5222 PUSHs((svp) ? *svp : &PL_sv_undef);
5229 if (gimme == G_ARRAY)
5232 if (iters || !pm->op_pmreplroot) {
5242 Perl_unlock_condpair(pTHX_ void *svv)
5245 MAGIC *mg = mg_find((SV*)svv, 'm');
5248 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5249 MUTEX_LOCK(MgMUTEXP(mg));
5250 if (MgOWNER(mg) != thr)
5251 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5253 COND_SIGNAL(MgOWNERCONDP(mg));
5254 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5255 PTR2UV(thr), PTR2UV(svv));)
5256 MUTEX_UNLOCK(MgMUTEXP(mg));
5258 #endif /* USE_THREADS */
5267 #endif /* USE_THREADS */
5268 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5269 || SvTYPE(retsv) == SVt_PVCV) {
5270 retsv = refto(retsv);
5281 if (PL_op->op_private & OPpLVAL_INTRO)
5282 PUSHs(*save_threadsv(PL_op->op_targ));
5284 PUSHs(THREADSV(PL_op->op_targ));
5287 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5288 #endif /* USE_THREADS */