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);
566 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
567 Perl_croak(aTHX_ "Attempt to bless into a reference");
569 if (ckWARN(WARN_MISC) && len == 0)
570 Perl_warner(aTHX_ WARN_MISC,
571 "Explicit blessing to '' (assuming package main)");
572 stash = gv_stashpvn(ptr, len, TRUE);
575 (void)sv_bless(TOPs, stash);
589 elem = SvPV(sv, n_a);
593 switch (elem ? *elem : '\0')
596 if (strEQ(elem, "ARRAY"))
597 tmpRef = (SV*)GvAV(gv);
600 if (strEQ(elem, "CODE"))
601 tmpRef = (SV*)GvCVu(gv);
604 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
605 tmpRef = (SV*)GvIOp(gv);
607 if (strEQ(elem, "FORMAT"))
608 tmpRef = (SV*)GvFORM(gv);
611 if (strEQ(elem, "GLOB"))
615 if (strEQ(elem, "HASH"))
616 tmpRef = (SV*)GvHV(gv);
619 if (strEQ(elem, "IO"))
620 tmpRef = (SV*)GvIOp(gv);
623 if (strEQ(elem, "NAME"))
624 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
627 if (strEQ(elem, "PACKAGE"))
628 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
631 if (strEQ(elem, "SCALAR"))
645 /* Pattern matching */
650 register unsigned char *s;
653 register I32 *sfirst;
657 if (sv == PL_lastscream) {
663 SvSCREAM_off(PL_lastscream);
664 SvREFCNT_dec(PL_lastscream);
666 PL_lastscream = SvREFCNT_inc(sv);
669 s = (unsigned char*)(SvPV(sv, len));
673 if (pos > PL_maxscream) {
674 if (PL_maxscream < 0) {
675 PL_maxscream = pos + 80;
676 New(301, PL_screamfirst, 256, I32);
677 New(302, PL_screamnext, PL_maxscream, I32);
680 PL_maxscream = pos + pos / 4;
681 Renew(PL_screamnext, PL_maxscream, I32);
685 sfirst = PL_screamfirst;
686 snext = PL_screamnext;
688 if (!sfirst || !snext)
689 DIE(aTHX_ "do_study: out of memory");
691 for (ch = 256; ch; --ch)
698 snext[pos] = sfirst[ch] - pos;
705 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
714 if (PL_op->op_flags & OPf_STACKED)
720 TARG = sv_newmortal();
725 /* Lvalue operators. */
737 djSP; dMARK; dTARGET;
747 SETi(do_chomp(TOPs));
753 djSP; dMARK; dTARGET;
754 register I32 count = 0;
757 count += do_chomp(POPs);
768 if (!sv || !SvANY(sv))
770 switch (SvTYPE(sv)) {
772 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
776 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
780 if (CvROOT(sv) || CvXSUB(sv))
797 if (!PL_op->op_private) {
806 if (SvTHINKFIRST(sv))
809 switch (SvTYPE(sv)) {
819 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
820 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
821 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
825 /* let user-undef'd sub keep its identity */
826 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
833 SvSetMagicSV(sv, &PL_sv_undef);
837 Newz(602, gp, 1, GP);
838 GvGP(sv) = gp_ref(gp);
839 GvSV(sv) = NEWSV(72,0);
840 GvLINE(sv) = CopLINE(PL_curcop);
846 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
849 SvPV_set(sv, Nullch);
862 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
863 DIE(aTHX_ PL_no_modify);
864 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
865 SvIVX(TOPs) != IV_MIN)
868 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
879 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
880 DIE(aTHX_ PL_no_modify);
881 sv_setsv(TARG, TOPs);
882 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
883 SvIVX(TOPs) != IV_MAX)
886 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
900 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
901 DIE(aTHX_ PL_no_modify);
902 sv_setsv(TARG, TOPs);
903 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
904 SvIVX(TOPs) != IV_MIN)
907 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
916 /* Ordinary operators. */
920 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
923 SETn( Perl_pow( left, right) );
930 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
933 SETn( left * right );
940 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
945 DIE(aTHX_ "Illegal division by zero");
947 /* insure that 20./5. == 4. */
950 if ((NV)I_V(left) == left &&
951 (NV)I_V(right) == right &&
952 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
956 value = left / right;
960 value = left / right;
969 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
979 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
981 right = (right_neg = (i < 0)) ? -i : i;
986 right_neg = dright < 0;
991 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
993 left = (left_neg = (i < 0)) ? -i : i;
1001 left_neg = dleft < 0;
1010 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1012 # define CAST_D2UV(d) U_V(d)
1014 # define CAST_D2UV(d) ((UV)(d))
1016 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1017 * or, in other words, precision of UV more than of NV.
1018 * But in fact the approach below turned out to be an
1019 * optimization - floor() may be slow */
1020 if (dright <= UV_MAX && dleft <= UV_MAX) {
1021 right = CAST_D2UV(dright);
1022 left = CAST_D2UV(dleft);
1027 /* Backward-compatibility clause: */
1028 dright = Perl_floor(dright + 0.5);
1029 dleft = Perl_floor(dleft + 0.5);
1032 DIE(aTHX_ "Illegal modulus zero");
1034 dans = Perl_fmod(dleft, dright);
1035 if ((left_neg != right_neg) && dans)
1036 dans = dright - dans;
1039 sv_setnv(TARG, dans);
1046 DIE(aTHX_ "Illegal modulus zero");
1049 if ((left_neg != right_neg) && ans)
1052 /* XXX may warn: unary minus operator applied to unsigned type */
1053 /* could change -foo to be (~foo)+1 instead */
1054 if (ans <= ~((UV)IV_MAX)+1)
1055 sv_setiv(TARG, ~ans+1);
1057 sv_setnv(TARG, -(NV)ans);
1060 sv_setuv(TARG, ans);
1069 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1071 register IV count = POPi;
1072 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1074 I32 items = SP - MARK;
1077 max = items * count;
1086 repeatcpy((char*)(MARK + items), (char*)MARK,
1087 items * sizeof(SV*), count - 1);
1090 else if (count <= 0)
1093 else { /* Note: mark already snarfed by pp_list */
1096 bool isutf = DO_UTF8(tmpstr);
1098 SvSetSV(TARG, tmpstr);
1099 SvPV_force(TARG, len);
1104 SvGROW(TARG, (count * len) + 1);
1105 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1106 SvCUR(TARG) *= count;
1108 *SvEND(TARG) = '\0';
1111 (void)SvPOK_only_UTF8(TARG);
1113 (void)SvPOK_only(TARG);
1122 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1125 SETn( left - right );
1132 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1135 if (PL_op->op_private & HINT_INTEGER) {
1149 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1152 if (PL_op->op_private & HINT_INTEGER) {
1166 djSP; tryAMAGICbinSET(lt,0);
1169 SETs(boolSV(TOPn < value));
1176 djSP; tryAMAGICbinSET(gt,0);
1179 SETs(boolSV(TOPn > value));
1186 djSP; tryAMAGICbinSET(le,0);
1189 SETs(boolSV(TOPn <= value));
1196 djSP; tryAMAGICbinSET(ge,0);
1199 SETs(boolSV(TOPn >= value));
1206 djSP; tryAMAGICbinSET(ne,0);
1209 SETs(boolSV(TOPn != value));
1216 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1222 if (Perl_isnan(left) || Perl_isnan(right)) {
1226 value = (left > right) - (left < right);
1230 else if (left < right)
1232 else if (left > right)
1246 djSP; tryAMAGICbinSET(slt,0);
1249 int cmp = ((PL_op->op_private & OPpLOCALE)
1250 ? sv_cmp_locale(left, right)
1251 : sv_cmp(left, right));
1252 SETs(boolSV(cmp < 0));
1259 djSP; tryAMAGICbinSET(sgt,0);
1262 int cmp = ((PL_op->op_private & OPpLOCALE)
1263 ? sv_cmp_locale(left, right)
1264 : sv_cmp(left, right));
1265 SETs(boolSV(cmp > 0));
1272 djSP; tryAMAGICbinSET(sle,0);
1275 int cmp = ((PL_op->op_private & OPpLOCALE)
1276 ? sv_cmp_locale(left, right)
1277 : sv_cmp(left, right));
1278 SETs(boolSV(cmp <= 0));
1285 djSP; tryAMAGICbinSET(sge,0);
1288 int cmp = ((PL_op->op_private & OPpLOCALE)
1289 ? sv_cmp_locale(left, right)
1290 : sv_cmp(left, right));
1291 SETs(boolSV(cmp >= 0));
1298 djSP; tryAMAGICbinSET(seq,0);
1301 SETs(boolSV(sv_eq(left, right)));
1308 djSP; tryAMAGICbinSET(sne,0);
1311 SETs(boolSV(!sv_eq(left, right)));
1318 djSP; dTARGET; tryAMAGICbin(scmp,0);
1321 int cmp = ((PL_op->op_private & OPpLOCALE)
1322 ? sv_cmp_locale(left, right)
1323 : sv_cmp(left, right));
1331 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1334 if (SvNIOKp(left) || SvNIOKp(right)) {
1335 if (PL_op->op_private & HINT_INTEGER) {
1336 IV i = SvIV(left) & SvIV(right);
1340 UV u = SvUV(left) & SvUV(right);
1345 do_vop(PL_op->op_type, TARG, left, right);
1354 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1357 if (SvNIOKp(left) || SvNIOKp(right)) {
1358 if (PL_op->op_private & HINT_INTEGER) {
1359 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1363 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1368 do_vop(PL_op->op_type, TARG, left, right);
1377 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1380 if (SvNIOKp(left) || SvNIOKp(right)) {
1381 if (PL_op->op_private & HINT_INTEGER) {
1382 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1386 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1391 do_vop(PL_op->op_type, TARG, left, right);
1400 djSP; dTARGET; tryAMAGICun(neg);
1405 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1407 if (SvIVX(sv) == IV_MIN) {
1408 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1411 else if (SvUVX(sv) <= IV_MAX) {
1416 else if (SvIVX(sv) != IV_MIN) {
1423 else if (SvPOKp(sv)) {
1425 char *s = SvPV(sv, len);
1426 if (isIDFIRST(*s)) {
1427 sv_setpvn(TARG, "-", 1);
1430 else if (*s == '+' || *s == '-') {
1432 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1434 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1435 sv_setpvn(TARG, "-", 1);
1439 sv_setnv(TARG, -SvNV(sv));
1450 djSP; tryAMAGICunSET(not);
1451 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1457 djSP; dTARGET; tryAMAGICun(compl);
1461 if (PL_op->op_private & HINT_INTEGER) {
1476 tmps = (U8*)SvPV_force(TARG, len);
1479 /* Calculate exact length, let's not estimate */
1486 while (tmps < send) {
1487 UV c = utf8_to_uv(tmps, &l);
1488 tmps += UTF8SKIP(tmps);
1489 targlen += UTF8LEN(~c);
1492 /* Now rewind strings and write them. */
1494 Newz(0, result, targlen + 1, U8);
1495 while (tmps < send) {
1496 UV c = utf8_to_uv(tmps, &l);
1497 tmps += UTF8SKIP(tmps);
1498 result = uv_to_utf8(result,(UV)~c);
1502 sv_setpvn(TARG, (char*)result, targlen);
1510 register long *tmpl;
1511 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1514 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1519 for ( ; anum > 0; anum--, tmps++)
1528 /* integer versions of some of the above */
1532 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1535 SETi( left * right );
1542 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1546 DIE(aTHX_ "Illegal division by zero");
1547 value = POPi / value;
1555 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1559 DIE(aTHX_ "Illegal modulus zero");
1560 SETi( left % right );
1567 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1570 SETi( left + right );
1577 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1580 SETi( left - right );
1587 djSP; tryAMAGICbinSET(lt,0);
1590 SETs(boolSV(left < right));
1597 djSP; tryAMAGICbinSET(gt,0);
1600 SETs(boolSV(left > right));
1607 djSP; tryAMAGICbinSET(le,0);
1610 SETs(boolSV(left <= right));
1617 djSP; tryAMAGICbinSET(ge,0);
1620 SETs(boolSV(left >= right));
1627 djSP; tryAMAGICbinSET(eq,0);
1630 SETs(boolSV(left == right));
1637 djSP; tryAMAGICbinSET(ne,0);
1640 SETs(boolSV(left != right));
1647 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1654 else if (left < right)
1665 djSP; dTARGET; tryAMAGICun(neg);
1670 /* High falutin' math. */
1674 djSP; dTARGET; tryAMAGICbin(atan2,0);
1677 SETn(Perl_atan2(left, right));
1684 djSP; dTARGET; tryAMAGICun(sin);
1688 value = Perl_sin(value);
1696 djSP; dTARGET; tryAMAGICun(cos);
1700 value = Perl_cos(value);
1706 /* Support Configure command-line overrides for rand() functions.
1707 After 5.005, perhaps we should replace this by Configure support
1708 for drand48(), random(), or rand(). For 5.005, though, maintain
1709 compatibility by calling rand() but allow the user to override it.
1710 See INSTALL for details. --Andy Dougherty 15 July 1998
1712 /* Now it's after 5.005, and Configure supports drand48() and random(),
1713 in addition to rand(). So the overrides should not be needed any more.
1714 --Jarkko Hietaniemi 27 September 1998
1717 #ifndef HAS_DRAND48_PROTO
1718 extern double drand48 (void);
1731 if (!PL_srand_called) {
1732 (void)seedDrand01((Rand_seed_t)seed());
1733 PL_srand_called = TRUE;
1748 (void)seedDrand01((Rand_seed_t)anum);
1749 PL_srand_called = TRUE;
1758 * This is really just a quick hack which grabs various garbage
1759 * values. It really should be a real hash algorithm which
1760 * spreads the effect of every input bit onto every output bit,
1761 * if someone who knows about such things would bother to write it.
1762 * Might be a good idea to add that function to CORE as well.
1763 * No numbers below come from careful analysis or anything here,
1764 * except they are primes and SEED_C1 > 1E6 to get a full-width
1765 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1766 * probably be bigger too.
1769 # define SEED_C1 1000003
1770 #define SEED_C4 73819
1772 # define SEED_C1 25747
1773 #define SEED_C4 20639
1777 #define SEED_C5 26107
1780 #ifndef PERL_NO_DEV_RANDOM
1785 # include <starlet.h>
1786 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1787 * in 100-ns units, typically incremented ever 10 ms. */
1788 unsigned int when[2];
1790 # ifdef HAS_GETTIMEOFDAY
1791 struct timeval when;
1797 /* This test is an escape hatch, this symbol isn't set by Configure. */
1798 #ifndef PERL_NO_DEV_RANDOM
1799 #ifndef PERL_RANDOM_DEVICE
1800 /* /dev/random isn't used by default because reads from it will block
1801 * if there isn't enough entropy available. You can compile with
1802 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1803 * is enough real entropy to fill the seed. */
1804 # define PERL_RANDOM_DEVICE "/dev/urandom"
1806 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1808 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1817 _ckvmssts(sys$gettim(when));
1818 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1820 # ifdef HAS_GETTIMEOFDAY
1821 gettimeofday(&when,(struct timezone *) 0);
1822 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1825 u = (U32)SEED_C1 * when;
1828 u += SEED_C3 * (U32)PerlProc_getpid();
1829 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1830 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1831 u += SEED_C5 * (U32)PTR2UV(&when);
1838 djSP; dTARGET; tryAMAGICun(exp);
1842 value = Perl_exp(value);
1850 djSP; dTARGET; tryAMAGICun(log);
1855 SET_NUMERIC_STANDARD();
1856 DIE(aTHX_ "Can't take log of %g", value);
1858 value = Perl_log(value);
1866 djSP; dTARGET; tryAMAGICun(sqrt);
1871 SET_NUMERIC_STANDARD();
1872 DIE(aTHX_ "Can't take sqrt of %g", value);
1874 value = Perl_sqrt(value);
1887 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1893 (void)Perl_modf(value, &value);
1895 (void)Perl_modf(-value, &value);
1910 djSP; dTARGET; tryAMAGICun(abs);
1915 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1916 (iv = SvIVX(TOPs)) != IV_MIN) {
1938 argtype = 1; /* allow underscores */
1939 XPUSHn(scan_hex(tmps, 99, &argtype));
1952 while (*tmps && isSPACE(*tmps))
1956 argtype = 1; /* allow underscores */
1958 value = scan_hex(++tmps, 99, &argtype);
1959 else if (*tmps == 'b')
1960 value = scan_bin(++tmps, 99, &argtype);
1962 value = scan_oct(tmps, 99, &argtype);
1975 SETi(sv_len_utf8(sv));
1991 I32 lvalue = PL_op->op_flags & OPf_MOD;
1993 I32 arybase = PL_curcop->cop_arybase;
1997 SvTAINTED_off(TARG); /* decontaminate */
1998 SvUTF8_off(TARG); /* decontaminate */
2002 repl = SvPV(sv, repl_len);
2009 tmps = SvPV(sv, curlen);
2011 utfcurlen = sv_len_utf8(sv);
2012 if (utfcurlen == curlen)
2020 if (pos >= arybase) {
2038 else if (len >= 0) {
2040 if (rem > (I32)curlen)
2055 Perl_croak(aTHX_ "substr outside of string");
2056 if (ckWARN(WARN_SUBSTR))
2057 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2062 sv_pos_u2b(sv, &pos, &rem);
2064 sv_setpvn(TARG, tmps, rem);
2068 sv_insert(sv, pos, rem, repl, repl_len);
2069 else if (lvalue) { /* it's an lvalue! */
2070 if (!SvGMAGICAL(sv)) {
2074 if (ckWARN(WARN_SUBSTR))
2075 Perl_warner(aTHX_ WARN_SUBSTR,
2076 "Attempt to use reference as lvalue in substr");
2078 if (SvOK(sv)) /* is it defined ? */
2079 (void)SvPOK_only_UTF8(sv);
2081 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2084 if (SvTYPE(TARG) < SVt_PVLV) {
2085 sv_upgrade(TARG, SVt_PVLV);
2086 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2090 if (LvTARG(TARG) != sv) {
2092 SvREFCNT_dec(LvTARG(TARG));
2093 LvTARG(TARG) = SvREFCNT_inc(sv);
2095 LvTARGOFF(TARG) = pos;
2096 LvTARGLEN(TARG) = rem;
2100 PUSHs(TARG); /* avoid SvSETMAGIC here */
2107 register IV size = POPi;
2108 register IV offset = POPi;
2109 register SV *src = POPs;
2110 I32 lvalue = PL_op->op_flags & OPf_MOD;
2112 SvTAINTED_off(TARG); /* decontaminate */
2113 if (lvalue) { /* it's an lvalue! */
2114 if (SvTYPE(TARG) < SVt_PVLV) {
2115 sv_upgrade(TARG, SVt_PVLV);
2116 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2119 if (LvTARG(TARG) != src) {
2121 SvREFCNT_dec(LvTARG(TARG));
2122 LvTARG(TARG) = SvREFCNT_inc(src);
2124 LvTARGOFF(TARG) = offset;
2125 LvTARGLEN(TARG) = size;
2128 sv_setuv(TARG, do_vecget(src, offset, size));
2143 I32 arybase = PL_curcop->cop_arybase;
2148 offset = POPi - arybase;
2151 tmps = SvPV(big, biglen);
2152 if (offset > 0 && DO_UTF8(big))
2153 sv_pos_u2b(big, &offset, 0);
2156 else if (offset > biglen)
2158 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2159 (unsigned char*)tmps + biglen, little, 0)))
2162 retval = tmps2 - tmps;
2163 if (retval > 0 && DO_UTF8(big))
2164 sv_pos_b2u(big, &retval);
2165 PUSHi(retval + arybase);
2180 I32 arybase = PL_curcop->cop_arybase;
2186 tmps2 = SvPV(little, llen);
2187 tmps = SvPV(big, blen);
2191 if (offset > 0 && DO_UTF8(big))
2192 sv_pos_u2b(big, &offset, 0);
2193 offset = offset - arybase + llen;
2197 else if (offset > blen)
2199 if (!(tmps2 = rninstr(tmps, tmps + offset,
2200 tmps2, tmps2 + llen)))
2203 retval = tmps2 - tmps;
2204 if (retval > 0 && DO_UTF8(big))
2205 sv_pos_b2u(big, &retval);
2206 PUSHi(retval + arybase);
2212 djSP; dMARK; dORIGMARK; dTARGET;
2213 do_sprintf(TARG, SP-MARK, MARK+1);
2214 TAINT_IF(SvTAINTED(TARG));
2226 U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
2229 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2230 value = utf8_to_uv_chk(tmps, &retlen, 0);
2232 value = (UV)(*tmps & 255);
2243 (void)SvUPGRADE(TARG,SVt_PV);
2245 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2246 SvGROW(TARG, UTF8_MAXLEN+1);
2248 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2249 SvCUR_set(TARG, tmps - SvPVX(TARG));
2251 (void)SvPOK_only(TARG);
2262 (void)SvPOK_only(TARG);
2269 djSP; dTARGET; dPOPTOPssrl;
2272 char *tmps = SvPV(left, n_a);
2274 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2276 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2280 "The crypt() function is unimplemented due to excessive paranoia.");
2293 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2295 U8 tmpbuf[UTF8_MAXLEN];
2297 UV uv = utf8_to_uv_chk(s, &ulen, 0);
2299 if (PL_op->op_private & OPpLOCALE) {
2302 uv = toTITLE_LC_uni(uv);
2305 uv = toTITLE_utf8(s);
2307 tend = uv_to_utf8(tmpbuf, uv);
2309 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2311 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2312 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2317 s = (U8*)SvPV_force(sv, slen);
2318 Copy(tmpbuf, s, ulen, U8);
2322 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2324 SvUTF8_off(TARG); /* decontaminate */
2329 s = (U8*)SvPV_force(sv, slen);
2331 if (PL_op->op_private & OPpLOCALE) {
2334 *s = toUPPER_LC(*s);
2352 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2354 U8 tmpbuf[UTF8_MAXLEN];
2356 UV uv = utf8_to_uv_chk(s, &ulen, 0);
2358 if (PL_op->op_private & OPpLOCALE) {
2361 uv = toLOWER_LC_uni(uv);
2364 uv = toLOWER_utf8(s);
2366 tend = uv_to_utf8(tmpbuf, uv);
2368 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2370 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2371 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2376 s = (U8*)SvPV_force(sv, slen);
2377 Copy(tmpbuf, s, ulen, U8);
2381 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2383 SvUTF8_off(TARG); /* decontaminate */
2388 s = (U8*)SvPV_force(sv, slen);
2390 if (PL_op->op_private & OPpLOCALE) {
2393 *s = toLOWER_LC(*s);
2417 s = (U8*)SvPV(sv,len);
2419 SvUTF8_off(TARG); /* decontaminate */
2420 sv_setpvn(TARG, "", 0);
2424 (void)SvUPGRADE(TARG, SVt_PV);
2425 SvGROW(TARG, (len * 2) + 1);
2426 (void)SvPOK_only(TARG);
2427 d = (U8*)SvPVX(TARG);
2429 if (PL_op->op_private & OPpLOCALE) {
2433 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv_chk(s, &ulen, 0)));
2439 d = uv_to_utf8(d, toUPPER_utf8( s ));
2445 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2450 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2452 SvUTF8_off(TARG); /* decontaminate */
2457 s = (U8*)SvPV_force(sv, len);
2459 register U8 *send = s + len;
2461 if (PL_op->op_private & OPpLOCALE) {
2464 for (; s < send; s++)
2465 *s = toUPPER_LC(*s);
2468 for (; s < send; s++)
2491 s = (U8*)SvPV(sv,len);
2493 SvUTF8_off(TARG); /* decontaminate */
2494 sv_setpvn(TARG, "", 0);
2498 (void)SvUPGRADE(TARG, SVt_PV);
2499 SvGROW(TARG, (len * 2) + 1);
2500 (void)SvPOK_only(TARG);
2501 d = (U8*)SvPVX(TARG);
2503 if (PL_op->op_private & OPpLOCALE) {
2507 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv_chk(s, &ulen, 0)));
2513 d = uv_to_utf8(d, toLOWER_utf8(s));
2519 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2524 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2526 SvUTF8_off(TARG); /* decontaminate */
2532 s = (U8*)SvPV_force(sv, len);
2534 register U8 *send = s + len;
2536 if (PL_op->op_private & OPpLOCALE) {
2539 for (; s < send; s++)
2540 *s = toLOWER_LC(*s);
2543 for (; s < send; s++)
2558 register char *s = SvPV(sv,len);
2561 SvUTF8_off(TARG); /* decontaminate */
2563 (void)SvUPGRADE(TARG, SVt_PV);
2564 SvGROW(TARG, (len * 2) + 1);
2569 STRLEN ulen = UTF8SKIP(s);
2593 SvCUR_set(TARG, d - SvPVX(TARG));
2594 (void)SvPOK_only_UTF8(TARG);
2597 sv_setpvn(TARG, s, len);
2599 if (SvSMAGICAL(TARG))
2608 djSP; dMARK; dORIGMARK;
2610 register AV* av = (AV*)POPs;
2611 register I32 lval = PL_op->op_flags & OPf_MOD;
2612 I32 arybase = PL_curcop->cop_arybase;
2615 if (SvTYPE(av) == SVt_PVAV) {
2616 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2618 for (svp = MARK + 1; svp <= SP; svp++) {
2623 if (max > AvMAX(av))
2626 while (++MARK <= SP) {
2627 elem = SvIVx(*MARK);
2631 svp = av_fetch(av, elem, lval);
2633 if (!svp || *svp == &PL_sv_undef)
2634 DIE(aTHX_ PL_no_aelem, elem);
2635 if (PL_op->op_private & OPpLVAL_INTRO)
2636 save_aelem(av, elem, svp);
2638 *MARK = svp ? *svp : &PL_sv_undef;
2641 if (GIMME != G_ARRAY) {
2649 /* Associative arrays. */
2654 HV *hash = (HV*)POPs;
2656 I32 gimme = GIMME_V;
2657 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2660 /* might clobber stack_sp */
2661 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2666 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2667 if (gimme == G_ARRAY) {
2670 /* might clobber stack_sp */
2672 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2677 else if (gimme == G_SCALAR)
2696 I32 gimme = GIMME_V;
2697 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2701 if (PL_op->op_private & OPpSLICE) {
2705 hvtype = SvTYPE(hv);
2706 if (hvtype == SVt_PVHV) { /* hash element */
2707 while (++MARK <= SP) {
2708 sv = hv_delete_ent(hv, *MARK, discard, 0);
2709 *MARK = sv ? sv : &PL_sv_undef;
2712 else if (hvtype == SVt_PVAV) {
2713 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2714 while (++MARK <= SP) {
2715 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2716 *MARK = sv ? sv : &PL_sv_undef;
2719 else { /* pseudo-hash element */
2720 while (++MARK <= SP) {
2721 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2722 *MARK = sv ? sv : &PL_sv_undef;
2727 DIE(aTHX_ "Not a HASH reference");
2730 else if (gimme == G_SCALAR) {
2739 if (SvTYPE(hv) == SVt_PVHV)
2740 sv = hv_delete_ent(hv, keysv, discard, 0);
2741 else if (SvTYPE(hv) == SVt_PVAV) {
2742 if (PL_op->op_flags & OPf_SPECIAL)
2743 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2745 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2748 DIE(aTHX_ "Not a HASH reference");
2763 if (PL_op->op_private & OPpEXISTS_SUB) {
2767 cv = sv_2cv(sv, &hv, &gv, FALSE);
2770 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2776 if (SvTYPE(hv) == SVt_PVHV) {
2777 if (hv_exists_ent(hv, tmpsv, 0))
2780 else if (SvTYPE(hv) == SVt_PVAV) {
2781 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2782 if (av_exists((AV*)hv, SvIV(tmpsv)))
2785 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2789 DIE(aTHX_ "Not a HASH reference");
2796 djSP; dMARK; dORIGMARK;
2797 register HV *hv = (HV*)POPs;
2798 register I32 lval = PL_op->op_flags & OPf_MOD;
2799 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2801 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2802 DIE(aTHX_ "Can't localize pseudo-hash element");
2804 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2805 while (++MARK <= SP) {
2809 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2810 svp = he ? &HeVAL(he) : 0;
2813 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2816 if (!svp || *svp == &PL_sv_undef) {
2818 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2820 if (PL_op->op_private & OPpLVAL_INTRO)
2821 save_helem(hv, keysv, svp);
2823 *MARK = svp ? *svp : &PL_sv_undef;
2826 if (GIMME != G_ARRAY) {
2834 /* List operators. */
2839 if (GIMME != G_ARRAY) {
2841 *MARK = *SP; /* unwanted list, return last item */
2843 *MARK = &PL_sv_undef;
2852 SV **lastrelem = PL_stack_sp;
2853 SV **lastlelem = PL_stack_base + POPMARK;
2854 SV **firstlelem = PL_stack_base + POPMARK + 1;
2855 register SV **firstrelem = lastlelem + 1;
2856 I32 arybase = PL_curcop->cop_arybase;
2857 I32 lval = PL_op->op_flags & OPf_MOD;
2858 I32 is_something_there = lval;
2860 register I32 max = lastrelem - lastlelem;
2861 register SV **lelem;
2864 if (GIMME != G_ARRAY) {
2865 ix = SvIVx(*lastlelem);
2870 if (ix < 0 || ix >= max)
2871 *firstlelem = &PL_sv_undef;
2873 *firstlelem = firstrelem[ix];
2879 SP = firstlelem - 1;
2883 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2889 if (ix < 0 || ix >= max)
2890 *lelem = &PL_sv_undef;
2892 is_something_there = TRUE;
2893 if (!(*lelem = firstrelem[ix]))
2894 *lelem = &PL_sv_undef;
2897 if (is_something_there)
2900 SP = firstlelem - 1;
2906 djSP; dMARK; dORIGMARK;
2907 I32 items = SP - MARK;
2908 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2909 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2916 djSP; dMARK; dORIGMARK;
2917 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2921 SV *val = NEWSV(46, 0);
2923 sv_setsv(val, *++MARK);
2924 else if (ckWARN(WARN_MISC))
2925 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2926 (void)hv_store_ent(hv,key,val,0);
2935 djSP; dMARK; dORIGMARK;
2936 register AV *ary = (AV*)*++MARK;
2940 register I32 offset;
2941 register I32 length;
2948 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2949 *MARK-- = SvTIED_obj((SV*)ary, mg);
2953 call_method("SPLICE",GIMME_V);
2962 offset = i = SvIVx(*MARK);
2964 offset += AvFILLp(ary) + 1;
2966 offset -= PL_curcop->cop_arybase;
2968 DIE(aTHX_ PL_no_aelem, i);
2970 length = SvIVx(*MARK++);
2972 length += AvFILLp(ary) - offset + 1;
2978 length = AvMAX(ary) + 1; /* close enough to infinity */
2982 length = AvMAX(ary) + 1;
2984 if (offset > AvFILLp(ary) + 1)
2985 offset = AvFILLp(ary) + 1;
2986 after = AvFILLp(ary) + 1 - (offset + length);
2987 if (after < 0) { /* not that much array */
2988 length += after; /* offset+length now in array */
2994 /* At this point, MARK .. SP-1 is our new LIST */
2997 diff = newlen - length;
2998 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3001 if (diff < 0) { /* shrinking the area */
3003 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3004 Copy(MARK, tmparyval, newlen, SV*);
3007 MARK = ORIGMARK + 1;
3008 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3009 MEXTEND(MARK, length);
3010 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3012 EXTEND_MORTAL(length);
3013 for (i = length, dst = MARK; i; i--) {
3014 sv_2mortal(*dst); /* free them eventualy */
3021 *MARK = AvARRAY(ary)[offset+length-1];
3024 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3025 SvREFCNT_dec(*dst++); /* free them now */
3028 AvFILLp(ary) += diff;
3030 /* pull up or down? */
3032 if (offset < after) { /* easier to pull up */
3033 if (offset) { /* esp. if nothing to pull */
3034 src = &AvARRAY(ary)[offset-1];
3035 dst = src - diff; /* diff is negative */
3036 for (i = offset; i > 0; i--) /* can't trust Copy */
3040 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3044 if (after) { /* anything to pull down? */
3045 src = AvARRAY(ary) + offset + length;
3046 dst = src + diff; /* diff is negative */
3047 Move(src, dst, after, SV*);
3049 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3050 /* avoid later double free */
3054 dst[--i] = &PL_sv_undef;
3057 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3059 *dst = NEWSV(46, 0);
3060 sv_setsv(*dst++, *src++);
3062 Safefree(tmparyval);
3065 else { /* no, expanding (or same) */
3067 New(452, tmparyval, length, SV*); /* so remember deletion */
3068 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3071 if (diff > 0) { /* expanding */
3073 /* push up or down? */
3075 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3079 Move(src, dst, offset, SV*);
3081 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3083 AvFILLp(ary) += diff;
3086 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3087 av_extend(ary, AvFILLp(ary) + diff);
3088 AvFILLp(ary) += diff;
3091 dst = AvARRAY(ary) + AvFILLp(ary);
3093 for (i = after; i; i--) {
3100 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3101 *dst = NEWSV(46, 0);
3102 sv_setsv(*dst++, *src++);
3104 MARK = ORIGMARK + 1;
3105 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3107 Copy(tmparyval, MARK, length, SV*);
3109 EXTEND_MORTAL(length);
3110 for (i = length, dst = MARK; i; i--) {
3111 sv_2mortal(*dst); /* free them eventualy */
3115 Safefree(tmparyval);
3119 else if (length--) {
3120 *MARK = tmparyval[length];
3123 while (length-- > 0)
3124 SvREFCNT_dec(tmparyval[length]);
3126 Safefree(tmparyval);
3129 *MARK = &PL_sv_undef;
3137 djSP; dMARK; dORIGMARK; dTARGET;
3138 register AV *ary = (AV*)*++MARK;
3139 register SV *sv = &PL_sv_undef;
3142 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3143 *MARK-- = SvTIED_obj((SV*)ary, mg);
3147 call_method("PUSH",G_SCALAR|G_DISCARD);
3152 /* Why no pre-extend of ary here ? */
3153 for (++MARK; MARK <= SP; MARK++) {
3156 sv_setsv(sv, *MARK);
3161 PUSHi( AvFILL(ary) + 1 );
3169 SV *sv = av_pop(av);
3171 (void)sv_2mortal(sv);
3180 SV *sv = av_shift(av);
3185 (void)sv_2mortal(sv);
3192 djSP; dMARK; dORIGMARK; dTARGET;
3193 register AV *ary = (AV*)*++MARK;
3198 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3199 *MARK-- = SvTIED_obj((SV*)ary, mg);
3203 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3208 av_unshift(ary, SP - MARK);
3211 sv_setsv(sv, *++MARK);
3212 (void)av_store(ary, i++, sv);
3216 PUSHi( AvFILL(ary) + 1 );
3226 if (GIMME == G_ARRAY) {
3233 /* safe as long as stack cannot get extended in the above */
3238 register char *down;
3243 SvUTF8_off(TARG); /* decontaminate */
3245 do_join(TARG, &PL_sv_no, MARK, SP);
3247 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3248 up = SvPV_force(TARG, len);
3250 if (DO_UTF8(TARG)) { /* first reverse each character */
3251 U8* s = (U8*)SvPVX(TARG);
3252 U8* send = (U8*)(s + len);
3261 down = (char*)(s - 1);
3262 if (s > send || !((*down & 0xc0) == 0x80)) {
3263 if (ckWARN_d(WARN_UTF8))
3264 Perl_warner(aTHX_ WARN_UTF8,
3265 "Malformed UTF-8 character");
3277 down = SvPVX(TARG) + len - 1;
3283 (void)SvPOK_only_UTF8(TARG);
3292 S_mul128(pTHX_ SV *sv, U8 m)
3295 char *s = SvPV(sv, len);
3299 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3300 SV *tmpNew = newSVpvn("0000000000", 10);
3302 sv_catsv(tmpNew, sv);
3303 SvREFCNT_dec(sv); /* free old sv */
3308 while (!*t) /* trailing '\0'? */
3311 i = ((*t - '0') << 7) + m;
3312 *(t--) = '0' + (i % 10);
3318 /* Explosives and implosives. */
3320 #if 'I' == 73 && 'J' == 74
3321 /* On an ASCII/ISO kind of system */
3322 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3325 Some other sort of character set - use memchr() so we don't match
3328 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3335 I32 start_sp_offset = SP - PL_stack_base;
3336 I32 gimme = GIMME_V;
3340 register char *pat = SvPV(left, llen);
3341 register char *s = SvPV(right, rlen);
3342 char *strend = s + rlen;
3344 register char *patend = pat + llen;
3350 /* These must not be in registers: */
3367 register U32 culong;
3371 #ifdef PERL_NATINT_PACK
3372 int natint; /* native integer */
3373 int unatint; /* unsigned native integer */
3376 if (gimme != G_ARRAY) { /* arrange to do first one only */
3378 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3379 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3381 while (isDIGIT(*patend) || *patend == '*')
3387 while (pat < patend) {
3389 datumtype = *pat++ & 0xFF;
3390 #ifdef PERL_NATINT_PACK
3393 if (isSPACE(datumtype))
3395 if (datumtype == '#') {
3396 while (pat < patend && *pat != '\n')
3401 char *natstr = "sSiIlL";
3403 if (strchr(natstr, datumtype)) {
3404 #ifdef PERL_NATINT_PACK
3410 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3415 else if (*pat == '*') {
3416 len = strend - strbeg; /* long enough */
3420 else if (isDIGIT(*pat)) {
3422 while (isDIGIT(*pat)) {
3423 len = (len * 10) + (*pat++ - '0');
3425 DIE(aTHX_ "Repeat count in unpack overflows");
3429 len = (datumtype != '@');
3433 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3434 case ',': /* grandfather in commas but with a warning */
3435 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3436 Perl_warner(aTHX_ WARN_UNPACK,
3437 "Invalid type in unpack: '%c'", (int)datumtype);
3440 if (len == 1 && pat[-1] != '1')
3449 if (len > strend - strbeg)
3450 DIE(aTHX_ "@ outside of string");
3454 if (len > s - strbeg)
3455 DIE(aTHX_ "X outside of string");
3459 if (len > strend - s)
3460 DIE(aTHX_ "x outside of string");
3464 if (start_sp_offset >= SP - PL_stack_base)
3465 DIE(aTHX_ "/ must follow a numeric type");
3468 pat++; /* ignore '*' for compatibility with pack */
3470 DIE(aTHX_ "/ cannot take a count" );
3477 if (len > strend - s)
3480 goto uchar_checksum;
3481 sv = NEWSV(35, len);
3482 sv_setpvn(sv, s, len);
3484 if (datumtype == 'A' || datumtype == 'Z') {
3485 aptr = s; /* borrow register */
3486 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3491 else { /* 'A' strips both nulls and spaces */
3492 s = SvPVX(sv) + len - 1;
3493 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3497 SvCUR_set(sv, s - SvPVX(sv));
3498 s = aptr; /* unborrow register */
3500 XPUSHs(sv_2mortal(sv));
3504 if (star || len > (strend - s) * 8)
3505 len = (strend - s) * 8;
3508 Newz(601, PL_bitcount, 256, char);
3509 for (bits = 1; bits < 256; bits++) {
3510 if (bits & 1) PL_bitcount[bits]++;
3511 if (bits & 2) PL_bitcount[bits]++;
3512 if (bits & 4) PL_bitcount[bits]++;
3513 if (bits & 8) PL_bitcount[bits]++;
3514 if (bits & 16) PL_bitcount[bits]++;
3515 if (bits & 32) PL_bitcount[bits]++;
3516 if (bits & 64) PL_bitcount[bits]++;
3517 if (bits & 128) PL_bitcount[bits]++;
3521 culong += PL_bitcount[*(unsigned char*)s++];
3526 if (datumtype == 'b') {
3528 if (bits & 1) culong++;
3534 if (bits & 128) culong++;
3541 sv = NEWSV(35, len + 1);
3545 if (datumtype == 'b') {
3547 for (len = 0; len < aint; len++) {
3548 if (len & 7) /*SUPPRESS 595*/
3552 *str++ = '0' + (bits & 1);
3557 for (len = 0; len < aint; len++) {
3562 *str++ = '0' + ((bits & 128) != 0);
3566 XPUSHs(sv_2mortal(sv));
3570 if (star || len > (strend - s) * 2)
3571 len = (strend - s) * 2;
3572 sv = NEWSV(35, len + 1);
3576 if (datumtype == 'h') {
3578 for (len = 0; len < aint; len++) {
3583 *str++ = PL_hexdigit[bits & 15];
3588 for (len = 0; len < aint; len++) {
3593 *str++ = PL_hexdigit[(bits >> 4) & 15];
3597 XPUSHs(sv_2mortal(sv));
3600 if (len > strend - s)
3605 if (aint >= 128) /* fake up signed chars */
3615 if (aint >= 128) /* fake up signed chars */
3618 sv_setiv(sv, (IV)aint);
3619 PUSHs(sv_2mortal(sv));
3624 if (len > strend - s)
3639 sv_setiv(sv, (IV)auint);
3640 PUSHs(sv_2mortal(sv));
3645 if (len > strend - s)
3648 while (len-- > 0 && s < strend) {
3649 auint = utf8_to_uv_chk((U8*)s, &along, 0);
3652 cdouble += (NV)auint;
3660 while (len-- > 0 && s < strend) {
3661 auint = utf8_to_uv_chk((U8*)s, &along, 0);
3664 sv_setuv(sv, (UV)auint);
3665 PUSHs(sv_2mortal(sv));
3670 #if SHORTSIZE == SIZE16
3671 along = (strend - s) / SIZE16;
3673 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3678 #if SHORTSIZE != SIZE16
3682 COPYNN(s, &ashort, sizeof(short));
3693 #if SHORTSIZE > SIZE16
3705 #if SHORTSIZE != SIZE16
3709 COPYNN(s, &ashort, sizeof(short));
3712 sv_setiv(sv, (IV)ashort);
3713 PUSHs(sv_2mortal(sv));
3721 #if SHORTSIZE > SIZE16
3727 sv_setiv(sv, (IV)ashort);
3728 PUSHs(sv_2mortal(sv));
3736 #if SHORTSIZE == SIZE16
3737 along = (strend - s) / SIZE16;
3739 unatint = natint && datumtype == 'S';
3740 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3745 #if SHORTSIZE != SIZE16
3747 unsigned short aushort;
3749 COPYNN(s, &aushort, sizeof(unsigned short));
3750 s += sizeof(unsigned short);
3758 COPY16(s, &aushort);
3761 if (datumtype == 'n')
3762 aushort = PerlSock_ntohs(aushort);
3765 if (datumtype == 'v')
3766 aushort = vtohs(aushort);
3775 #if SHORTSIZE != SIZE16
3777 unsigned short aushort;
3779 COPYNN(s, &aushort, sizeof(unsigned short));
3780 s += sizeof(unsigned short);
3782 sv_setiv(sv, (UV)aushort);
3783 PUSHs(sv_2mortal(sv));
3790 COPY16(s, &aushort);
3794 if (datumtype == 'n')
3795 aushort = PerlSock_ntohs(aushort);
3798 if (datumtype == 'v')
3799 aushort = vtohs(aushort);
3801 sv_setiv(sv, (UV)aushort);
3802 PUSHs(sv_2mortal(sv));
3808 along = (strend - s) / sizeof(int);
3813 Copy(s, &aint, 1, int);
3816 cdouble += (NV)aint;
3825 Copy(s, &aint, 1, int);
3829 /* Without the dummy below unpack("i", pack("i",-1))
3830 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3831 * cc with optimization turned on.
3833 * The bug was detected in
3834 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3835 * with optimization (-O4) turned on.
3836 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3837 * does not have this problem even with -O4.
3839 * This bug was reported as DECC_BUGS 1431
3840 * and tracked internally as GEM_BUGS 7775.
3842 * The bug is fixed in
3843 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3844 * UNIX V4.0F support: DEC C V5.9-006 or later
3845 * UNIX V4.0E support: DEC C V5.8-011 or later
3848 * See also few lines later for the same bug.
3851 sv_setiv(sv, (IV)aint) :
3853 sv_setiv(sv, (IV)aint);
3854 PUSHs(sv_2mortal(sv));
3859 along = (strend - s) / sizeof(unsigned int);
3864 Copy(s, &auint, 1, unsigned int);
3865 s += sizeof(unsigned int);
3867 cdouble += (NV)auint;
3876 Copy(s, &auint, 1, unsigned int);
3877 s += sizeof(unsigned int);
3880 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3881 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3882 * See details few lines earlier. */
3884 sv_setuv(sv, (UV)auint) :
3886 sv_setuv(sv, (UV)auint);
3887 PUSHs(sv_2mortal(sv));
3892 #if LONGSIZE == SIZE32
3893 along = (strend - s) / SIZE32;
3895 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3900 #if LONGSIZE != SIZE32
3904 COPYNN(s, &along, sizeof(long));
3907 cdouble += (NV)along;
3917 #if LONGSIZE > SIZE32
3918 if (along > 2147483647)
3919 along -= 4294967296;
3923 cdouble += (NV)along;
3932 #if LONGSIZE != SIZE32
3936 COPYNN(s, &along, sizeof(long));
3939 sv_setiv(sv, (IV)along);
3940 PUSHs(sv_2mortal(sv));
3948 #if LONGSIZE > SIZE32
3949 if (along > 2147483647)
3950 along -= 4294967296;
3954 sv_setiv(sv, (IV)along);
3955 PUSHs(sv_2mortal(sv));
3963 #if LONGSIZE == SIZE32
3964 along = (strend - s) / SIZE32;
3966 unatint = natint && datumtype == 'L';
3967 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3972 #if LONGSIZE != SIZE32
3974 unsigned long aulong;
3976 COPYNN(s, &aulong, sizeof(unsigned long));
3977 s += sizeof(unsigned long);
3979 cdouble += (NV)aulong;
3991 if (datumtype == 'N')
3992 aulong = PerlSock_ntohl(aulong);
3995 if (datumtype == 'V')
3996 aulong = vtohl(aulong);
3999 cdouble += (NV)aulong;
4008 #if LONGSIZE != SIZE32
4010 unsigned long aulong;
4012 COPYNN(s, &aulong, sizeof(unsigned long));
4013 s += sizeof(unsigned long);
4015 sv_setuv(sv, (UV)aulong);
4016 PUSHs(sv_2mortal(sv));
4026 if (datumtype == 'N')
4027 aulong = PerlSock_ntohl(aulong);
4030 if (datumtype == 'V')
4031 aulong = vtohl(aulong);
4034 sv_setuv(sv, (UV)aulong);
4035 PUSHs(sv_2mortal(sv));
4041 along = (strend - s) / sizeof(char*);
4047 if (sizeof(char*) > strend - s)
4050 Copy(s, &aptr, 1, char*);
4056 PUSHs(sv_2mortal(sv));
4066 while ((len > 0) && (s < strend)) {
4067 auv = (auv << 7) | (*s & 0x7f);
4068 if (!(*s++ & 0x80)) {
4072 PUSHs(sv_2mortal(sv));
4076 else if (++bytes >= sizeof(UV)) { /* promote to string */
4080 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4081 while (s < strend) {
4082 sv = mul128(sv, *s & 0x7f);
4083 if (!(*s++ & 0x80)) {
4092 PUSHs(sv_2mortal(sv));
4097 if ((s >= strend) && bytes)
4098 DIE(aTHX_ "Unterminated compressed integer");
4103 if (sizeof(char*) > strend - s)
4106 Copy(s, &aptr, 1, char*);
4111 sv_setpvn(sv, aptr, len);
4112 PUSHs(sv_2mortal(sv));
4116 along = (strend - s) / sizeof(Quad_t);
4122 if (s + sizeof(Quad_t) > strend)
4125 Copy(s, &aquad, 1, Quad_t);
4126 s += sizeof(Quad_t);
4129 if (aquad >= IV_MIN && aquad <= IV_MAX)
4130 sv_setiv(sv, (IV)aquad);
4132 sv_setnv(sv, (NV)aquad);
4133 PUSHs(sv_2mortal(sv));
4137 along = (strend - s) / sizeof(Quad_t);
4143 if (s + sizeof(Uquad_t) > strend)
4146 Copy(s, &auquad, 1, Uquad_t);
4147 s += sizeof(Uquad_t);
4150 if (auquad <= UV_MAX)
4151 sv_setuv(sv, (UV)auquad);
4153 sv_setnv(sv, (NV)auquad);
4154 PUSHs(sv_2mortal(sv));
4158 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4161 along = (strend - s) / sizeof(float);
4166 Copy(s, &afloat, 1, float);
4175 Copy(s, &afloat, 1, float);
4178 sv_setnv(sv, (NV)afloat);
4179 PUSHs(sv_2mortal(sv));
4185 along = (strend - s) / sizeof(double);
4190 Copy(s, &adouble, 1, double);
4191 s += sizeof(double);
4199 Copy(s, &adouble, 1, double);
4200 s += sizeof(double);
4202 sv_setnv(sv, (NV)adouble);
4203 PUSHs(sv_2mortal(sv));
4209 * Initialise the decode mapping. By using a table driven
4210 * algorithm, the code will be character-set independent
4211 * (and just as fast as doing character arithmetic)
4213 if (PL_uudmap['M'] == 0) {
4216 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4217 PL_uudmap[(U8)PL_uuemap[i]] = i;
4219 * Because ' ' and '`' map to the same value,
4220 * we need to decode them both the same.
4225 along = (strend - s) * 3 / 4;
4226 sv = NEWSV(42, along);
4229 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4234 len = PL_uudmap[*(U8*)s++] & 077;
4236 if (s < strend && ISUUCHAR(*s))
4237 a = PL_uudmap[*(U8*)s++] & 077;
4240 if (s < strend && ISUUCHAR(*s))
4241 b = PL_uudmap[*(U8*)s++] & 077;
4244 if (s < strend && ISUUCHAR(*s))
4245 c = PL_uudmap[*(U8*)s++] & 077;
4248 if (s < strend && ISUUCHAR(*s))
4249 d = PL_uudmap[*(U8*)s++] & 077;
4252 hunk[0] = (a << 2) | (b >> 4);
4253 hunk[1] = (b << 4) | (c >> 2);
4254 hunk[2] = (c << 6) | d;
4255 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4260 else if (s[1] == '\n') /* possible checksum byte */
4263 XPUSHs(sv_2mortal(sv));
4268 if (strchr("fFdD", datumtype) ||
4269 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4273 while (checksum >= 16) {
4277 while (checksum >= 4) {
4283 along = (1 << checksum) - 1;
4284 while (cdouble < 0.0)
4286 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4287 sv_setnv(sv, cdouble);
4290 if (checksum < 32) {
4291 aulong = (1 << checksum) - 1;
4294 sv_setuv(sv, (UV)culong);
4296 XPUSHs(sv_2mortal(sv));
4300 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4301 PUSHs(&PL_sv_undef);
4306 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4310 *hunk = PL_uuemap[len];
4311 sv_catpvn(sv, hunk, 1);
4314 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4315 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4316 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4317 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4318 sv_catpvn(sv, hunk, 4);
4323 char r = (len > 1 ? s[1] : '\0');
4324 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4325 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4326 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4327 hunk[3] = PL_uuemap[0];
4328 sv_catpvn(sv, hunk, 4);
4330 sv_catpvn(sv, "\n", 1);
4334 S_is_an_int(pTHX_ char *s, STRLEN l)
4337 SV *result = newSVpvn(s, l);
4338 char *result_c = SvPV(result, n_a); /* convenience */
4339 char *out = result_c;
4349 SvREFCNT_dec(result);
4372 SvREFCNT_dec(result);
4378 SvCUR_set(result, out - result_c);
4382 /* pnum must be '\0' terminated */
4384 S_div128(pTHX_ SV *pnum, bool *done)
4387 char *s = SvPV(pnum, len);
4396 i = m * 10 + (*t - '0');
4398 r = (i >> 7); /* r < 10 */
4405 SvCUR_set(pnum, (STRLEN) (t - s));
4412 djSP; dMARK; dORIGMARK; dTARGET;
4413 register SV *cat = TARG;
4416 register char *pat = SvPVx(*++MARK, fromlen);
4418 register char *patend = pat + fromlen;
4423 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4424 static char *space10 = " ";
4426 /* These must not be in registers: */
4441 #ifdef PERL_NATINT_PACK
4442 int natint; /* native integer */
4447 sv_setpvn(cat, "", 0);
4449 while (pat < patend) {
4450 SV *lengthcode = Nullsv;
4451 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4452 datumtype = *pat++ & 0xFF;
4453 #ifdef PERL_NATINT_PACK
4456 if (isSPACE(datumtype)) {
4460 if (datumtype == 'U' && pat == patcopy+1)
4462 if (datumtype == '#') {
4463 while (pat < patend && *pat != '\n')
4468 char *natstr = "sSiIlL";
4470 if (strchr(natstr, datumtype)) {
4471 #ifdef PERL_NATINT_PACK
4477 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4480 len = strchr("@Xxu", datumtype) ? 0 : items;
4483 else if (isDIGIT(*pat)) {
4485 while (isDIGIT(*pat)) {
4486 len = (len * 10) + (*pat++ - '0');
4488 DIE(aTHX_ "Repeat count in pack overflows");
4495 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4496 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4497 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4498 ? *MARK : &PL_sv_no)
4499 + (*pat == 'Z' ? 1 : 0)));
4503 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4504 case ',': /* grandfather in commas but with a warning */
4505 if (commas++ == 0 && ckWARN(WARN_PACK))
4506 Perl_warner(aTHX_ WARN_PACK,
4507 "Invalid type in pack: '%c'", (int)datumtype);
4510 DIE(aTHX_ "%% may only be used in unpack");
4521 if (SvCUR(cat) < len)
4522 DIE(aTHX_ "X outside of string");
4529 sv_catpvn(cat, null10, 10);
4532 sv_catpvn(cat, null10, len);
4538 aptr = SvPV(fromstr, fromlen);
4539 if (pat[-1] == '*') {
4541 if (datumtype == 'Z')
4544 if (fromlen >= len) {
4545 sv_catpvn(cat, aptr, len);
4546 if (datumtype == 'Z')
4547 *(SvEND(cat)-1) = '\0';
4550 sv_catpvn(cat, aptr, fromlen);
4552 if (datumtype == 'A') {
4554 sv_catpvn(cat, space10, 10);
4557 sv_catpvn(cat, space10, len);
4561 sv_catpvn(cat, null10, 10);
4564 sv_catpvn(cat, null10, len);
4576 str = SvPV(fromstr, fromlen);
4580 SvCUR(cat) += (len+7)/8;
4581 SvGROW(cat, SvCUR(cat) + 1);
4582 aptr = SvPVX(cat) + aint;
4587 if (datumtype == 'B') {
4588 for (len = 0; len++ < aint;) {
4589 items |= *str++ & 1;
4593 *aptr++ = items & 0xff;
4599 for (len = 0; len++ < aint;) {
4605 *aptr++ = items & 0xff;
4611 if (datumtype == 'B')
4612 items <<= 7 - (aint & 7);
4614 items >>= 7 - (aint & 7);
4615 *aptr++ = items & 0xff;
4617 str = SvPVX(cat) + SvCUR(cat);
4632 str = SvPV(fromstr, fromlen);
4636 SvCUR(cat) += (len+1)/2;
4637 SvGROW(cat, SvCUR(cat) + 1);
4638 aptr = SvPVX(cat) + aint;
4643 if (datumtype == 'H') {
4644 for (len = 0; len++ < aint;) {
4646 items |= ((*str++ & 15) + 9) & 15;
4648 items |= *str++ & 15;
4652 *aptr++ = items & 0xff;
4658 for (len = 0; len++ < aint;) {
4660 items |= (((*str++ & 15) + 9) & 15) << 4;
4662 items |= (*str++ & 15) << 4;
4666 *aptr++ = items & 0xff;
4672 *aptr++ = items & 0xff;
4673 str = SvPVX(cat) + SvCUR(cat);
4684 aint = SvIV(fromstr);
4686 sv_catpvn(cat, &achar, sizeof(char));
4692 auint = SvUV(fromstr);
4693 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4694 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4699 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4704 afloat = (float)SvNV(fromstr);
4705 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4712 adouble = (double)SvNV(fromstr);
4713 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4719 ashort = (I16)SvIV(fromstr);
4721 ashort = PerlSock_htons(ashort);
4723 CAT16(cat, &ashort);
4729 ashort = (I16)SvIV(fromstr);
4731 ashort = htovs(ashort);
4733 CAT16(cat, &ashort);
4737 #if SHORTSIZE != SIZE16
4739 unsigned short aushort;
4743 aushort = SvUV(fromstr);
4744 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4754 aushort = (U16)SvUV(fromstr);
4755 CAT16(cat, &aushort);
4761 #if SHORTSIZE != SIZE16
4767 ashort = SvIV(fromstr);
4768 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4776 ashort = (I16)SvIV(fromstr);
4777 CAT16(cat, &ashort);
4784 auint = SvUV(fromstr);
4785 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4791 adouble = Perl_floor(SvNV(fromstr));
4794 DIE(aTHX_ "Cannot compress negative numbers");
4797 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4798 adouble <= 0xffffffff
4800 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4801 adouble <= UV_MAX_cxux
4808 char buf[1 + sizeof(UV)];
4809 char *in = buf + sizeof(buf);
4810 UV auv = U_V(adouble);
4813 *--in = (auv & 0x7f) | 0x80;
4816 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4817 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4819 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4820 char *from, *result, *in;
4825 /* Copy string and check for compliance */
4826 from = SvPV(fromstr, len);
4827 if ((norm = is_an_int(from, len)) == NULL)
4828 DIE(aTHX_ "can compress only unsigned integer");
4830 New('w', result, len, char);
4834 *--in = div128(norm, &done) | 0x80;
4835 result[len - 1] &= 0x7F; /* clear continue bit */
4836 sv_catpvn(cat, in, (result + len) - in);
4838 SvREFCNT_dec(norm); /* free norm */
4840 else if (SvNOKp(fromstr)) {
4841 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4842 char *in = buf + sizeof(buf);
4845 double next = floor(adouble / 128);
4846 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4847 if (in <= buf) /* this cannot happen ;-) */
4848 DIE(aTHX_ "Cannot compress integer");
4851 } while (adouble > 0);
4852 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4853 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4856 DIE(aTHX_ "Cannot compress non integer");
4862 aint = SvIV(fromstr);
4863 sv_catpvn(cat, (char*)&aint, sizeof(int));
4869 aulong = SvUV(fromstr);
4871 aulong = PerlSock_htonl(aulong);
4873 CAT32(cat, &aulong);
4879 aulong = SvUV(fromstr);
4881 aulong = htovl(aulong);
4883 CAT32(cat, &aulong);
4887 #if LONGSIZE != SIZE32
4889 unsigned long aulong;
4893 aulong = SvUV(fromstr);
4894 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4902 aulong = SvUV(fromstr);
4903 CAT32(cat, &aulong);
4908 #if LONGSIZE != SIZE32
4914 along = SvIV(fromstr);
4915 sv_catpvn(cat, (char *)&along, sizeof(long));
4923 along = SvIV(fromstr);
4932 auquad = (Uquad_t)SvUV(fromstr);
4933 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4939 aquad = (Quad_t)SvIV(fromstr);
4940 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4945 len = 1; /* assume SV is correct length */
4950 if (fromstr == &PL_sv_undef)
4954 /* XXX better yet, could spirit away the string to
4955 * a safe spot and hang on to it until the result
4956 * of pack() (and all copies of the result) are
4959 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4960 || (SvPADTMP(fromstr)
4961 && !SvREADONLY(fromstr))))
4963 Perl_warner(aTHX_ WARN_PACK,
4964 "Attempt to pack pointer to temporary value");
4966 if (SvPOK(fromstr) || SvNIOK(fromstr))
4967 aptr = SvPV(fromstr,n_a);
4969 aptr = SvPV_force(fromstr,n_a);
4971 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4976 aptr = SvPV(fromstr, fromlen);
4977 SvGROW(cat, fromlen * 4 / 3);
4982 while (fromlen > 0) {
4989 doencodes(cat, aptr, todo);
5008 register IV limit = POPi; /* note, negative is forever */
5010 bool doutf8 = DO_UTF8(sv);
5012 register char *s = SvPV(sv, len);
5013 char *strend = s + len;
5015 register REGEXP *rx;
5019 I32 maxiters = (strend - s) + 10;
5022 I32 origlimit = limit;
5025 AV *oldstack = PL_curstack;
5026 I32 gimme = GIMME_V;
5027 I32 oldsave = PL_savestack_ix;
5028 I32 make_mortal = 1;
5029 MAGIC *mg = (MAGIC *) NULL;
5032 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5037 DIE(aTHX_ "panic: do_split");
5038 rx = pm->op_pmregexp;
5040 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5041 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5043 if (pm->op_pmreplroot) {
5045 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5047 ary = GvAVn((GV*)pm->op_pmreplroot);
5050 else if (gimme != G_ARRAY)
5052 ary = (AV*)PL_curpad[0];
5054 ary = GvAVn(PL_defgv);
5055 #endif /* USE_THREADS */
5058 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5064 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5066 XPUSHs(SvTIED_obj((SV*)ary, mg));
5072 for (i = AvFILLp(ary); i >= 0; i--)
5073 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5075 /* temporarily switch stacks */
5076 SWITCHSTACK(PL_curstack, ary);
5080 base = SP - PL_stack_base;
5082 if (pm->op_pmflags & PMf_SKIPWHITE) {
5083 if (pm->op_pmflags & PMf_LOCALE) {
5084 while (isSPACE_LC(*s))
5092 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5093 SAVEINT(PL_multiline);
5094 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5098 limit = maxiters + 2;
5099 if (pm->op_pmflags & PMf_WHITE) {
5102 while (m < strend &&
5103 !((pm->op_pmflags & PMf_LOCALE)
5104 ? isSPACE_LC(*m) : isSPACE(*m)))
5109 dstr = NEWSV(30, m-s);
5110 sv_setpvn(dstr, s, m-s);
5114 (void)SvUTF8_on(dstr);
5118 while (s < strend &&
5119 ((pm->op_pmflags & PMf_LOCALE)
5120 ? isSPACE_LC(*s) : isSPACE(*s)))
5124 else if (strEQ("^", rx->precomp)) {
5127 for (m = s; m < strend && *m != '\n'; m++) ;
5131 dstr = NEWSV(30, m-s);
5132 sv_setpvn(dstr, s, m-s);
5136 (void)SvUTF8_on(dstr);
5141 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5142 && (rx->reganch & ROPT_CHECK_ALL)
5143 && !(rx->reganch & ROPT_ANCH)) {
5144 int tail = (rx->reganch & RE_INTUIT_TAIL);
5145 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5148 if (len == 1 && !tail) {
5150 char c = *SvPV(csv, n_a);
5153 for (m = s; m < strend && *m != c; m++) ;
5156 dstr = NEWSV(30, m-s);
5157 sv_setpvn(dstr, s, m-s);
5161 (void)SvUTF8_on(dstr);
5163 /* The rx->minlen is in characters but we want to step
5164 * s ahead by bytes. */
5165 s = m + (doutf8 ? SvCUR(csv) : len);
5170 while (s < strend && --limit &&
5171 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5172 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5175 dstr = NEWSV(31, m-s);
5176 sv_setpvn(dstr, s, m-s);
5180 (void)SvUTF8_on(dstr);
5182 /* The rx->minlen is in characters but we want to step
5183 * s ahead by bytes. */
5184 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5189 maxiters += (strend - s) * rx->nparens;
5190 while (s < strend && --limit
5191 /* && (!rx->check_substr
5192 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5194 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5195 1 /* minend */, sv, NULL, 0))
5197 TAINT_IF(RX_MATCH_TAINTED(rx));
5198 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5203 strend = s + (strend - m);
5205 m = rx->startp[0] + orig;
5206 dstr = NEWSV(32, m-s);
5207 sv_setpvn(dstr, s, m-s);
5211 (void)SvUTF8_on(dstr);
5214 for (i = 1; i <= rx->nparens; i++) {
5215 s = rx->startp[i] + orig;
5216 m = rx->endp[i] + orig;
5218 dstr = NEWSV(33, m-s);
5219 sv_setpvn(dstr, s, m-s);
5222 dstr = NEWSV(33, 0);
5226 (void)SvUTF8_on(dstr);
5230 s = rx->endp[0] + orig;
5234 LEAVE_SCOPE(oldsave);
5235 iters = (SP - PL_stack_base) - base;
5236 if (iters > maxiters)
5237 DIE(aTHX_ "Split loop");
5239 /* keep field after final delim? */
5240 if (s < strend || (iters && origlimit)) {
5241 STRLEN l = strend - s;
5242 dstr = NEWSV(34, l);
5243 sv_setpvn(dstr, s, l);
5247 (void)SvUTF8_on(dstr);
5251 else if (!origlimit) {
5252 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5258 SWITCHSTACK(ary, oldstack);
5259 if (SvSMAGICAL(ary)) {
5264 if (gimme == G_ARRAY) {
5266 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5274 call_method("PUSH",G_SCALAR|G_DISCARD);
5277 if (gimme == G_ARRAY) {
5278 /* EXTEND should not be needed - we just popped them */
5280 for (i=0; i < iters; i++) {
5281 SV **svp = av_fetch(ary, i, FALSE);
5282 PUSHs((svp) ? *svp : &PL_sv_undef);
5289 if (gimme == G_ARRAY)
5292 if (iters || !pm->op_pmreplroot) {
5302 Perl_unlock_condpair(pTHX_ void *svv)
5305 MAGIC *mg = mg_find((SV*)svv, 'm');
5308 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5309 MUTEX_LOCK(MgMUTEXP(mg));
5310 if (MgOWNER(mg) != thr)
5311 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5313 COND_SIGNAL(MgOWNERCONDP(mg));
5314 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5315 PTR2UV(thr), PTR2UV(svv));)
5316 MUTEX_UNLOCK(MgMUTEXP(mg));
5318 #endif /* USE_THREADS */
5327 #endif /* USE_THREADS */
5328 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5329 || SvTYPE(retsv) == SVt_PVCV) {
5330 retsv = refto(retsv);
5341 if (PL_op->op_private & OPpLVAL_INTRO)
5342 PUSHs(*save_threadsv(PL_op->op_targ));
5344 PUSHs(THREADSV(PL_op->op_targ));
5347 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5348 #endif /* USE_THREADS */