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 if (SvTYPE(sv) < SVt_RV)
227 sv_upgrade(sv, SVt_RV);
233 if (PL_op->op_flags & OPf_REF ||
234 PL_op->op_private & HINT_STRICT_REFS)
235 DIE(aTHX_ PL_no_usym, "a symbol");
236 if (ckWARN(WARN_UNINITIALIZED))
241 if ((PL_op->op_flags & OPf_SPECIAL) &&
242 !(PL_op->op_flags & OPf_MOD))
244 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
246 && (!is_gv_magical(sym,len,0)
247 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
253 if (PL_op->op_private & HINT_STRICT_REFS)
254 DIE(aTHX_ PL_no_symref, sym, "a symbol");
255 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
259 if (PL_op->op_private & OPpLVAL_INTRO)
260 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
271 tryAMAGICunDEREF(to_sv);
274 switch (SvTYPE(sv)) {
278 DIE(aTHX_ "Not a SCALAR reference");
286 if (SvTYPE(gv) != SVt_PVGV) {
287 if (SvGMAGICAL(sv)) {
293 if (PL_op->op_flags & OPf_REF ||
294 PL_op->op_private & HINT_STRICT_REFS)
295 DIE(aTHX_ PL_no_usym, "a SCALAR");
296 if (ckWARN(WARN_UNINITIALIZED))
301 if ((PL_op->op_flags & OPf_SPECIAL) &&
302 !(PL_op->op_flags & OPf_MOD))
304 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
306 && (!is_gv_magical(sym,len,0)
307 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
313 if (PL_op->op_private & HINT_STRICT_REFS)
314 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
315 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
320 if (PL_op->op_flags & OPf_MOD) {
321 if (PL_op->op_private & OPpLVAL_INTRO)
322 sv = save_scalar((GV*)TOPs);
323 else if (PL_op->op_private & OPpDEREF)
324 vivify_ref(sv, PL_op->op_private & OPpDEREF);
334 SV *sv = AvARYLEN(av);
336 AvARYLEN(av) = sv = NEWSV(0,0);
337 sv_upgrade(sv, SVt_IV);
338 sv_magic(sv, (SV*)av, '#', Nullch, 0);
346 djSP; dTARGET; dPOPss;
348 if (PL_op->op_flags & OPf_MOD) {
349 if (SvTYPE(TARG) < SVt_PVLV) {
350 sv_upgrade(TARG, SVt_PVLV);
351 sv_magic(TARG, Nullsv, '.', Nullch, 0);
355 if (LvTARG(TARG) != sv) {
357 SvREFCNT_dec(LvTARG(TARG));
358 LvTARG(TARG) = SvREFCNT_inc(sv);
360 PUSHs(TARG); /* no SvSETMAGIC */
366 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
367 mg = mg_find(sv, 'g');
368 if (mg && mg->mg_len >= 0) {
372 PUSHi(i + PL_curcop->cop_arybase);
386 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
387 /* (But not in defined().) */
388 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
391 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
392 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
393 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
396 cv = (CV*)&PL_sv_undef;
410 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
411 char *s = SvPVX(TOPs);
412 if (strnEQ(s, "CORE::", 6)) {
415 code = keyword(s + 6, SvCUR(TOPs) - 6);
416 if (code < 0) { /* Overridable. */
417 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
418 int i = 0, n = 0, seen_question = 0;
420 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
422 while (i < MAXO) { /* The slow way. */
423 if (strEQ(s + 6, PL_op_name[i])
424 || strEQ(s + 6, PL_op_desc[i]))
430 goto nonesuch; /* Should not happen... */
432 oa = PL_opargs[i] >> OASHIFT;
434 if (oa & OA_OPTIONAL) {
438 else if (n && str[0] == ';' && seen_question)
439 goto set; /* XXXX system, exec */
440 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
441 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
444 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
445 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
449 ret = sv_2mortal(newSVpvn(str, n - 1));
451 else if (code) /* Non-Overridable */
453 else { /* None such */
455 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
459 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
461 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
470 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
472 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
488 if (GIMME != G_ARRAY) {
492 *MARK = &PL_sv_undef;
493 *MARK = refto(*MARK);
497 EXTEND_MORTAL(SP - MARK);
499 *MARK = refto(*MARK);
504 S_refto(pTHX_ SV *sv)
508 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
511 if (!(sv = LvTARG(sv)))
514 (void)SvREFCNT_inc(sv);
516 else if (SvTYPE(sv) == SVt_PVAV) {
517 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
520 (void)SvREFCNT_inc(sv);
522 else if (SvPADTMP(sv))
526 (void)SvREFCNT_inc(sv);
529 sv_upgrade(rv, SVt_RV);
543 if (sv && SvGMAGICAL(sv))
546 if (!sv || !SvROK(sv))
550 pv = sv_reftype(sv,TRUE);
551 PUSHp(pv, strlen(pv));
561 stash = CopSTASH(PL_curcop);
567 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
568 Perl_croak(aTHX_ "Attempt to bless into a reference");
570 if (ckWARN(WARN_MISC) && len == 0)
571 Perl_warner(aTHX_ WARN_MISC,
572 "Explicit blessing to '' (assuming package main)");
573 stash = gv_stashpvn(ptr, len, TRUE);
576 (void)sv_bless(TOPs, stash);
590 elem = SvPV(sv, n_a);
594 switch (elem ? *elem : '\0')
597 if (strEQ(elem, "ARRAY"))
598 tmpRef = (SV*)GvAV(gv);
601 if (strEQ(elem, "CODE"))
602 tmpRef = (SV*)GvCVu(gv);
605 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
606 tmpRef = (SV*)GvIOp(gv);
608 if (strEQ(elem, "FORMAT"))
609 tmpRef = (SV*)GvFORM(gv);
612 if (strEQ(elem, "GLOB"))
616 if (strEQ(elem, "HASH"))
617 tmpRef = (SV*)GvHV(gv);
620 if (strEQ(elem, "IO"))
621 tmpRef = (SV*)GvIOp(gv);
624 if (strEQ(elem, "NAME"))
625 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
628 if (strEQ(elem, "PACKAGE"))
629 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
632 if (strEQ(elem, "SCALAR"))
646 /* Pattern matching */
651 register unsigned char *s;
654 register I32 *sfirst;
658 if (sv == PL_lastscream) {
664 SvSCREAM_off(PL_lastscream);
665 SvREFCNT_dec(PL_lastscream);
667 PL_lastscream = SvREFCNT_inc(sv);
670 s = (unsigned char*)(SvPV(sv, len));
674 if (pos > PL_maxscream) {
675 if (PL_maxscream < 0) {
676 PL_maxscream = pos + 80;
677 New(301, PL_screamfirst, 256, I32);
678 New(302, PL_screamnext, PL_maxscream, I32);
681 PL_maxscream = pos + pos / 4;
682 Renew(PL_screamnext, PL_maxscream, I32);
686 sfirst = PL_screamfirst;
687 snext = PL_screamnext;
689 if (!sfirst || !snext)
690 DIE(aTHX_ "do_study: out of memory");
692 for (ch = 256; ch; --ch)
699 snext[pos] = sfirst[ch] - pos;
706 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
715 if (PL_op->op_flags & OPf_STACKED)
721 TARG = sv_newmortal();
726 /* Lvalue operators. */
738 djSP; dMARK; dTARGET;
748 SETi(do_chomp(TOPs));
754 djSP; dMARK; dTARGET;
755 register I32 count = 0;
758 count += do_chomp(POPs);
769 if (!sv || !SvANY(sv))
771 switch (SvTYPE(sv)) {
773 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
777 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
781 if (CvROOT(sv) || CvXSUB(sv))
798 if (!PL_op->op_private) {
807 if (SvTHINKFIRST(sv))
810 switch (SvTYPE(sv)) {
820 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
821 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
822 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
826 /* let user-undef'd sub keep its identity */
827 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
834 SvSetMagicSV(sv, &PL_sv_undef);
838 Newz(602, gp, 1, GP);
839 GvGP(sv) = gp_ref(gp);
840 GvSV(sv) = NEWSV(72,0);
841 GvLINE(sv) = CopLINE(PL_curcop);
847 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
850 SvPV_set(sv, Nullch);
863 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
864 DIE(aTHX_ PL_no_modify);
865 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
866 SvIVX(TOPs) != IV_MIN)
869 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
880 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
881 DIE(aTHX_ PL_no_modify);
882 sv_setsv(TARG, TOPs);
883 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
884 SvIVX(TOPs) != IV_MAX)
887 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
901 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
902 DIE(aTHX_ PL_no_modify);
903 sv_setsv(TARG, TOPs);
904 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
905 SvIVX(TOPs) != IV_MIN)
908 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
917 /* Ordinary operators. */
921 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
924 SETn( Perl_pow( left, right) );
931 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
934 SETn( left * right );
941 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
946 DIE(aTHX_ "Illegal division by zero");
948 /* insure that 20./5. == 4. */
951 if ((NV)I_V(left) == left &&
952 (NV)I_V(right) == right &&
953 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
957 value = left / right;
961 value = left / right;
970 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
980 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
982 right = (right_neg = (i < 0)) ? -i : i;
987 right_neg = dright < 0;
992 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
994 left = (left_neg = (i < 0)) ? -i : i;
1002 left_neg = dleft < 0;
1011 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1013 # define CAST_D2UV(d) U_V(d)
1015 # define CAST_D2UV(d) ((UV)(d))
1017 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1018 * or, in other words, precision of UV more than of NV.
1019 * But in fact the approach below turned out to be an
1020 * optimization - floor() may be slow */
1021 if (dright <= UV_MAX && dleft <= UV_MAX) {
1022 right = CAST_D2UV(dright);
1023 left = CAST_D2UV(dleft);
1028 /* Backward-compatibility clause: */
1029 dright = Perl_floor(dright + 0.5);
1030 dleft = Perl_floor(dleft + 0.5);
1033 DIE(aTHX_ "Illegal modulus zero");
1035 dans = Perl_fmod(dleft, dright);
1036 if ((left_neg != right_neg) && dans)
1037 dans = dright - dans;
1040 sv_setnv(TARG, dans);
1047 DIE(aTHX_ "Illegal modulus zero");
1050 if ((left_neg != right_neg) && ans)
1053 /* XXX may warn: unary minus operator applied to unsigned type */
1054 /* could change -foo to be (~foo)+1 instead */
1055 if (ans <= ~((UV)IV_MAX)+1)
1056 sv_setiv(TARG, ~ans+1);
1058 sv_setnv(TARG, -(NV)ans);
1061 sv_setuv(TARG, ans);
1070 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1072 register IV count = POPi;
1073 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1075 I32 items = SP - MARK;
1078 max = items * count;
1087 repeatcpy((char*)(MARK + items), (char*)MARK,
1088 items * sizeof(SV*), count - 1);
1091 else if (count <= 0)
1094 else { /* Note: mark already snarfed by pp_list */
1097 bool isutf = DO_UTF8(tmpstr);
1099 SvSetSV(TARG, tmpstr);
1100 SvPV_force(TARG, len);
1105 SvGROW(TARG, (count * len) + 1);
1106 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1107 SvCUR(TARG) *= count;
1109 *SvEND(TARG) = '\0';
1112 (void)SvPOK_only_UTF8(TARG);
1114 (void)SvPOK_only(TARG);
1123 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1126 SETn( left - right );
1133 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1136 if (PL_op->op_private & HINT_INTEGER) {
1150 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1153 if (PL_op->op_private & HINT_INTEGER) {
1167 djSP; tryAMAGICbinSET(lt,0);
1170 SETs(boolSV(TOPn < value));
1177 djSP; tryAMAGICbinSET(gt,0);
1180 SETs(boolSV(TOPn > value));
1187 djSP; tryAMAGICbinSET(le,0);
1190 SETs(boolSV(TOPn <= value));
1197 djSP; tryAMAGICbinSET(ge,0);
1200 SETs(boolSV(TOPn >= value));
1207 djSP; tryAMAGICbinSET(ne,0);
1210 SETs(boolSV(TOPn != value));
1217 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1223 if (Perl_isnan(left) || Perl_isnan(right)) {
1227 value = (left > right) - (left < right);
1231 else if (left < right)
1233 else if (left > right)
1247 djSP; tryAMAGICbinSET(slt,0);
1250 int cmp = ((PL_op->op_private & OPpLOCALE)
1251 ? sv_cmp_locale(left, right)
1252 : sv_cmp(left, right));
1253 SETs(boolSV(cmp < 0));
1260 djSP; tryAMAGICbinSET(sgt,0);
1263 int cmp = ((PL_op->op_private & OPpLOCALE)
1264 ? sv_cmp_locale(left, right)
1265 : sv_cmp(left, right));
1266 SETs(boolSV(cmp > 0));
1273 djSP; tryAMAGICbinSET(sle,0);
1276 int cmp = ((PL_op->op_private & OPpLOCALE)
1277 ? sv_cmp_locale(left, right)
1278 : sv_cmp(left, right));
1279 SETs(boolSV(cmp <= 0));
1286 djSP; tryAMAGICbinSET(sge,0);
1289 int cmp = ((PL_op->op_private & OPpLOCALE)
1290 ? sv_cmp_locale(left, right)
1291 : sv_cmp(left, right));
1292 SETs(boolSV(cmp >= 0));
1299 djSP; tryAMAGICbinSET(seq,0);
1302 SETs(boolSV(sv_eq(left, right)));
1309 djSP; tryAMAGICbinSET(sne,0);
1312 SETs(boolSV(!sv_eq(left, right)));
1319 djSP; dTARGET; tryAMAGICbin(scmp,0);
1322 int cmp = ((PL_op->op_private & OPpLOCALE)
1323 ? sv_cmp_locale(left, right)
1324 : sv_cmp(left, right));
1332 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1335 if (SvNIOKp(left) || SvNIOKp(right)) {
1336 if (PL_op->op_private & HINT_INTEGER) {
1337 IV i = SvIV(left) & SvIV(right);
1341 UV u = SvUV(left) & SvUV(right);
1346 do_vop(PL_op->op_type, TARG, left, right);
1355 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1358 if (SvNIOKp(left) || SvNIOKp(right)) {
1359 if (PL_op->op_private & HINT_INTEGER) {
1360 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1364 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1369 do_vop(PL_op->op_type, TARG, left, right);
1378 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1381 if (SvNIOKp(left) || SvNIOKp(right)) {
1382 if (PL_op->op_private & HINT_INTEGER) {
1383 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1387 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1392 do_vop(PL_op->op_type, TARG, left, right);
1401 djSP; dTARGET; tryAMAGICun(neg);
1406 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1408 if (SvIVX(sv) == IV_MIN) {
1409 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1412 else if (SvUVX(sv) <= IV_MAX) {
1417 else if (SvIVX(sv) != IV_MIN) {
1424 else if (SvPOKp(sv)) {
1426 char *s = SvPV(sv, len);
1427 if (isIDFIRST(*s)) {
1428 sv_setpvn(TARG, "-", 1);
1431 else if (*s == '+' || *s == '-') {
1433 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1435 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1436 sv_setpvn(TARG, "-", 1);
1440 sv_setnv(TARG, -SvNV(sv));
1451 djSP; tryAMAGICunSET(not);
1452 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1458 djSP; dTARGET; tryAMAGICun(compl);
1462 if (PL_op->op_private & HINT_INTEGER) {
1477 tmps = (U8*)SvPV_force(TARG, len);
1480 /* Calculate exact length, let's not estimate. */
1489 while (tmps < send) {
1490 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1491 tmps += UTF8SKIP(tmps);
1492 targlen += UNISKIP(~c);
1498 /* Now rewind strings and write them. */
1502 Newz(0, result, targlen + 1, U8);
1503 while (tmps < send) {
1504 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1505 tmps += UTF8SKIP(tmps);
1506 result = uv_to_utf8(result, ~c);
1510 sv_setpvn(TARG, (char*)result, targlen);
1514 Newz(0, result, nchar + 1, U8);
1515 while (tmps < send) {
1516 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
1517 tmps += UTF8SKIP(tmps);
1522 sv_setpvn(TARG, (char*)result, nchar);
1530 register long *tmpl;
1531 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1534 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1539 for ( ; anum > 0; anum--, tmps++)
1548 /* integer versions of some of the above */
1552 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1555 SETi( left * right );
1562 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1566 DIE(aTHX_ "Illegal division by zero");
1567 value = POPi / value;
1575 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1579 DIE(aTHX_ "Illegal modulus zero");
1580 SETi( left % right );
1587 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1590 SETi( left + right );
1597 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1600 SETi( left - right );
1607 djSP; tryAMAGICbinSET(lt,0);
1610 SETs(boolSV(left < right));
1617 djSP; tryAMAGICbinSET(gt,0);
1620 SETs(boolSV(left > right));
1627 djSP; tryAMAGICbinSET(le,0);
1630 SETs(boolSV(left <= right));
1637 djSP; tryAMAGICbinSET(ge,0);
1640 SETs(boolSV(left >= right));
1647 djSP; tryAMAGICbinSET(eq,0);
1650 SETs(boolSV(left == right));
1657 djSP; tryAMAGICbinSET(ne,0);
1660 SETs(boolSV(left != right));
1667 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1674 else if (left < right)
1685 djSP; dTARGET; tryAMAGICun(neg);
1690 /* High falutin' math. */
1694 djSP; dTARGET; tryAMAGICbin(atan2,0);
1697 SETn(Perl_atan2(left, right));
1704 djSP; dTARGET; tryAMAGICun(sin);
1708 value = Perl_sin(value);
1716 djSP; dTARGET; tryAMAGICun(cos);
1720 value = Perl_cos(value);
1726 /* Support Configure command-line overrides for rand() functions.
1727 After 5.005, perhaps we should replace this by Configure support
1728 for drand48(), random(), or rand(). For 5.005, though, maintain
1729 compatibility by calling rand() but allow the user to override it.
1730 See INSTALL for details. --Andy Dougherty 15 July 1998
1732 /* Now it's after 5.005, and Configure supports drand48() and random(),
1733 in addition to rand(). So the overrides should not be needed any more.
1734 --Jarkko Hietaniemi 27 September 1998
1737 #ifndef HAS_DRAND48_PROTO
1738 extern double drand48 (void);
1751 if (!PL_srand_called) {
1752 (void)seedDrand01((Rand_seed_t)seed());
1753 PL_srand_called = TRUE;
1768 (void)seedDrand01((Rand_seed_t)anum);
1769 PL_srand_called = TRUE;
1778 * This is really just a quick hack which grabs various garbage
1779 * values. It really should be a real hash algorithm which
1780 * spreads the effect of every input bit onto every output bit,
1781 * if someone who knows about such things would bother to write it.
1782 * Might be a good idea to add that function to CORE as well.
1783 * No numbers below come from careful analysis or anything here,
1784 * except they are primes and SEED_C1 > 1E6 to get a full-width
1785 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1786 * probably be bigger too.
1789 # define SEED_C1 1000003
1790 #define SEED_C4 73819
1792 # define SEED_C1 25747
1793 #define SEED_C4 20639
1797 #define SEED_C5 26107
1800 #ifndef PERL_NO_DEV_RANDOM
1805 # include <starlet.h>
1806 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1807 * in 100-ns units, typically incremented ever 10 ms. */
1808 unsigned int when[2];
1810 # ifdef HAS_GETTIMEOFDAY
1811 struct timeval when;
1817 /* This test is an escape hatch, this symbol isn't set by Configure. */
1818 #ifndef PERL_NO_DEV_RANDOM
1819 #ifndef PERL_RANDOM_DEVICE
1820 /* /dev/random isn't used by default because reads from it will block
1821 * if there isn't enough entropy available. You can compile with
1822 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1823 * is enough real entropy to fill the seed. */
1824 # define PERL_RANDOM_DEVICE "/dev/urandom"
1826 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1828 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1837 _ckvmssts(sys$gettim(when));
1838 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1840 # ifdef HAS_GETTIMEOFDAY
1841 gettimeofday(&when,(struct timezone *) 0);
1842 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1845 u = (U32)SEED_C1 * when;
1848 u += SEED_C3 * (U32)PerlProc_getpid();
1849 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1850 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1851 u += SEED_C5 * (U32)PTR2UV(&when);
1858 djSP; dTARGET; tryAMAGICun(exp);
1862 value = Perl_exp(value);
1870 djSP; dTARGET; tryAMAGICun(log);
1875 SET_NUMERIC_STANDARD();
1876 DIE(aTHX_ "Can't take log of %g", value);
1878 value = Perl_log(value);
1886 djSP; dTARGET; tryAMAGICun(sqrt);
1891 SET_NUMERIC_STANDARD();
1892 DIE(aTHX_ "Can't take sqrt of %g", value);
1894 value = Perl_sqrt(value);
1907 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1913 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1914 (void)Perl_modf(value, &value);
1916 double tmp = (double)value;
1917 (void)Perl_modf(tmp, &tmp);
1922 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1923 (void)Perl_modf(-value, &value);
1926 double tmp = (double)value;
1927 (void)Perl_modf(-tmp, &tmp);
1943 djSP; dTARGET; tryAMAGICun(abs);
1948 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1949 (iv = SvIVX(TOPs)) != IV_MIN) {
1971 argtype = 1; /* allow underscores */
1972 XPUSHn(scan_hex(tmps, 99, &argtype));
1985 while (*tmps && isSPACE(*tmps))
1989 argtype = 1; /* allow underscores */
1991 value = scan_hex(++tmps, 99, &argtype);
1992 else if (*tmps == 'b')
1993 value = scan_bin(++tmps, 99, &argtype);
1995 value = scan_oct(tmps, 99, &argtype);
2008 SETi(sv_len_utf8(sv));
2024 I32 lvalue = PL_op->op_flags & OPf_MOD;
2026 I32 arybase = PL_curcop->cop_arybase;
2030 SvTAINTED_off(TARG); /* decontaminate */
2031 SvUTF8_off(TARG); /* decontaminate */
2035 repl = SvPV(sv, repl_len);
2042 tmps = SvPV(sv, curlen);
2044 utfcurlen = sv_len_utf8(sv);
2045 if (utfcurlen == curlen)
2053 if (pos >= arybase) {
2071 else if (len >= 0) {
2073 if (rem > (I32)curlen)
2088 Perl_croak(aTHX_ "substr outside of string");
2089 if (ckWARN(WARN_SUBSTR))
2090 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2095 sv_pos_u2b(sv, &pos, &rem);
2097 sv_setpvn(TARG, tmps, rem);
2101 sv_insert(sv, pos, rem, repl, repl_len);
2102 else if (lvalue) { /* it's an lvalue! */
2103 if (!SvGMAGICAL(sv)) {
2107 if (ckWARN(WARN_SUBSTR))
2108 Perl_warner(aTHX_ WARN_SUBSTR,
2109 "Attempt to use reference as lvalue in substr");
2111 if (SvOK(sv)) /* is it defined ? */
2112 (void)SvPOK_only_UTF8(sv);
2114 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2117 if (SvTYPE(TARG) < SVt_PVLV) {
2118 sv_upgrade(TARG, SVt_PVLV);
2119 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2123 if (LvTARG(TARG) != sv) {
2125 SvREFCNT_dec(LvTARG(TARG));
2126 LvTARG(TARG) = SvREFCNT_inc(sv);
2128 LvTARGOFF(TARG) = pos;
2129 LvTARGLEN(TARG) = rem;
2133 PUSHs(TARG); /* avoid SvSETMAGIC here */
2140 register IV size = POPi;
2141 register IV offset = POPi;
2142 register SV *src = POPs;
2143 I32 lvalue = PL_op->op_flags & OPf_MOD;
2145 SvTAINTED_off(TARG); /* decontaminate */
2146 if (lvalue) { /* it's an lvalue! */
2147 if (SvTYPE(TARG) < SVt_PVLV) {
2148 sv_upgrade(TARG, SVt_PVLV);
2149 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2152 if (LvTARG(TARG) != src) {
2154 SvREFCNT_dec(LvTARG(TARG));
2155 LvTARG(TARG) = SvREFCNT_inc(src);
2157 LvTARGOFF(TARG) = offset;
2158 LvTARGLEN(TARG) = size;
2161 sv_setuv(TARG, do_vecget(src, offset, size));
2176 I32 arybase = PL_curcop->cop_arybase;
2181 offset = POPi - arybase;
2184 tmps = SvPV(big, biglen);
2185 if (offset > 0 && DO_UTF8(big))
2186 sv_pos_u2b(big, &offset, 0);
2189 else if (offset > biglen)
2191 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2192 (unsigned char*)tmps + biglen, little, 0)))
2195 retval = tmps2 - tmps;
2196 if (retval > 0 && DO_UTF8(big))
2197 sv_pos_b2u(big, &retval);
2198 PUSHi(retval + arybase);
2213 I32 arybase = PL_curcop->cop_arybase;
2219 tmps2 = SvPV(little, llen);
2220 tmps = SvPV(big, blen);
2224 if (offset > 0 && DO_UTF8(big))
2225 sv_pos_u2b(big, &offset, 0);
2226 offset = offset - arybase + llen;
2230 else if (offset > blen)
2232 if (!(tmps2 = rninstr(tmps, tmps + offset,
2233 tmps2, tmps2 + llen)))
2236 retval = tmps2 - tmps;
2237 if (retval > 0 && DO_UTF8(big))
2238 sv_pos_b2u(big, &retval);
2239 PUSHi(retval + arybase);
2245 djSP; dMARK; dORIGMARK; dTARGET;
2246 do_sprintf(TARG, SP-MARK, MARK+1);
2247 TAINT_IF(SvTAINTED(TARG));
2259 U8 *tmps = (U8*)SvPVx(tmpsv, len);
2262 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2263 value = utf8_to_uv(tmps, len, &retlen, 0);
2265 value = (UV)(*tmps & 255);
2276 (void)SvUPGRADE(TARG,SVt_PV);
2278 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2279 SvGROW(TARG, UTF8_MAXLEN+1);
2281 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2282 SvCUR_set(TARG, tmps - SvPVX(TARG));
2284 (void)SvPOK_only(TARG);
2295 (void)SvPOK_only(TARG);
2302 djSP; dTARGET; dPOPTOPssrl;
2305 char *tmps = SvPV(left, n_a);
2307 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2309 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2313 "The crypt() function is unimplemented due to excessive paranoia.");
2326 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2328 U8 tmpbuf[UTF8_MAXLEN];
2330 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2332 if (PL_op->op_private & OPpLOCALE) {
2335 uv = toTITLE_LC_uni(uv);
2338 uv = toTITLE_utf8(s);
2340 tend = uv_to_utf8(tmpbuf, uv);
2342 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2344 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2345 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2350 s = (U8*)SvPV_force(sv, slen);
2351 Copy(tmpbuf, s, ulen, U8);
2355 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2357 SvUTF8_off(TARG); /* decontaminate */
2362 s = (U8*)SvPV_force(sv, slen);
2364 if (PL_op->op_private & OPpLOCALE) {
2367 *s = toUPPER_LC(*s);
2385 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2387 U8 tmpbuf[UTF8_MAXLEN];
2389 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2391 if (PL_op->op_private & OPpLOCALE) {
2394 uv = toLOWER_LC_uni(uv);
2397 uv = toLOWER_utf8(s);
2399 tend = uv_to_utf8(tmpbuf, uv);
2401 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2403 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2404 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2409 s = (U8*)SvPV_force(sv, slen);
2410 Copy(tmpbuf, s, ulen, U8);
2414 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2416 SvUTF8_off(TARG); /* decontaminate */
2421 s = (U8*)SvPV_force(sv, slen);
2423 if (PL_op->op_private & OPpLOCALE) {
2426 *s = toLOWER_LC(*s);
2450 s = (U8*)SvPV(sv,len);
2452 SvUTF8_off(TARG); /* decontaminate */
2453 sv_setpvn(TARG, "", 0);
2457 (void)SvUPGRADE(TARG, SVt_PV);
2458 SvGROW(TARG, (len * 2) + 1);
2459 (void)SvPOK_only(TARG);
2460 d = (U8*)SvPVX(TARG);
2462 if (PL_op->op_private & OPpLOCALE) {
2466 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2472 d = uv_to_utf8(d, toUPPER_utf8( s ));
2478 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2483 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2485 SvUTF8_off(TARG); /* decontaminate */
2490 s = (U8*)SvPV_force(sv, len);
2492 register U8 *send = s + len;
2494 if (PL_op->op_private & OPpLOCALE) {
2497 for (; s < send; s++)
2498 *s = toUPPER_LC(*s);
2501 for (; s < send; s++)
2524 s = (U8*)SvPV(sv,len);
2526 SvUTF8_off(TARG); /* decontaminate */
2527 sv_setpvn(TARG, "", 0);
2531 (void)SvUPGRADE(TARG, SVt_PV);
2532 SvGROW(TARG, (len * 2) + 1);
2533 (void)SvPOK_only(TARG);
2534 d = (U8*)SvPVX(TARG);
2536 if (PL_op->op_private & OPpLOCALE) {
2540 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2546 d = uv_to_utf8(d, toLOWER_utf8(s));
2552 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2557 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2559 SvUTF8_off(TARG); /* decontaminate */
2565 s = (U8*)SvPV_force(sv, len);
2567 register U8 *send = s + len;
2569 if (PL_op->op_private & OPpLOCALE) {
2572 for (; s < send; s++)
2573 *s = toLOWER_LC(*s);
2576 for (; s < send; s++)
2591 register char *s = SvPV(sv,len);
2594 SvUTF8_off(TARG); /* decontaminate */
2596 (void)SvUPGRADE(TARG, SVt_PV);
2597 SvGROW(TARG, (len * 2) + 1);
2602 STRLEN ulen = UTF8SKIP(s);
2626 SvCUR_set(TARG, d - SvPVX(TARG));
2627 (void)SvPOK_only_UTF8(TARG);
2630 sv_setpvn(TARG, s, len);
2632 if (SvSMAGICAL(TARG))
2641 djSP; dMARK; dORIGMARK;
2643 register AV* av = (AV*)POPs;
2644 register I32 lval = PL_op->op_flags & OPf_MOD;
2645 I32 arybase = PL_curcop->cop_arybase;
2648 if (SvTYPE(av) == SVt_PVAV) {
2649 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2651 for (svp = MARK + 1; svp <= SP; svp++) {
2656 if (max > AvMAX(av))
2659 while (++MARK <= SP) {
2660 elem = SvIVx(*MARK);
2664 svp = av_fetch(av, elem, lval);
2666 if (!svp || *svp == &PL_sv_undef)
2667 DIE(aTHX_ PL_no_aelem, elem);
2668 if (PL_op->op_private & OPpLVAL_INTRO)
2669 save_aelem(av, elem, svp);
2671 *MARK = svp ? *svp : &PL_sv_undef;
2674 if (GIMME != G_ARRAY) {
2682 /* Associative arrays. */
2687 HV *hash = (HV*)POPs;
2689 I32 gimme = GIMME_V;
2690 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2693 /* might clobber stack_sp */
2694 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2699 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2700 if (gimme == G_ARRAY) {
2703 /* might clobber stack_sp */
2705 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2710 else if (gimme == G_SCALAR)
2729 I32 gimme = GIMME_V;
2730 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2734 if (PL_op->op_private & OPpSLICE) {
2738 hvtype = SvTYPE(hv);
2739 if (hvtype == SVt_PVHV) { /* hash element */
2740 while (++MARK <= SP) {
2741 sv = hv_delete_ent(hv, *MARK, discard, 0);
2742 *MARK = sv ? sv : &PL_sv_undef;
2745 else if (hvtype == SVt_PVAV) {
2746 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2747 while (++MARK <= SP) {
2748 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2749 *MARK = sv ? sv : &PL_sv_undef;
2752 else { /* pseudo-hash element */
2753 while (++MARK <= SP) {
2754 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2755 *MARK = sv ? sv : &PL_sv_undef;
2760 DIE(aTHX_ "Not a HASH reference");
2763 else if (gimme == G_SCALAR) {
2772 if (SvTYPE(hv) == SVt_PVHV)
2773 sv = hv_delete_ent(hv, keysv, discard, 0);
2774 else if (SvTYPE(hv) == SVt_PVAV) {
2775 if (PL_op->op_flags & OPf_SPECIAL)
2776 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2778 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2781 DIE(aTHX_ "Not a HASH reference");
2796 if (PL_op->op_private & OPpEXISTS_SUB) {
2800 cv = sv_2cv(sv, &hv, &gv, FALSE);
2803 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2809 if (SvTYPE(hv) == SVt_PVHV) {
2810 if (hv_exists_ent(hv, tmpsv, 0))
2813 else if (SvTYPE(hv) == SVt_PVAV) {
2814 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2815 if (av_exists((AV*)hv, SvIV(tmpsv)))
2818 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2822 DIE(aTHX_ "Not a HASH reference");
2829 djSP; dMARK; dORIGMARK;
2830 register HV *hv = (HV*)POPs;
2831 register I32 lval = PL_op->op_flags & OPf_MOD;
2832 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2834 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2835 DIE(aTHX_ "Can't localize pseudo-hash element");
2837 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2838 while (++MARK <= SP) {
2842 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2843 svp = he ? &HeVAL(he) : 0;
2846 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2849 if (!svp || *svp == &PL_sv_undef) {
2851 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2853 if (PL_op->op_private & OPpLVAL_INTRO)
2854 save_helem(hv, keysv, svp);
2856 *MARK = svp ? *svp : &PL_sv_undef;
2859 if (GIMME != G_ARRAY) {
2867 /* List operators. */
2872 if (GIMME != G_ARRAY) {
2874 *MARK = *SP; /* unwanted list, return last item */
2876 *MARK = &PL_sv_undef;
2885 SV **lastrelem = PL_stack_sp;
2886 SV **lastlelem = PL_stack_base + POPMARK;
2887 SV **firstlelem = PL_stack_base + POPMARK + 1;
2888 register SV **firstrelem = lastlelem + 1;
2889 I32 arybase = PL_curcop->cop_arybase;
2890 I32 lval = PL_op->op_flags & OPf_MOD;
2891 I32 is_something_there = lval;
2893 register I32 max = lastrelem - lastlelem;
2894 register SV **lelem;
2897 if (GIMME != G_ARRAY) {
2898 ix = SvIVx(*lastlelem);
2903 if (ix < 0 || ix >= max)
2904 *firstlelem = &PL_sv_undef;
2906 *firstlelem = firstrelem[ix];
2912 SP = firstlelem - 1;
2916 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2922 if (ix < 0 || ix >= max)
2923 *lelem = &PL_sv_undef;
2925 is_something_there = TRUE;
2926 if (!(*lelem = firstrelem[ix]))
2927 *lelem = &PL_sv_undef;
2930 if (is_something_there)
2933 SP = firstlelem - 1;
2939 djSP; dMARK; dORIGMARK;
2940 I32 items = SP - MARK;
2941 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2942 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2949 djSP; dMARK; dORIGMARK;
2950 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2954 SV *val = NEWSV(46, 0);
2956 sv_setsv(val, *++MARK);
2957 else if (ckWARN(WARN_MISC))
2958 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2959 (void)hv_store_ent(hv,key,val,0);
2968 djSP; dMARK; dORIGMARK;
2969 register AV *ary = (AV*)*++MARK;
2973 register I32 offset;
2974 register I32 length;
2981 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2982 *MARK-- = SvTIED_obj((SV*)ary, mg);
2986 call_method("SPLICE",GIMME_V);
2995 offset = i = SvIVx(*MARK);
2997 offset += AvFILLp(ary) + 1;
2999 offset -= PL_curcop->cop_arybase;
3001 DIE(aTHX_ PL_no_aelem, i);
3003 length = SvIVx(*MARK++);
3005 length += AvFILLp(ary) - offset + 1;
3011 length = AvMAX(ary) + 1; /* close enough to infinity */
3015 length = AvMAX(ary) + 1;
3017 if (offset > AvFILLp(ary) + 1)
3018 offset = AvFILLp(ary) + 1;
3019 after = AvFILLp(ary) + 1 - (offset + length);
3020 if (after < 0) { /* not that much array */
3021 length += after; /* offset+length now in array */
3027 /* At this point, MARK .. SP-1 is our new LIST */
3030 diff = newlen - length;
3031 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3034 if (diff < 0) { /* shrinking the area */
3036 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3037 Copy(MARK, tmparyval, newlen, SV*);
3040 MARK = ORIGMARK + 1;
3041 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3042 MEXTEND(MARK, length);
3043 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3045 EXTEND_MORTAL(length);
3046 for (i = length, dst = MARK; i; i--) {
3047 sv_2mortal(*dst); /* free them eventualy */
3054 *MARK = AvARRAY(ary)[offset+length-1];
3057 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3058 SvREFCNT_dec(*dst++); /* free them now */
3061 AvFILLp(ary) += diff;
3063 /* pull up or down? */
3065 if (offset < after) { /* easier to pull up */
3066 if (offset) { /* esp. if nothing to pull */
3067 src = &AvARRAY(ary)[offset-1];
3068 dst = src - diff; /* diff is negative */
3069 for (i = offset; i > 0; i--) /* can't trust Copy */
3073 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3077 if (after) { /* anything to pull down? */
3078 src = AvARRAY(ary) + offset + length;
3079 dst = src + diff; /* diff is negative */
3080 Move(src, dst, after, SV*);
3082 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3083 /* avoid later double free */
3087 dst[--i] = &PL_sv_undef;
3090 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3092 *dst = NEWSV(46, 0);
3093 sv_setsv(*dst++, *src++);
3095 Safefree(tmparyval);
3098 else { /* no, expanding (or same) */
3100 New(452, tmparyval, length, SV*); /* so remember deletion */
3101 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3104 if (diff > 0) { /* expanding */
3106 /* push up or down? */
3108 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3112 Move(src, dst, offset, SV*);
3114 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3116 AvFILLp(ary) += diff;
3119 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3120 av_extend(ary, AvFILLp(ary) + diff);
3121 AvFILLp(ary) += diff;
3124 dst = AvARRAY(ary) + AvFILLp(ary);
3126 for (i = after; i; i--) {
3133 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3134 *dst = NEWSV(46, 0);
3135 sv_setsv(*dst++, *src++);
3137 MARK = ORIGMARK + 1;
3138 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3140 Copy(tmparyval, MARK, length, SV*);
3142 EXTEND_MORTAL(length);
3143 for (i = length, dst = MARK; i; i--) {
3144 sv_2mortal(*dst); /* free them eventualy */
3148 Safefree(tmparyval);
3152 else if (length--) {
3153 *MARK = tmparyval[length];
3156 while (length-- > 0)
3157 SvREFCNT_dec(tmparyval[length]);
3159 Safefree(tmparyval);
3162 *MARK = &PL_sv_undef;
3170 djSP; dMARK; dORIGMARK; dTARGET;
3171 register AV *ary = (AV*)*++MARK;
3172 register SV *sv = &PL_sv_undef;
3175 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3176 *MARK-- = SvTIED_obj((SV*)ary, mg);
3180 call_method("PUSH",G_SCALAR|G_DISCARD);
3185 /* Why no pre-extend of ary here ? */
3186 for (++MARK; MARK <= SP; MARK++) {
3189 sv_setsv(sv, *MARK);
3194 PUSHi( AvFILL(ary) + 1 );
3202 SV *sv = av_pop(av);
3204 (void)sv_2mortal(sv);
3213 SV *sv = av_shift(av);
3218 (void)sv_2mortal(sv);
3225 djSP; dMARK; dORIGMARK; dTARGET;
3226 register AV *ary = (AV*)*++MARK;
3231 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3232 *MARK-- = SvTIED_obj((SV*)ary, mg);
3236 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3241 av_unshift(ary, SP - MARK);
3244 sv_setsv(sv, *++MARK);
3245 (void)av_store(ary, i++, sv);
3249 PUSHi( AvFILL(ary) + 1 );
3259 if (GIMME == G_ARRAY) {
3266 /* safe as long as stack cannot get extended in the above */
3271 register char *down;
3276 SvUTF8_off(TARG); /* decontaminate */
3278 do_join(TARG, &PL_sv_no, MARK, SP);
3280 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3281 up = SvPV_force(TARG, len);
3283 if (DO_UTF8(TARG)) { /* first reverse each character */
3284 U8* s = (U8*)SvPVX(TARG);
3285 U8* send = (U8*)(s + len);
3294 down = (char*)(s - 1);
3295 if (s > send || !((*down & 0xc0) == 0x80)) {
3296 if (ckWARN_d(WARN_UTF8))
3297 Perl_warner(aTHX_ WARN_UTF8,
3298 "Malformed UTF-8 character");
3310 down = SvPVX(TARG) + len - 1;
3316 (void)SvPOK_only_UTF8(TARG);
3325 S_mul128(pTHX_ SV *sv, U8 m)
3328 char *s = SvPV(sv, len);
3332 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3333 SV *tmpNew = newSVpvn("0000000000", 10);
3335 sv_catsv(tmpNew, sv);
3336 SvREFCNT_dec(sv); /* free old sv */
3341 while (!*t) /* trailing '\0'? */
3344 i = ((*t - '0') << 7) + m;
3345 *(t--) = '0' + (i % 10);
3351 /* Explosives and implosives. */
3353 #if 'I' == 73 && 'J' == 74
3354 /* On an ASCII/ISO kind of system */
3355 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3358 Some other sort of character set - use memchr() so we don't match
3361 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3368 I32 start_sp_offset = SP - PL_stack_base;
3369 I32 gimme = GIMME_V;
3373 register char *pat = SvPV(left, llen);
3374 register char *s = SvPV(right, rlen);
3375 char *strend = s + rlen;
3377 register char *patend = pat + llen;
3383 /* These must not be in registers: */
3400 register U32 culong;
3404 #ifdef PERL_NATINT_PACK
3405 int natint; /* native integer */
3406 int unatint; /* unsigned native integer */
3409 if (gimme != G_ARRAY) { /* arrange to do first one only */
3411 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3412 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3414 while (isDIGIT(*patend) || *patend == '*')
3420 while (pat < patend) {
3422 datumtype = *pat++ & 0xFF;
3423 #ifdef PERL_NATINT_PACK
3426 if (isSPACE(datumtype))
3428 if (datumtype == '#') {
3429 while (pat < patend && *pat != '\n')
3434 char *natstr = "sSiIlL";
3436 if (strchr(natstr, datumtype)) {
3437 #ifdef PERL_NATINT_PACK
3443 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3448 else if (*pat == '*') {
3449 len = strend - strbeg; /* long enough */
3453 else if (isDIGIT(*pat)) {
3455 while (isDIGIT(*pat)) {
3456 len = (len * 10) + (*pat++ - '0');
3458 DIE(aTHX_ "Repeat count in unpack overflows");
3462 len = (datumtype != '@');
3466 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3467 case ',': /* grandfather in commas but with a warning */
3468 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3469 Perl_warner(aTHX_ WARN_UNPACK,
3470 "Invalid type in unpack: '%c'", (int)datumtype);
3473 if (len == 1 && pat[-1] != '1')
3482 if (len > strend - strbeg)
3483 DIE(aTHX_ "@ outside of string");
3487 if (len > s - strbeg)
3488 DIE(aTHX_ "X outside of string");
3492 if (len > strend - s)
3493 DIE(aTHX_ "x outside of string");
3497 if (start_sp_offset >= SP - PL_stack_base)
3498 DIE(aTHX_ "/ must follow a numeric type");
3501 pat++; /* ignore '*' for compatibility with pack */
3503 DIE(aTHX_ "/ cannot take a count" );
3510 if (len > strend - s)
3513 goto uchar_checksum;
3514 sv = NEWSV(35, len);
3515 sv_setpvn(sv, s, len);
3517 if (datumtype == 'A' || datumtype == 'Z') {
3518 aptr = s; /* borrow register */
3519 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3524 else { /* 'A' strips both nulls and spaces */
3525 s = SvPVX(sv) + len - 1;
3526 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3530 SvCUR_set(sv, s - SvPVX(sv));
3531 s = aptr; /* unborrow register */
3533 XPUSHs(sv_2mortal(sv));
3537 if (star || len > (strend - s) * 8)
3538 len = (strend - s) * 8;
3541 Newz(601, PL_bitcount, 256, char);
3542 for (bits = 1; bits < 256; bits++) {
3543 if (bits & 1) PL_bitcount[bits]++;
3544 if (bits & 2) PL_bitcount[bits]++;
3545 if (bits & 4) PL_bitcount[bits]++;
3546 if (bits & 8) PL_bitcount[bits]++;
3547 if (bits & 16) PL_bitcount[bits]++;
3548 if (bits & 32) PL_bitcount[bits]++;
3549 if (bits & 64) PL_bitcount[bits]++;
3550 if (bits & 128) PL_bitcount[bits]++;
3554 culong += PL_bitcount[*(unsigned char*)s++];
3559 if (datumtype == 'b') {
3561 if (bits & 1) culong++;
3567 if (bits & 128) culong++;
3574 sv = NEWSV(35, len + 1);
3578 if (datumtype == 'b') {
3580 for (len = 0; len < aint; len++) {
3581 if (len & 7) /*SUPPRESS 595*/
3585 *str++ = '0' + (bits & 1);
3590 for (len = 0; len < aint; len++) {
3595 *str++ = '0' + ((bits & 128) != 0);
3599 XPUSHs(sv_2mortal(sv));
3603 if (star || len > (strend - s) * 2)
3604 len = (strend - s) * 2;
3605 sv = NEWSV(35, len + 1);
3609 if (datumtype == 'h') {
3611 for (len = 0; len < aint; len++) {
3616 *str++ = PL_hexdigit[bits & 15];
3621 for (len = 0; len < aint; len++) {
3626 *str++ = PL_hexdigit[(bits >> 4) & 15];
3630 XPUSHs(sv_2mortal(sv));
3633 if (len > strend - s)
3638 if (aint >= 128) /* fake up signed chars */
3648 if (aint >= 128) /* fake up signed chars */
3651 sv_setiv(sv, (IV)aint);
3652 PUSHs(sv_2mortal(sv));
3657 if (len > strend - s)
3672 sv_setiv(sv, (IV)auint);
3673 PUSHs(sv_2mortal(sv));
3678 if (len > strend - s)
3681 while (len-- > 0 && s < strend) {
3683 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3687 cdouble += (NV)auint;
3695 while (len-- > 0 && s < strend) {
3697 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3701 sv_setuv(sv, (UV)auint);
3702 PUSHs(sv_2mortal(sv));
3707 #if SHORTSIZE == SIZE16
3708 along = (strend - s) / SIZE16;
3710 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3715 #if SHORTSIZE != SIZE16
3719 COPYNN(s, &ashort, sizeof(short));
3730 #if SHORTSIZE > SIZE16
3742 #if SHORTSIZE != SIZE16
3746 COPYNN(s, &ashort, sizeof(short));
3749 sv_setiv(sv, (IV)ashort);
3750 PUSHs(sv_2mortal(sv));
3758 #if SHORTSIZE > SIZE16
3764 sv_setiv(sv, (IV)ashort);
3765 PUSHs(sv_2mortal(sv));
3773 #if SHORTSIZE == SIZE16
3774 along = (strend - s) / SIZE16;
3776 unatint = natint && datumtype == 'S';
3777 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3782 #if SHORTSIZE != SIZE16
3784 unsigned short aushort;
3786 COPYNN(s, &aushort, sizeof(unsigned short));
3787 s += sizeof(unsigned short);
3795 COPY16(s, &aushort);
3798 if (datumtype == 'n')
3799 aushort = PerlSock_ntohs(aushort);
3802 if (datumtype == 'v')
3803 aushort = vtohs(aushort);
3812 #if SHORTSIZE != SIZE16
3814 unsigned short aushort;
3816 COPYNN(s, &aushort, sizeof(unsigned short));
3817 s += sizeof(unsigned short);
3819 sv_setiv(sv, (UV)aushort);
3820 PUSHs(sv_2mortal(sv));
3827 COPY16(s, &aushort);
3831 if (datumtype == 'n')
3832 aushort = PerlSock_ntohs(aushort);
3835 if (datumtype == 'v')
3836 aushort = vtohs(aushort);
3838 sv_setiv(sv, (UV)aushort);
3839 PUSHs(sv_2mortal(sv));
3845 along = (strend - s) / sizeof(int);
3850 Copy(s, &aint, 1, int);
3853 cdouble += (NV)aint;
3862 Copy(s, &aint, 1, int);
3866 /* Without the dummy below unpack("i", pack("i",-1))
3867 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3868 * cc with optimization turned on.
3870 * The bug was detected in
3871 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3872 * with optimization (-O4) turned on.
3873 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3874 * does not have this problem even with -O4.
3876 * This bug was reported as DECC_BUGS 1431
3877 * and tracked internally as GEM_BUGS 7775.
3879 * The bug is fixed in
3880 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3881 * UNIX V4.0F support: DEC C V5.9-006 or later
3882 * UNIX V4.0E support: DEC C V5.8-011 or later
3885 * See also few lines later for the same bug.
3888 sv_setiv(sv, (IV)aint) :
3890 sv_setiv(sv, (IV)aint);
3891 PUSHs(sv_2mortal(sv));
3896 along = (strend - s) / sizeof(unsigned int);
3901 Copy(s, &auint, 1, unsigned int);
3902 s += sizeof(unsigned int);
3904 cdouble += (NV)auint;
3913 Copy(s, &auint, 1, unsigned int);
3914 s += sizeof(unsigned int);
3917 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3918 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3919 * See details few lines earlier. */
3921 sv_setuv(sv, (UV)auint) :
3923 sv_setuv(sv, (UV)auint);
3924 PUSHs(sv_2mortal(sv));
3929 #if LONGSIZE == SIZE32
3930 along = (strend - s) / SIZE32;
3932 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3937 #if LONGSIZE != SIZE32
3940 COPYNN(s, &along, sizeof(long));
3943 cdouble += (NV)along;
3952 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3956 #if LONGSIZE > SIZE32
3957 if (along > 2147483647)
3958 along -= 4294967296;
3962 cdouble += (NV)along;
3971 #if LONGSIZE != SIZE32
3974 COPYNN(s, &along, sizeof(long));
3977 sv_setiv(sv, (IV)along);
3978 PUSHs(sv_2mortal(sv));
3985 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3989 #if LONGSIZE > SIZE32
3990 if (along > 2147483647)
3991 along -= 4294967296;
3995 sv_setiv(sv, (IV)along);
3996 PUSHs(sv_2mortal(sv));
4004 #if LONGSIZE == SIZE32
4005 along = (strend - s) / SIZE32;
4007 unatint = natint && datumtype == 'L';
4008 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4013 #if LONGSIZE != SIZE32
4015 unsigned long aulong;
4017 COPYNN(s, &aulong, sizeof(unsigned long));
4018 s += sizeof(unsigned long);
4020 cdouble += (NV)aulong;
4032 if (datumtype == 'N')
4033 aulong = PerlSock_ntohl(aulong);
4036 if (datumtype == 'V')
4037 aulong = vtohl(aulong);
4040 cdouble += (NV)aulong;
4049 #if LONGSIZE != SIZE32
4051 unsigned long aulong;
4053 COPYNN(s, &aulong, sizeof(unsigned long));
4054 s += sizeof(unsigned long);
4056 sv_setuv(sv, (UV)aulong);
4057 PUSHs(sv_2mortal(sv));
4067 if (datumtype == 'N')
4068 aulong = PerlSock_ntohl(aulong);
4071 if (datumtype == 'V')
4072 aulong = vtohl(aulong);
4075 sv_setuv(sv, (UV)aulong);
4076 PUSHs(sv_2mortal(sv));
4082 along = (strend - s) / sizeof(char*);
4088 if (sizeof(char*) > strend - s)
4091 Copy(s, &aptr, 1, char*);
4097 PUSHs(sv_2mortal(sv));
4107 while ((len > 0) && (s < strend)) {
4108 auv = (auv << 7) | (*s & 0x7f);
4109 if (!(*s++ & 0x80)) {
4113 PUSHs(sv_2mortal(sv));
4117 else if (++bytes >= sizeof(UV)) { /* promote to string */
4121 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4122 while (s < strend) {
4123 sv = mul128(sv, *s & 0x7f);
4124 if (!(*s++ & 0x80)) {
4133 PUSHs(sv_2mortal(sv));
4138 if ((s >= strend) && bytes)
4139 DIE(aTHX_ "Unterminated compressed integer");
4144 if (sizeof(char*) > strend - s)
4147 Copy(s, &aptr, 1, char*);
4152 sv_setpvn(sv, aptr, len);
4153 PUSHs(sv_2mortal(sv));
4157 along = (strend - s) / sizeof(Quad_t);
4163 if (s + sizeof(Quad_t) > strend)
4166 Copy(s, &aquad, 1, Quad_t);
4167 s += sizeof(Quad_t);
4170 if (aquad >= IV_MIN && aquad <= IV_MAX)
4171 sv_setiv(sv, (IV)aquad);
4173 sv_setnv(sv, (NV)aquad);
4174 PUSHs(sv_2mortal(sv));
4178 along = (strend - s) / sizeof(Quad_t);
4184 if (s + sizeof(Uquad_t) > strend)
4187 Copy(s, &auquad, 1, Uquad_t);
4188 s += sizeof(Uquad_t);
4191 if (auquad <= UV_MAX)
4192 sv_setuv(sv, (UV)auquad);
4194 sv_setnv(sv, (NV)auquad);
4195 PUSHs(sv_2mortal(sv));
4199 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4202 along = (strend - s) / sizeof(float);
4207 Copy(s, &afloat, 1, float);
4216 Copy(s, &afloat, 1, float);
4219 sv_setnv(sv, (NV)afloat);
4220 PUSHs(sv_2mortal(sv));
4226 along = (strend - s) / sizeof(double);
4231 Copy(s, &adouble, 1, double);
4232 s += sizeof(double);
4240 Copy(s, &adouble, 1, double);
4241 s += sizeof(double);
4243 sv_setnv(sv, (NV)adouble);
4244 PUSHs(sv_2mortal(sv));
4250 * Initialise the decode mapping. By using a table driven
4251 * algorithm, the code will be character-set independent
4252 * (and just as fast as doing character arithmetic)
4254 if (PL_uudmap['M'] == 0) {
4257 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4258 PL_uudmap[(U8)PL_uuemap[i]] = i;
4260 * Because ' ' and '`' map to the same value,
4261 * we need to decode them both the same.
4266 along = (strend - s) * 3 / 4;
4267 sv = NEWSV(42, along);
4270 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4275 len = PL_uudmap[*(U8*)s++] & 077;
4277 if (s < strend && ISUUCHAR(*s))
4278 a = PL_uudmap[*(U8*)s++] & 077;
4281 if (s < strend && ISUUCHAR(*s))
4282 b = PL_uudmap[*(U8*)s++] & 077;
4285 if (s < strend && ISUUCHAR(*s))
4286 c = PL_uudmap[*(U8*)s++] & 077;
4289 if (s < strend && ISUUCHAR(*s))
4290 d = PL_uudmap[*(U8*)s++] & 077;
4293 hunk[0] = (a << 2) | (b >> 4);
4294 hunk[1] = (b << 4) | (c >> 2);
4295 hunk[2] = (c << 6) | d;
4296 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4301 else if (s[1] == '\n') /* possible checksum byte */
4304 XPUSHs(sv_2mortal(sv));
4309 if (strchr("fFdD", datumtype) ||
4310 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4314 while (checksum >= 16) {
4318 while (checksum >= 4) {
4324 along = (1 << checksum) - 1;
4325 while (cdouble < 0.0)
4327 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4328 sv_setnv(sv, cdouble);
4331 if (checksum < 32) {
4332 aulong = (1 << checksum) - 1;
4335 sv_setuv(sv, (UV)culong);
4337 XPUSHs(sv_2mortal(sv));
4341 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4342 PUSHs(&PL_sv_undef);
4347 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4351 *hunk = PL_uuemap[len];
4352 sv_catpvn(sv, hunk, 1);
4355 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4356 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4357 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4358 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4359 sv_catpvn(sv, hunk, 4);
4364 char r = (len > 1 ? s[1] : '\0');
4365 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4366 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4367 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4368 hunk[3] = PL_uuemap[0];
4369 sv_catpvn(sv, hunk, 4);
4371 sv_catpvn(sv, "\n", 1);
4375 S_is_an_int(pTHX_ char *s, STRLEN l)
4378 SV *result = newSVpvn(s, l);
4379 char *result_c = SvPV(result, n_a); /* convenience */
4380 char *out = result_c;
4390 SvREFCNT_dec(result);
4413 SvREFCNT_dec(result);
4419 SvCUR_set(result, out - result_c);
4423 /* pnum must be '\0' terminated */
4425 S_div128(pTHX_ SV *pnum, bool *done)
4428 char *s = SvPV(pnum, len);
4437 i = m * 10 + (*t - '0');
4439 r = (i >> 7); /* r < 10 */
4446 SvCUR_set(pnum, (STRLEN) (t - s));
4453 djSP; dMARK; dORIGMARK; dTARGET;
4454 register SV *cat = TARG;
4457 register char *pat = SvPVx(*++MARK, fromlen);
4459 register char *patend = pat + fromlen;
4464 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4465 static char *space10 = " ";
4467 /* These must not be in registers: */
4482 #ifdef PERL_NATINT_PACK
4483 int natint; /* native integer */
4488 sv_setpvn(cat, "", 0);
4490 while (pat < patend) {
4491 SV *lengthcode = Nullsv;
4492 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4493 datumtype = *pat++ & 0xFF;
4494 #ifdef PERL_NATINT_PACK
4497 if (isSPACE(datumtype)) {
4501 if (datumtype == 'U' && pat == patcopy+1)
4503 if (datumtype == '#') {
4504 while (pat < patend && *pat != '\n')
4509 char *natstr = "sSiIlL";
4511 if (strchr(natstr, datumtype)) {
4512 #ifdef PERL_NATINT_PACK
4518 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4521 len = strchr("@Xxu", datumtype) ? 0 : items;
4524 else if (isDIGIT(*pat)) {
4526 while (isDIGIT(*pat)) {
4527 len = (len * 10) + (*pat++ - '0');
4529 DIE(aTHX_ "Repeat count in pack overflows");
4536 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4537 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4538 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4539 ? *MARK : &PL_sv_no)
4540 + (*pat == 'Z' ? 1 : 0)));
4544 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4545 case ',': /* grandfather in commas but with a warning */
4546 if (commas++ == 0 && ckWARN(WARN_PACK))
4547 Perl_warner(aTHX_ WARN_PACK,
4548 "Invalid type in pack: '%c'", (int)datumtype);
4551 DIE(aTHX_ "%% may only be used in unpack");
4562 if (SvCUR(cat) < len)
4563 DIE(aTHX_ "X outside of string");
4570 sv_catpvn(cat, null10, 10);
4573 sv_catpvn(cat, null10, len);
4579 aptr = SvPV(fromstr, fromlen);
4580 if (pat[-1] == '*') {
4582 if (datumtype == 'Z')
4585 if (fromlen >= len) {
4586 sv_catpvn(cat, aptr, len);
4587 if (datumtype == 'Z')
4588 *(SvEND(cat)-1) = '\0';
4591 sv_catpvn(cat, aptr, fromlen);
4593 if (datumtype == 'A') {
4595 sv_catpvn(cat, space10, 10);
4598 sv_catpvn(cat, space10, len);
4602 sv_catpvn(cat, null10, 10);
4605 sv_catpvn(cat, null10, len);
4617 str = SvPV(fromstr, fromlen);
4621 SvCUR(cat) += (len+7)/8;
4622 SvGROW(cat, SvCUR(cat) + 1);
4623 aptr = SvPVX(cat) + aint;
4628 if (datumtype == 'B') {
4629 for (len = 0; len++ < aint;) {
4630 items |= *str++ & 1;
4634 *aptr++ = items & 0xff;
4640 for (len = 0; len++ < aint;) {
4646 *aptr++ = items & 0xff;
4652 if (datumtype == 'B')
4653 items <<= 7 - (aint & 7);
4655 items >>= 7 - (aint & 7);
4656 *aptr++ = items & 0xff;
4658 str = SvPVX(cat) + SvCUR(cat);
4673 str = SvPV(fromstr, fromlen);
4677 SvCUR(cat) += (len+1)/2;
4678 SvGROW(cat, SvCUR(cat) + 1);
4679 aptr = SvPVX(cat) + aint;
4684 if (datumtype == 'H') {
4685 for (len = 0; len++ < aint;) {
4687 items |= ((*str++ & 15) + 9) & 15;
4689 items |= *str++ & 15;
4693 *aptr++ = items & 0xff;
4699 for (len = 0; len++ < aint;) {
4701 items |= (((*str++ & 15) + 9) & 15) << 4;
4703 items |= (*str++ & 15) << 4;
4707 *aptr++ = items & 0xff;
4713 *aptr++ = items & 0xff;
4714 str = SvPVX(cat) + SvCUR(cat);
4725 aint = SvIV(fromstr);
4727 sv_catpvn(cat, &achar, sizeof(char));
4733 auint = SvUV(fromstr);
4734 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4735 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4740 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4745 afloat = (float)SvNV(fromstr);
4746 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4753 adouble = (double)SvNV(fromstr);
4754 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4760 ashort = (I16)SvIV(fromstr);
4762 ashort = PerlSock_htons(ashort);
4764 CAT16(cat, &ashort);
4770 ashort = (I16)SvIV(fromstr);
4772 ashort = htovs(ashort);
4774 CAT16(cat, &ashort);
4778 #if SHORTSIZE != SIZE16
4780 unsigned short aushort;
4784 aushort = SvUV(fromstr);
4785 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4795 aushort = (U16)SvUV(fromstr);
4796 CAT16(cat, &aushort);
4802 #if SHORTSIZE != SIZE16
4808 ashort = SvIV(fromstr);
4809 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4817 ashort = (I16)SvIV(fromstr);
4818 CAT16(cat, &ashort);
4825 auint = SvUV(fromstr);
4826 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4832 adouble = Perl_floor(SvNV(fromstr));
4835 DIE(aTHX_ "Cannot compress negative numbers");
4838 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4839 adouble <= 0xffffffff
4841 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4842 adouble <= UV_MAX_cxux
4849 char buf[1 + sizeof(UV)];
4850 char *in = buf + sizeof(buf);
4851 UV auv = U_V(adouble);
4854 *--in = (auv & 0x7f) | 0x80;
4857 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4858 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4860 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4861 char *from, *result, *in;
4866 /* Copy string and check for compliance */
4867 from = SvPV(fromstr, len);
4868 if ((norm = is_an_int(from, len)) == NULL)
4869 DIE(aTHX_ "can compress only unsigned integer");
4871 New('w', result, len, char);
4875 *--in = div128(norm, &done) | 0x80;
4876 result[len - 1] &= 0x7F; /* clear continue bit */
4877 sv_catpvn(cat, in, (result + len) - in);
4879 SvREFCNT_dec(norm); /* free norm */
4881 else if (SvNOKp(fromstr)) {
4882 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4883 char *in = buf + sizeof(buf);
4886 double next = floor(adouble / 128);
4887 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4888 if (in <= buf) /* this cannot happen ;-) */
4889 DIE(aTHX_ "Cannot compress integer");
4892 } while (adouble > 0);
4893 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4894 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4897 DIE(aTHX_ "Cannot compress non integer");
4903 aint = SvIV(fromstr);
4904 sv_catpvn(cat, (char*)&aint, sizeof(int));
4910 aulong = SvUV(fromstr);
4912 aulong = PerlSock_htonl(aulong);
4914 CAT32(cat, &aulong);
4920 aulong = SvUV(fromstr);
4922 aulong = htovl(aulong);
4924 CAT32(cat, &aulong);
4928 #if LONGSIZE != SIZE32
4930 unsigned long aulong;
4934 aulong = SvUV(fromstr);
4935 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4943 aulong = SvUV(fromstr);
4944 CAT32(cat, &aulong);
4949 #if LONGSIZE != SIZE32
4955 along = SvIV(fromstr);
4956 sv_catpvn(cat, (char *)&along, sizeof(long));
4964 along = SvIV(fromstr);
4973 auquad = (Uquad_t)SvUV(fromstr);
4974 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4980 aquad = (Quad_t)SvIV(fromstr);
4981 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4986 len = 1; /* assume SV is correct length */
4991 if (fromstr == &PL_sv_undef)
4995 /* XXX better yet, could spirit away the string to
4996 * a safe spot and hang on to it until the result
4997 * of pack() (and all copies of the result) are
5000 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5001 || (SvPADTMP(fromstr)
5002 && !SvREADONLY(fromstr))))
5004 Perl_warner(aTHX_ WARN_PACK,
5005 "Attempt to pack pointer to temporary value");
5007 if (SvPOK(fromstr) || SvNIOK(fromstr))
5008 aptr = SvPV(fromstr,n_a);
5010 aptr = SvPV_force(fromstr,n_a);
5012 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5017 aptr = SvPV(fromstr, fromlen);
5018 SvGROW(cat, fromlen * 4 / 3);
5023 while (fromlen > 0) {
5030 doencodes(cat, aptr, todo);
5049 register IV limit = POPi; /* note, negative is forever */
5051 bool doutf8 = DO_UTF8(sv);
5053 register char *s = SvPV(sv, len);
5054 char *strend = s + len;
5056 register REGEXP *rx;
5060 I32 maxiters = (strend - s) + 10;
5063 I32 origlimit = limit;
5066 AV *oldstack = PL_curstack;
5067 I32 gimme = GIMME_V;
5068 I32 oldsave = PL_savestack_ix;
5069 I32 make_mortal = 1;
5070 MAGIC *mg = (MAGIC *) NULL;
5073 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5078 DIE(aTHX_ "panic: do_split");
5079 rx = pm->op_pmregexp;
5081 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5082 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5084 if (pm->op_pmreplroot) {
5086 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5088 ary = GvAVn((GV*)pm->op_pmreplroot);
5091 else if (gimme != G_ARRAY)
5093 ary = (AV*)PL_curpad[0];
5095 ary = GvAVn(PL_defgv);
5096 #endif /* USE_THREADS */
5099 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5105 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5107 XPUSHs(SvTIED_obj((SV*)ary, mg));
5113 for (i = AvFILLp(ary); i >= 0; i--)
5114 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5116 /* temporarily switch stacks */
5117 SWITCHSTACK(PL_curstack, ary);
5121 base = SP - PL_stack_base;
5123 if (pm->op_pmflags & PMf_SKIPWHITE) {
5124 if (pm->op_pmflags & PMf_LOCALE) {
5125 while (isSPACE_LC(*s))
5133 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5134 SAVEINT(PL_multiline);
5135 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5139 limit = maxiters + 2;
5140 if (pm->op_pmflags & PMf_WHITE) {
5143 while (m < strend &&
5144 !((pm->op_pmflags & PMf_LOCALE)
5145 ? isSPACE_LC(*m) : isSPACE(*m)))
5150 dstr = NEWSV(30, m-s);
5151 sv_setpvn(dstr, s, m-s);
5155 (void)SvUTF8_on(dstr);
5159 while (s < strend &&
5160 ((pm->op_pmflags & PMf_LOCALE)
5161 ? isSPACE_LC(*s) : isSPACE(*s)))
5165 else if (strEQ("^", rx->precomp)) {
5168 for (m = s; m < strend && *m != '\n'; m++) ;
5172 dstr = NEWSV(30, m-s);
5173 sv_setpvn(dstr, s, m-s);
5177 (void)SvUTF8_on(dstr);
5182 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5183 && (rx->reganch & ROPT_CHECK_ALL)
5184 && !(rx->reganch & ROPT_ANCH)) {
5185 int tail = (rx->reganch & RE_INTUIT_TAIL);
5186 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5189 if (len == 1 && !tail) {
5191 char c = *SvPV(csv, n_a);
5194 for (m = s; m < strend && *m != c; m++) ;
5197 dstr = NEWSV(30, m-s);
5198 sv_setpvn(dstr, s, m-s);
5202 (void)SvUTF8_on(dstr);
5204 /* The rx->minlen is in characters but we want to step
5205 * s ahead by bytes. */
5206 s = m + (doutf8 ? SvCUR(csv) : len);
5211 while (s < strend && --limit &&
5212 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5213 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5216 dstr = NEWSV(31, m-s);
5217 sv_setpvn(dstr, s, m-s);
5221 (void)SvUTF8_on(dstr);
5223 /* The rx->minlen is in characters but we want to step
5224 * s ahead by bytes. */
5225 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5230 maxiters += (strend - s) * rx->nparens;
5231 while (s < strend && --limit
5232 /* && (!rx->check_substr
5233 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5235 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5236 1 /* minend */, sv, NULL, 0))
5238 TAINT_IF(RX_MATCH_TAINTED(rx));
5239 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5244 strend = s + (strend - m);
5246 m = rx->startp[0] + orig;
5247 dstr = NEWSV(32, m-s);
5248 sv_setpvn(dstr, s, m-s);
5252 (void)SvUTF8_on(dstr);
5255 for (i = 1; i <= rx->nparens; i++) {
5256 s = rx->startp[i] + orig;
5257 m = rx->endp[i] + orig;
5259 dstr = NEWSV(33, m-s);
5260 sv_setpvn(dstr, s, m-s);
5263 dstr = NEWSV(33, 0);
5267 (void)SvUTF8_on(dstr);
5271 s = rx->endp[0] + orig;
5275 LEAVE_SCOPE(oldsave);
5276 iters = (SP - PL_stack_base) - base;
5277 if (iters > maxiters)
5278 DIE(aTHX_ "Split loop");
5280 /* keep field after final delim? */
5281 if (s < strend || (iters && origlimit)) {
5282 STRLEN l = strend - s;
5283 dstr = NEWSV(34, l);
5284 sv_setpvn(dstr, s, l);
5288 (void)SvUTF8_on(dstr);
5292 else if (!origlimit) {
5293 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5299 SWITCHSTACK(ary, oldstack);
5300 if (SvSMAGICAL(ary)) {
5305 if (gimme == G_ARRAY) {
5307 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5315 call_method("PUSH",G_SCALAR|G_DISCARD);
5318 if (gimme == G_ARRAY) {
5319 /* EXTEND should not be needed - we just popped them */
5321 for (i=0; i < iters; i++) {
5322 SV **svp = av_fetch(ary, i, FALSE);
5323 PUSHs((svp) ? *svp : &PL_sv_undef);
5330 if (gimme == G_ARRAY)
5333 if (iters || !pm->op_pmreplroot) {
5343 Perl_unlock_condpair(pTHX_ void *svv)
5346 MAGIC *mg = mg_find((SV*)svv, 'm');
5349 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5350 MUTEX_LOCK(MgMUTEXP(mg));
5351 if (MgOWNER(mg) != thr)
5352 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5354 COND_SIGNAL(MgOWNERCONDP(mg));
5355 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5356 PTR2UV(thr), PTR2UV(svv));)
5357 MUTEX_UNLOCK(MgMUTEXP(mg));
5359 #endif /* USE_THREADS */
5368 #endif /* USE_THREADS */
5369 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5370 || SvTYPE(retsv) == SVt_PVCV) {
5371 retsv = refto(retsv);
5382 if (PL_op->op_private & OPpLVAL_INTRO)
5383 PUSHs(*save_threadsv(PL_op->op_targ));
5385 PUSHs(THREADSV(PL_op->op_targ));
5388 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5389 #endif /* USE_THREADS */