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. */
1488 while (tmps < send) {
1489 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1490 tmps += UTF8SKIP(tmps);
1491 targlen += UNISKIP(~c);
1497 /* Now rewind strings and write them. */
1501 Newz(0, result, targlen + 1, U8);
1502 while (tmps < send) {
1503 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1504 tmps += UTF8SKIP(tmps);
1505 result = uv_to_utf8(result, ~c);
1509 sv_setpvn(TARG, (char*)result, targlen);
1513 Newz(0, result, nchar + 1, U8);
1514 while (tmps < send) {
1515 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
1516 tmps += UTF8SKIP(tmps);
1521 sv_setpvn(TARG, (char*)result, nchar);
1529 register long *tmpl;
1530 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1533 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1538 for ( ; anum > 0; anum--, tmps++)
1547 /* integer versions of some of the above */
1551 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1554 SETi( left * right );
1561 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1565 DIE(aTHX_ "Illegal division by zero");
1566 value = POPi / value;
1574 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1578 DIE(aTHX_ "Illegal modulus zero");
1579 SETi( left % right );
1586 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1589 SETi( left + right );
1596 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1599 SETi( left - right );
1606 djSP; tryAMAGICbinSET(lt,0);
1609 SETs(boolSV(left < right));
1616 djSP; tryAMAGICbinSET(gt,0);
1619 SETs(boolSV(left > right));
1626 djSP; tryAMAGICbinSET(le,0);
1629 SETs(boolSV(left <= right));
1636 djSP; tryAMAGICbinSET(ge,0);
1639 SETs(boolSV(left >= right));
1646 djSP; tryAMAGICbinSET(eq,0);
1649 SETs(boolSV(left == right));
1656 djSP; tryAMAGICbinSET(ne,0);
1659 SETs(boolSV(left != right));
1666 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1673 else if (left < right)
1684 djSP; dTARGET; tryAMAGICun(neg);
1689 /* High falutin' math. */
1693 djSP; dTARGET; tryAMAGICbin(atan2,0);
1696 SETn(Perl_atan2(left, right));
1703 djSP; dTARGET; tryAMAGICun(sin);
1707 value = Perl_sin(value);
1715 djSP; dTARGET; tryAMAGICun(cos);
1719 value = Perl_cos(value);
1725 /* Support Configure command-line overrides for rand() functions.
1726 After 5.005, perhaps we should replace this by Configure support
1727 for drand48(), random(), or rand(). For 5.005, though, maintain
1728 compatibility by calling rand() but allow the user to override it.
1729 See INSTALL for details. --Andy Dougherty 15 July 1998
1731 /* Now it's after 5.005, and Configure supports drand48() and random(),
1732 in addition to rand(). So the overrides should not be needed any more.
1733 --Jarkko Hietaniemi 27 September 1998
1736 #ifndef HAS_DRAND48_PROTO
1737 extern double drand48 (void);
1750 if (!PL_srand_called) {
1751 (void)seedDrand01((Rand_seed_t)seed());
1752 PL_srand_called = TRUE;
1767 (void)seedDrand01((Rand_seed_t)anum);
1768 PL_srand_called = TRUE;
1777 * This is really just a quick hack which grabs various garbage
1778 * values. It really should be a real hash algorithm which
1779 * spreads the effect of every input bit onto every output bit,
1780 * if someone who knows about such things would bother to write it.
1781 * Might be a good idea to add that function to CORE as well.
1782 * No numbers below come from careful analysis or anything here,
1783 * except they are primes and SEED_C1 > 1E6 to get a full-width
1784 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1785 * probably be bigger too.
1788 # define SEED_C1 1000003
1789 #define SEED_C4 73819
1791 # define SEED_C1 25747
1792 #define SEED_C4 20639
1796 #define SEED_C5 26107
1799 #ifndef PERL_NO_DEV_RANDOM
1804 # include <starlet.h>
1805 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1806 * in 100-ns units, typically incremented ever 10 ms. */
1807 unsigned int when[2];
1809 # ifdef HAS_GETTIMEOFDAY
1810 struct timeval when;
1816 /* This test is an escape hatch, this symbol isn't set by Configure. */
1817 #ifndef PERL_NO_DEV_RANDOM
1818 #ifndef PERL_RANDOM_DEVICE
1819 /* /dev/random isn't used by default because reads from it will block
1820 * if there isn't enough entropy available. You can compile with
1821 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1822 * is enough real entropy to fill the seed. */
1823 # define PERL_RANDOM_DEVICE "/dev/urandom"
1825 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1827 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1836 _ckvmssts(sys$gettim(when));
1837 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1839 # ifdef HAS_GETTIMEOFDAY
1840 gettimeofday(&when,(struct timezone *) 0);
1841 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1844 u = (U32)SEED_C1 * when;
1847 u += SEED_C3 * (U32)PerlProc_getpid();
1848 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1849 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1850 u += SEED_C5 * (U32)PTR2UV(&when);
1857 djSP; dTARGET; tryAMAGICun(exp);
1861 value = Perl_exp(value);
1869 djSP; dTARGET; tryAMAGICun(log);
1874 SET_NUMERIC_STANDARD();
1875 DIE(aTHX_ "Can't take log of %g", value);
1877 value = Perl_log(value);
1885 djSP; dTARGET; tryAMAGICun(sqrt);
1890 SET_NUMERIC_STANDARD();
1891 DIE(aTHX_ "Can't take sqrt of %g", value);
1893 value = Perl_sqrt(value);
1906 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1912 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1913 (void)Perl_modf(value, &value);
1915 double tmp = (double)value;
1916 (void)Perl_modf(tmp, &tmp);
1921 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1922 (void)Perl_modf(-value, &value);
1925 double tmp = (double)value;
1926 (void)Perl_modf(-tmp, &tmp);
1942 djSP; dTARGET; tryAMAGICun(abs);
1947 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1948 (iv = SvIVX(TOPs)) != IV_MIN) {
1970 argtype = 1; /* allow underscores */
1971 XPUSHn(scan_hex(tmps, 99, &argtype));
1984 while (*tmps && isSPACE(*tmps))
1988 argtype = 1; /* allow underscores */
1990 value = scan_hex(++tmps, 99, &argtype);
1991 else if (*tmps == 'b')
1992 value = scan_bin(++tmps, 99, &argtype);
1994 value = scan_oct(tmps, 99, &argtype);
2007 SETi(sv_len_utf8(sv));
2023 I32 lvalue = PL_op->op_flags & OPf_MOD;
2025 I32 arybase = PL_curcop->cop_arybase;
2029 SvTAINTED_off(TARG); /* decontaminate */
2030 SvUTF8_off(TARG); /* decontaminate */
2034 repl = SvPV(sv, repl_len);
2041 tmps = SvPV(sv, curlen);
2043 utfcurlen = sv_len_utf8(sv);
2044 if (utfcurlen == curlen)
2052 if (pos >= arybase) {
2070 else if (len >= 0) {
2072 if (rem > (I32)curlen)
2087 Perl_croak(aTHX_ "substr outside of string");
2088 if (ckWARN(WARN_SUBSTR))
2089 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2094 sv_pos_u2b(sv, &pos, &rem);
2096 sv_setpvn(TARG, tmps, rem);
2100 sv_insert(sv, pos, rem, repl, repl_len);
2101 else if (lvalue) { /* it's an lvalue! */
2102 if (!SvGMAGICAL(sv)) {
2106 if (ckWARN(WARN_SUBSTR))
2107 Perl_warner(aTHX_ WARN_SUBSTR,
2108 "Attempt to use reference as lvalue in substr");
2110 if (SvOK(sv)) /* is it defined ? */
2111 (void)SvPOK_only_UTF8(sv);
2113 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2116 if (SvTYPE(TARG) < SVt_PVLV) {
2117 sv_upgrade(TARG, SVt_PVLV);
2118 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2122 if (LvTARG(TARG) != sv) {
2124 SvREFCNT_dec(LvTARG(TARG));
2125 LvTARG(TARG) = SvREFCNT_inc(sv);
2127 LvTARGOFF(TARG) = pos;
2128 LvTARGLEN(TARG) = rem;
2132 PUSHs(TARG); /* avoid SvSETMAGIC here */
2139 register IV size = POPi;
2140 register IV offset = POPi;
2141 register SV *src = POPs;
2142 I32 lvalue = PL_op->op_flags & OPf_MOD;
2144 SvTAINTED_off(TARG); /* decontaminate */
2145 if (lvalue) { /* it's an lvalue! */
2146 if (SvTYPE(TARG) < SVt_PVLV) {
2147 sv_upgrade(TARG, SVt_PVLV);
2148 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2151 if (LvTARG(TARG) != src) {
2153 SvREFCNT_dec(LvTARG(TARG));
2154 LvTARG(TARG) = SvREFCNT_inc(src);
2156 LvTARGOFF(TARG) = offset;
2157 LvTARGLEN(TARG) = size;
2160 sv_setuv(TARG, do_vecget(src, offset, size));
2175 I32 arybase = PL_curcop->cop_arybase;
2180 offset = POPi - arybase;
2183 tmps = SvPV(big, biglen);
2184 if (offset > 0 && DO_UTF8(big))
2185 sv_pos_u2b(big, &offset, 0);
2188 else if (offset > biglen)
2190 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2191 (unsigned char*)tmps + biglen, little, 0)))
2194 retval = tmps2 - tmps;
2195 if (retval > 0 && DO_UTF8(big))
2196 sv_pos_b2u(big, &retval);
2197 PUSHi(retval + arybase);
2212 I32 arybase = PL_curcop->cop_arybase;
2218 tmps2 = SvPV(little, llen);
2219 tmps = SvPV(big, blen);
2223 if (offset > 0 && DO_UTF8(big))
2224 sv_pos_u2b(big, &offset, 0);
2225 offset = offset - arybase + llen;
2229 else if (offset > blen)
2231 if (!(tmps2 = rninstr(tmps, tmps + offset,
2232 tmps2, tmps2 + llen)))
2235 retval = tmps2 - tmps;
2236 if (retval > 0 && DO_UTF8(big))
2237 sv_pos_b2u(big, &retval);
2238 PUSHi(retval + arybase);
2244 djSP; dMARK; dORIGMARK; dTARGET;
2245 do_sprintf(TARG, SP-MARK, MARK+1);
2246 TAINT_IF(SvTAINTED(TARG));
2258 U8 *tmps = (U8*)SvPVx(tmpsv, len);
2261 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2262 value = utf8_to_uv(tmps, len, &retlen, 0);
2264 value = (UV)(*tmps & 255);
2275 (void)SvUPGRADE(TARG,SVt_PV);
2277 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2278 SvGROW(TARG, UTF8_MAXLEN+1);
2280 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2281 SvCUR_set(TARG, tmps - SvPVX(TARG));
2283 (void)SvPOK_only(TARG);
2294 (void)SvPOK_only(TARG);
2301 djSP; dTARGET; dPOPTOPssrl;
2304 char *tmps = SvPV(left, n_a);
2306 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2308 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2312 "The crypt() function is unimplemented due to excessive paranoia.");
2325 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2327 U8 tmpbuf[UTF8_MAXLEN];
2329 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2331 if (PL_op->op_private & OPpLOCALE) {
2334 uv = toTITLE_LC_uni(uv);
2337 uv = toTITLE_utf8(s);
2339 tend = uv_to_utf8(tmpbuf, uv);
2341 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2343 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2344 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2349 s = (U8*)SvPV_force(sv, slen);
2350 Copy(tmpbuf, s, ulen, U8);
2354 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2356 SvUTF8_off(TARG); /* decontaminate */
2361 s = (U8*)SvPV_force(sv, slen);
2363 if (PL_op->op_private & OPpLOCALE) {
2366 *s = toUPPER_LC(*s);
2384 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2386 U8 tmpbuf[UTF8_MAXLEN];
2388 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2390 if (PL_op->op_private & OPpLOCALE) {
2393 uv = toLOWER_LC_uni(uv);
2396 uv = toLOWER_utf8(s);
2398 tend = uv_to_utf8(tmpbuf, uv);
2400 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2402 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2403 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2408 s = (U8*)SvPV_force(sv, slen);
2409 Copy(tmpbuf, s, ulen, U8);
2413 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2415 SvUTF8_off(TARG); /* decontaminate */
2420 s = (U8*)SvPV_force(sv, slen);
2422 if (PL_op->op_private & OPpLOCALE) {
2425 *s = toLOWER_LC(*s);
2449 s = (U8*)SvPV(sv,len);
2451 SvUTF8_off(TARG); /* decontaminate */
2452 sv_setpvn(TARG, "", 0);
2456 (void)SvUPGRADE(TARG, SVt_PV);
2457 SvGROW(TARG, (len * 2) + 1);
2458 (void)SvPOK_only(TARG);
2459 d = (U8*)SvPVX(TARG);
2461 if (PL_op->op_private & OPpLOCALE) {
2465 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2471 d = uv_to_utf8(d, toUPPER_utf8( s ));
2477 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2482 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2484 SvUTF8_off(TARG); /* decontaminate */
2489 s = (U8*)SvPV_force(sv, len);
2491 register U8 *send = s + len;
2493 if (PL_op->op_private & OPpLOCALE) {
2496 for (; s < send; s++)
2497 *s = toUPPER_LC(*s);
2500 for (; s < send; s++)
2523 s = (U8*)SvPV(sv,len);
2525 SvUTF8_off(TARG); /* decontaminate */
2526 sv_setpvn(TARG, "", 0);
2530 (void)SvUPGRADE(TARG, SVt_PV);
2531 SvGROW(TARG, (len * 2) + 1);
2532 (void)SvPOK_only(TARG);
2533 d = (U8*)SvPVX(TARG);
2535 if (PL_op->op_private & OPpLOCALE) {
2539 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2545 d = uv_to_utf8(d, toLOWER_utf8(s));
2551 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2556 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2558 SvUTF8_off(TARG); /* decontaminate */
2564 s = (U8*)SvPV_force(sv, len);
2566 register U8 *send = s + len;
2568 if (PL_op->op_private & OPpLOCALE) {
2571 for (; s < send; s++)
2572 *s = toLOWER_LC(*s);
2575 for (; s < send; s++)
2590 register char *s = SvPV(sv,len);
2593 SvUTF8_off(TARG); /* decontaminate */
2595 (void)SvUPGRADE(TARG, SVt_PV);
2596 SvGROW(TARG, (len * 2) + 1);
2601 STRLEN ulen = UTF8SKIP(s);
2625 SvCUR_set(TARG, d - SvPVX(TARG));
2626 (void)SvPOK_only_UTF8(TARG);
2629 sv_setpvn(TARG, s, len);
2631 if (SvSMAGICAL(TARG))
2640 djSP; dMARK; dORIGMARK;
2642 register AV* av = (AV*)POPs;
2643 register I32 lval = PL_op->op_flags & OPf_MOD;
2644 I32 arybase = PL_curcop->cop_arybase;
2647 if (SvTYPE(av) == SVt_PVAV) {
2648 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2650 for (svp = MARK + 1; svp <= SP; svp++) {
2655 if (max > AvMAX(av))
2658 while (++MARK <= SP) {
2659 elem = SvIVx(*MARK);
2663 svp = av_fetch(av, elem, lval);
2665 if (!svp || *svp == &PL_sv_undef)
2666 DIE(aTHX_ PL_no_aelem, elem);
2667 if (PL_op->op_private & OPpLVAL_INTRO)
2668 save_aelem(av, elem, svp);
2670 *MARK = svp ? *svp : &PL_sv_undef;
2673 if (GIMME != G_ARRAY) {
2681 /* Associative arrays. */
2686 HV *hash = (HV*)POPs;
2688 I32 gimme = GIMME_V;
2689 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2692 /* might clobber stack_sp */
2693 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2698 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2699 if (gimme == G_ARRAY) {
2702 /* might clobber stack_sp */
2704 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2709 else if (gimme == G_SCALAR)
2728 I32 gimme = GIMME_V;
2729 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2733 if (PL_op->op_private & OPpSLICE) {
2737 hvtype = SvTYPE(hv);
2738 if (hvtype == SVt_PVHV) { /* hash element */
2739 while (++MARK <= SP) {
2740 sv = hv_delete_ent(hv, *MARK, discard, 0);
2741 *MARK = sv ? sv : &PL_sv_undef;
2744 else if (hvtype == SVt_PVAV) {
2745 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2746 while (++MARK <= SP) {
2747 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2748 *MARK = sv ? sv : &PL_sv_undef;
2751 else { /* pseudo-hash element */
2752 while (++MARK <= SP) {
2753 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2754 *MARK = sv ? sv : &PL_sv_undef;
2759 DIE(aTHX_ "Not a HASH reference");
2762 else if (gimme == G_SCALAR) {
2771 if (SvTYPE(hv) == SVt_PVHV)
2772 sv = hv_delete_ent(hv, keysv, discard, 0);
2773 else if (SvTYPE(hv) == SVt_PVAV) {
2774 if (PL_op->op_flags & OPf_SPECIAL)
2775 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2777 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2780 DIE(aTHX_ "Not a HASH reference");
2795 if (PL_op->op_private & OPpEXISTS_SUB) {
2799 cv = sv_2cv(sv, &hv, &gv, FALSE);
2802 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2808 if (SvTYPE(hv) == SVt_PVHV) {
2809 if (hv_exists_ent(hv, tmpsv, 0))
2812 else if (SvTYPE(hv) == SVt_PVAV) {
2813 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2814 if (av_exists((AV*)hv, SvIV(tmpsv)))
2817 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2821 DIE(aTHX_ "Not a HASH reference");
2828 djSP; dMARK; dORIGMARK;
2829 register HV *hv = (HV*)POPs;
2830 register I32 lval = PL_op->op_flags & OPf_MOD;
2831 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2833 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2834 DIE(aTHX_ "Can't localize pseudo-hash element");
2836 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2837 while (++MARK <= SP) {
2841 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2842 svp = he ? &HeVAL(he) : 0;
2845 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2848 if (!svp || *svp == &PL_sv_undef) {
2850 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2852 if (PL_op->op_private & OPpLVAL_INTRO)
2853 save_helem(hv, keysv, svp);
2855 *MARK = svp ? *svp : &PL_sv_undef;
2858 if (GIMME != G_ARRAY) {
2866 /* List operators. */
2871 if (GIMME != G_ARRAY) {
2873 *MARK = *SP; /* unwanted list, return last item */
2875 *MARK = &PL_sv_undef;
2884 SV **lastrelem = PL_stack_sp;
2885 SV **lastlelem = PL_stack_base + POPMARK;
2886 SV **firstlelem = PL_stack_base + POPMARK + 1;
2887 register SV **firstrelem = lastlelem + 1;
2888 I32 arybase = PL_curcop->cop_arybase;
2889 I32 lval = PL_op->op_flags & OPf_MOD;
2890 I32 is_something_there = lval;
2892 register I32 max = lastrelem - lastlelem;
2893 register SV **lelem;
2896 if (GIMME != G_ARRAY) {
2897 ix = SvIVx(*lastlelem);
2902 if (ix < 0 || ix >= max)
2903 *firstlelem = &PL_sv_undef;
2905 *firstlelem = firstrelem[ix];
2911 SP = firstlelem - 1;
2915 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2921 if (ix < 0 || ix >= max)
2922 *lelem = &PL_sv_undef;
2924 is_something_there = TRUE;
2925 if (!(*lelem = firstrelem[ix]))
2926 *lelem = &PL_sv_undef;
2929 if (is_something_there)
2932 SP = firstlelem - 1;
2938 djSP; dMARK; dORIGMARK;
2939 I32 items = SP - MARK;
2940 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2941 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2948 djSP; dMARK; dORIGMARK;
2949 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2953 SV *val = NEWSV(46, 0);
2955 sv_setsv(val, *++MARK);
2956 else if (ckWARN(WARN_MISC))
2957 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2958 (void)hv_store_ent(hv,key,val,0);
2967 djSP; dMARK; dORIGMARK;
2968 register AV *ary = (AV*)*++MARK;
2972 register I32 offset;
2973 register I32 length;
2980 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2981 *MARK-- = SvTIED_obj((SV*)ary, mg);
2985 call_method("SPLICE",GIMME_V);
2994 offset = i = SvIVx(*MARK);
2996 offset += AvFILLp(ary) + 1;
2998 offset -= PL_curcop->cop_arybase;
3000 DIE(aTHX_ PL_no_aelem, i);
3002 length = SvIVx(*MARK++);
3004 length += AvFILLp(ary) - offset + 1;
3010 length = AvMAX(ary) + 1; /* close enough to infinity */
3014 length = AvMAX(ary) + 1;
3016 if (offset > AvFILLp(ary) + 1)
3017 offset = AvFILLp(ary) + 1;
3018 after = AvFILLp(ary) + 1 - (offset + length);
3019 if (after < 0) { /* not that much array */
3020 length += after; /* offset+length now in array */
3026 /* At this point, MARK .. SP-1 is our new LIST */
3029 diff = newlen - length;
3030 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3033 if (diff < 0) { /* shrinking the area */
3035 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3036 Copy(MARK, tmparyval, newlen, SV*);
3039 MARK = ORIGMARK + 1;
3040 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3041 MEXTEND(MARK, length);
3042 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3044 EXTEND_MORTAL(length);
3045 for (i = length, dst = MARK; i; i--) {
3046 sv_2mortal(*dst); /* free them eventualy */
3053 *MARK = AvARRAY(ary)[offset+length-1];
3056 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3057 SvREFCNT_dec(*dst++); /* free them now */
3060 AvFILLp(ary) += diff;
3062 /* pull up or down? */
3064 if (offset < after) { /* easier to pull up */
3065 if (offset) { /* esp. if nothing to pull */
3066 src = &AvARRAY(ary)[offset-1];
3067 dst = src - diff; /* diff is negative */
3068 for (i = offset; i > 0; i--) /* can't trust Copy */
3072 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3076 if (after) { /* anything to pull down? */
3077 src = AvARRAY(ary) + offset + length;
3078 dst = src + diff; /* diff is negative */
3079 Move(src, dst, after, SV*);
3081 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3082 /* avoid later double free */
3086 dst[--i] = &PL_sv_undef;
3089 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3091 *dst = NEWSV(46, 0);
3092 sv_setsv(*dst++, *src++);
3094 Safefree(tmparyval);
3097 else { /* no, expanding (or same) */
3099 New(452, tmparyval, length, SV*); /* so remember deletion */
3100 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3103 if (diff > 0) { /* expanding */
3105 /* push up or down? */
3107 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3111 Move(src, dst, offset, SV*);
3113 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3115 AvFILLp(ary) += diff;
3118 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3119 av_extend(ary, AvFILLp(ary) + diff);
3120 AvFILLp(ary) += diff;
3123 dst = AvARRAY(ary) + AvFILLp(ary);
3125 for (i = after; i; i--) {
3132 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3133 *dst = NEWSV(46, 0);
3134 sv_setsv(*dst++, *src++);
3136 MARK = ORIGMARK + 1;
3137 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3139 Copy(tmparyval, MARK, length, SV*);
3141 EXTEND_MORTAL(length);
3142 for (i = length, dst = MARK; i; i--) {
3143 sv_2mortal(*dst); /* free them eventualy */
3147 Safefree(tmparyval);
3151 else if (length--) {
3152 *MARK = tmparyval[length];
3155 while (length-- > 0)
3156 SvREFCNT_dec(tmparyval[length]);
3158 Safefree(tmparyval);
3161 *MARK = &PL_sv_undef;
3169 djSP; dMARK; dORIGMARK; dTARGET;
3170 register AV *ary = (AV*)*++MARK;
3171 register SV *sv = &PL_sv_undef;
3174 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3175 *MARK-- = SvTIED_obj((SV*)ary, mg);
3179 call_method("PUSH",G_SCALAR|G_DISCARD);
3184 /* Why no pre-extend of ary here ? */
3185 for (++MARK; MARK <= SP; MARK++) {
3188 sv_setsv(sv, *MARK);
3193 PUSHi( AvFILL(ary) + 1 );
3201 SV *sv = av_pop(av);
3203 (void)sv_2mortal(sv);
3212 SV *sv = av_shift(av);
3217 (void)sv_2mortal(sv);
3224 djSP; dMARK; dORIGMARK; dTARGET;
3225 register AV *ary = (AV*)*++MARK;
3230 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3231 *MARK-- = SvTIED_obj((SV*)ary, mg);
3235 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3240 av_unshift(ary, SP - MARK);
3243 sv_setsv(sv, *++MARK);
3244 (void)av_store(ary, i++, sv);
3248 PUSHi( AvFILL(ary) + 1 );
3258 if (GIMME == G_ARRAY) {
3265 /* safe as long as stack cannot get extended in the above */
3270 register char *down;
3275 SvUTF8_off(TARG); /* decontaminate */
3277 do_join(TARG, &PL_sv_no, MARK, SP);
3279 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3280 up = SvPV_force(TARG, len);
3282 if (DO_UTF8(TARG)) { /* first reverse each character */
3283 U8* s = (U8*)SvPVX(TARG);
3284 U8* send = (U8*)(s + len);
3293 down = (char*)(s - 1);
3294 if (s > send || !((*down & 0xc0) == 0x80)) {
3295 if (ckWARN_d(WARN_UTF8))
3296 Perl_warner(aTHX_ WARN_UTF8,
3297 "Malformed UTF-8 character");
3309 down = SvPVX(TARG) + len - 1;
3315 (void)SvPOK_only_UTF8(TARG);
3324 S_mul128(pTHX_ SV *sv, U8 m)
3327 char *s = SvPV(sv, len);
3331 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3332 SV *tmpNew = newSVpvn("0000000000", 10);
3334 sv_catsv(tmpNew, sv);
3335 SvREFCNT_dec(sv); /* free old sv */
3340 while (!*t) /* trailing '\0'? */
3343 i = ((*t - '0') << 7) + m;
3344 *(t--) = '0' + (i % 10);
3350 /* Explosives and implosives. */
3352 #if 'I' == 73 && 'J' == 74
3353 /* On an ASCII/ISO kind of system */
3354 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3357 Some other sort of character set - use memchr() so we don't match
3360 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3367 I32 start_sp_offset = SP - PL_stack_base;
3368 I32 gimme = GIMME_V;
3372 register char *pat = SvPV(left, llen);
3373 register char *s = SvPV(right, rlen);
3374 char *strend = s + rlen;
3376 register char *patend = pat + llen;
3382 /* These must not be in registers: */
3399 register U32 culong;
3403 #ifdef PERL_NATINT_PACK
3404 int natint; /* native integer */
3405 int unatint; /* unsigned native integer */
3408 if (gimme != G_ARRAY) { /* arrange to do first one only */
3410 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3411 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3413 while (isDIGIT(*patend) || *patend == '*')
3419 while (pat < patend) {
3421 datumtype = *pat++ & 0xFF;
3422 #ifdef PERL_NATINT_PACK
3425 if (isSPACE(datumtype))
3427 if (datumtype == '#') {
3428 while (pat < patend && *pat != '\n')
3433 char *natstr = "sSiIlL";
3435 if (strchr(natstr, datumtype)) {
3436 #ifdef PERL_NATINT_PACK
3442 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3447 else if (*pat == '*') {
3448 len = strend - strbeg; /* long enough */
3452 else if (isDIGIT(*pat)) {
3454 while (isDIGIT(*pat)) {
3455 len = (len * 10) + (*pat++ - '0');
3457 DIE(aTHX_ "Repeat count in unpack overflows");
3461 len = (datumtype != '@');
3465 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3466 case ',': /* grandfather in commas but with a warning */
3467 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3468 Perl_warner(aTHX_ WARN_UNPACK,
3469 "Invalid type in unpack: '%c'", (int)datumtype);
3472 if (len == 1 && pat[-1] != '1')
3481 if (len > strend - strbeg)
3482 DIE(aTHX_ "@ outside of string");
3486 if (len > s - strbeg)
3487 DIE(aTHX_ "X outside of string");
3491 if (len > strend - s)
3492 DIE(aTHX_ "x outside of string");
3496 if (start_sp_offset >= SP - PL_stack_base)
3497 DIE(aTHX_ "/ must follow a numeric type");
3500 pat++; /* ignore '*' for compatibility with pack */
3502 DIE(aTHX_ "/ cannot take a count" );
3509 if (len > strend - s)
3512 goto uchar_checksum;
3513 sv = NEWSV(35, len);
3514 sv_setpvn(sv, s, len);
3516 if (datumtype == 'A' || datumtype == 'Z') {
3517 aptr = s; /* borrow register */
3518 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3523 else { /* 'A' strips both nulls and spaces */
3524 s = SvPVX(sv) + len - 1;
3525 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3529 SvCUR_set(sv, s - SvPVX(sv));
3530 s = aptr; /* unborrow register */
3532 XPUSHs(sv_2mortal(sv));
3536 if (star || len > (strend - s) * 8)
3537 len = (strend - s) * 8;
3540 Newz(601, PL_bitcount, 256, char);
3541 for (bits = 1; bits < 256; bits++) {
3542 if (bits & 1) PL_bitcount[bits]++;
3543 if (bits & 2) PL_bitcount[bits]++;
3544 if (bits & 4) PL_bitcount[bits]++;
3545 if (bits & 8) PL_bitcount[bits]++;
3546 if (bits & 16) PL_bitcount[bits]++;
3547 if (bits & 32) PL_bitcount[bits]++;
3548 if (bits & 64) PL_bitcount[bits]++;
3549 if (bits & 128) PL_bitcount[bits]++;
3553 culong += PL_bitcount[*(unsigned char*)s++];
3558 if (datumtype == 'b') {
3560 if (bits & 1) culong++;
3566 if (bits & 128) culong++;
3573 sv = NEWSV(35, len + 1);
3577 if (datumtype == 'b') {
3579 for (len = 0; len < aint; len++) {
3580 if (len & 7) /*SUPPRESS 595*/
3584 *str++ = '0' + (bits & 1);
3589 for (len = 0; len < aint; len++) {
3594 *str++ = '0' + ((bits & 128) != 0);
3598 XPUSHs(sv_2mortal(sv));
3602 if (star || len > (strend - s) * 2)
3603 len = (strend - s) * 2;
3604 sv = NEWSV(35, len + 1);
3608 if (datumtype == 'h') {
3610 for (len = 0; len < aint; len++) {
3615 *str++ = PL_hexdigit[bits & 15];
3620 for (len = 0; len < aint; len++) {
3625 *str++ = PL_hexdigit[(bits >> 4) & 15];
3629 XPUSHs(sv_2mortal(sv));
3632 if (len > strend - s)
3637 if (aint >= 128) /* fake up signed chars */
3647 if (aint >= 128) /* fake up signed chars */
3650 sv_setiv(sv, (IV)aint);
3651 PUSHs(sv_2mortal(sv));
3656 if (len > strend - s)
3671 sv_setiv(sv, (IV)auint);
3672 PUSHs(sv_2mortal(sv));
3677 if (len > strend - s)
3680 while (len-- > 0 && s < strend) {
3682 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3686 cdouble += (NV)auint;
3694 while (len-- > 0 && s < strend) {
3696 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3700 sv_setuv(sv, (UV)auint);
3701 PUSHs(sv_2mortal(sv));
3706 #if SHORTSIZE == SIZE16
3707 along = (strend - s) / SIZE16;
3709 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3714 #if SHORTSIZE != SIZE16
3718 COPYNN(s, &ashort, sizeof(short));
3729 #if SHORTSIZE > SIZE16
3741 #if SHORTSIZE != SIZE16
3745 COPYNN(s, &ashort, sizeof(short));
3748 sv_setiv(sv, (IV)ashort);
3749 PUSHs(sv_2mortal(sv));
3757 #if SHORTSIZE > SIZE16
3763 sv_setiv(sv, (IV)ashort);
3764 PUSHs(sv_2mortal(sv));
3772 #if SHORTSIZE == SIZE16
3773 along = (strend - s) / SIZE16;
3775 unatint = natint && datumtype == 'S';
3776 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3781 #if SHORTSIZE != SIZE16
3783 unsigned short aushort;
3785 COPYNN(s, &aushort, sizeof(unsigned short));
3786 s += sizeof(unsigned short);
3794 COPY16(s, &aushort);
3797 if (datumtype == 'n')
3798 aushort = PerlSock_ntohs(aushort);
3801 if (datumtype == 'v')
3802 aushort = vtohs(aushort);
3811 #if SHORTSIZE != SIZE16
3813 unsigned short aushort;
3815 COPYNN(s, &aushort, sizeof(unsigned short));
3816 s += sizeof(unsigned short);
3818 sv_setiv(sv, (UV)aushort);
3819 PUSHs(sv_2mortal(sv));
3826 COPY16(s, &aushort);
3830 if (datumtype == 'n')
3831 aushort = PerlSock_ntohs(aushort);
3834 if (datumtype == 'v')
3835 aushort = vtohs(aushort);
3837 sv_setiv(sv, (UV)aushort);
3838 PUSHs(sv_2mortal(sv));
3844 along = (strend - s) / sizeof(int);
3849 Copy(s, &aint, 1, int);
3852 cdouble += (NV)aint;
3861 Copy(s, &aint, 1, int);
3865 /* Without the dummy below unpack("i", pack("i",-1))
3866 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3867 * cc with optimization turned on.
3869 * The bug was detected in
3870 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3871 * with optimization (-O4) turned on.
3872 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3873 * does not have this problem even with -O4.
3875 * This bug was reported as DECC_BUGS 1431
3876 * and tracked internally as GEM_BUGS 7775.
3878 * The bug is fixed in
3879 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3880 * UNIX V4.0F support: DEC C V5.9-006 or later
3881 * UNIX V4.0E support: DEC C V5.8-011 or later
3884 * See also few lines later for the same bug.
3887 sv_setiv(sv, (IV)aint) :
3889 sv_setiv(sv, (IV)aint);
3890 PUSHs(sv_2mortal(sv));
3895 along = (strend - s) / sizeof(unsigned int);
3900 Copy(s, &auint, 1, unsigned int);
3901 s += sizeof(unsigned int);
3903 cdouble += (NV)auint;
3912 Copy(s, &auint, 1, unsigned int);
3913 s += sizeof(unsigned int);
3916 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3917 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3918 * See details few lines earlier. */
3920 sv_setuv(sv, (UV)auint) :
3922 sv_setuv(sv, (UV)auint);
3923 PUSHs(sv_2mortal(sv));
3928 #if LONGSIZE == SIZE32
3929 along = (strend - s) / SIZE32;
3931 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3936 #if LONGSIZE != SIZE32
3939 COPYNN(s, &along, sizeof(long));
3942 cdouble += (NV)along;
3951 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3955 #if LONGSIZE > SIZE32
3956 if (along > 2147483647)
3957 along -= 4294967296;
3961 cdouble += (NV)along;
3970 #if LONGSIZE != SIZE32
3973 COPYNN(s, &along, sizeof(long));
3976 sv_setiv(sv, (IV)along);
3977 PUSHs(sv_2mortal(sv));
3984 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3988 #if LONGSIZE > SIZE32
3989 if (along > 2147483647)
3990 along -= 4294967296;
3994 sv_setiv(sv, (IV)along);
3995 PUSHs(sv_2mortal(sv));
4003 #if LONGSIZE == SIZE32
4004 along = (strend - s) / SIZE32;
4006 unatint = natint && datumtype == 'L';
4007 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4012 #if LONGSIZE != SIZE32
4014 unsigned long aulong;
4016 COPYNN(s, &aulong, sizeof(unsigned long));
4017 s += sizeof(unsigned long);
4019 cdouble += (NV)aulong;
4031 if (datumtype == 'N')
4032 aulong = PerlSock_ntohl(aulong);
4035 if (datumtype == 'V')
4036 aulong = vtohl(aulong);
4039 cdouble += (NV)aulong;
4048 #if LONGSIZE != SIZE32
4050 unsigned long aulong;
4052 COPYNN(s, &aulong, sizeof(unsigned long));
4053 s += sizeof(unsigned long);
4055 sv_setuv(sv, (UV)aulong);
4056 PUSHs(sv_2mortal(sv));
4066 if (datumtype == 'N')
4067 aulong = PerlSock_ntohl(aulong);
4070 if (datumtype == 'V')
4071 aulong = vtohl(aulong);
4074 sv_setuv(sv, (UV)aulong);
4075 PUSHs(sv_2mortal(sv));
4081 along = (strend - s) / sizeof(char*);
4087 if (sizeof(char*) > strend - s)
4090 Copy(s, &aptr, 1, char*);
4096 PUSHs(sv_2mortal(sv));
4106 while ((len > 0) && (s < strend)) {
4107 auv = (auv << 7) | (*s & 0x7f);
4108 if (!(*s++ & 0x80)) {
4112 PUSHs(sv_2mortal(sv));
4116 else if (++bytes >= sizeof(UV)) { /* promote to string */
4120 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4121 while (s < strend) {
4122 sv = mul128(sv, *s & 0x7f);
4123 if (!(*s++ & 0x80)) {
4132 PUSHs(sv_2mortal(sv));
4137 if ((s >= strend) && bytes)
4138 DIE(aTHX_ "Unterminated compressed integer");
4143 if (sizeof(char*) > strend - s)
4146 Copy(s, &aptr, 1, char*);
4151 sv_setpvn(sv, aptr, len);
4152 PUSHs(sv_2mortal(sv));
4156 along = (strend - s) / sizeof(Quad_t);
4162 if (s + sizeof(Quad_t) > strend)
4165 Copy(s, &aquad, 1, Quad_t);
4166 s += sizeof(Quad_t);
4169 if (aquad >= IV_MIN && aquad <= IV_MAX)
4170 sv_setiv(sv, (IV)aquad);
4172 sv_setnv(sv, (NV)aquad);
4173 PUSHs(sv_2mortal(sv));
4177 along = (strend - s) / sizeof(Quad_t);
4183 if (s + sizeof(Uquad_t) > strend)
4186 Copy(s, &auquad, 1, Uquad_t);
4187 s += sizeof(Uquad_t);
4190 if (auquad <= UV_MAX)
4191 sv_setuv(sv, (UV)auquad);
4193 sv_setnv(sv, (NV)auquad);
4194 PUSHs(sv_2mortal(sv));
4198 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4201 along = (strend - s) / sizeof(float);
4206 Copy(s, &afloat, 1, float);
4215 Copy(s, &afloat, 1, float);
4218 sv_setnv(sv, (NV)afloat);
4219 PUSHs(sv_2mortal(sv));
4225 along = (strend - s) / sizeof(double);
4230 Copy(s, &adouble, 1, double);
4231 s += sizeof(double);
4239 Copy(s, &adouble, 1, double);
4240 s += sizeof(double);
4242 sv_setnv(sv, (NV)adouble);
4243 PUSHs(sv_2mortal(sv));
4249 * Initialise the decode mapping. By using a table driven
4250 * algorithm, the code will be character-set independent
4251 * (and just as fast as doing character arithmetic)
4253 if (PL_uudmap['M'] == 0) {
4256 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4257 PL_uudmap[(U8)PL_uuemap[i]] = i;
4259 * Because ' ' and '`' map to the same value,
4260 * we need to decode them both the same.
4265 along = (strend - s) * 3 / 4;
4266 sv = NEWSV(42, along);
4269 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4274 len = PL_uudmap[*(U8*)s++] & 077;
4276 if (s < strend && ISUUCHAR(*s))
4277 a = PL_uudmap[*(U8*)s++] & 077;
4280 if (s < strend && ISUUCHAR(*s))
4281 b = PL_uudmap[*(U8*)s++] & 077;
4284 if (s < strend && ISUUCHAR(*s))
4285 c = PL_uudmap[*(U8*)s++] & 077;
4288 if (s < strend && ISUUCHAR(*s))
4289 d = PL_uudmap[*(U8*)s++] & 077;
4292 hunk[0] = (a << 2) | (b >> 4);
4293 hunk[1] = (b << 4) | (c >> 2);
4294 hunk[2] = (c << 6) | d;
4295 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4300 else if (s[1] == '\n') /* possible checksum byte */
4303 XPUSHs(sv_2mortal(sv));
4308 if (strchr("fFdD", datumtype) ||
4309 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4313 while (checksum >= 16) {
4317 while (checksum >= 4) {
4323 along = (1 << checksum) - 1;
4324 while (cdouble < 0.0)
4326 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4327 sv_setnv(sv, cdouble);
4330 if (checksum < 32) {
4331 aulong = (1 << checksum) - 1;
4334 sv_setuv(sv, (UV)culong);
4336 XPUSHs(sv_2mortal(sv));
4340 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4341 PUSHs(&PL_sv_undef);
4346 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4350 *hunk = PL_uuemap[len];
4351 sv_catpvn(sv, hunk, 1);
4354 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4355 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4356 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4357 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4358 sv_catpvn(sv, hunk, 4);
4363 char r = (len > 1 ? s[1] : '\0');
4364 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4365 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4366 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4367 hunk[3] = PL_uuemap[0];
4368 sv_catpvn(sv, hunk, 4);
4370 sv_catpvn(sv, "\n", 1);
4374 S_is_an_int(pTHX_ char *s, STRLEN l)
4377 SV *result = newSVpvn(s, l);
4378 char *result_c = SvPV(result, n_a); /* convenience */
4379 char *out = result_c;
4389 SvREFCNT_dec(result);
4412 SvREFCNT_dec(result);
4418 SvCUR_set(result, out - result_c);
4422 /* pnum must be '\0' terminated */
4424 S_div128(pTHX_ SV *pnum, bool *done)
4427 char *s = SvPV(pnum, len);
4436 i = m * 10 + (*t - '0');
4438 r = (i >> 7); /* r < 10 */
4445 SvCUR_set(pnum, (STRLEN) (t - s));
4452 djSP; dMARK; dORIGMARK; dTARGET;
4453 register SV *cat = TARG;
4456 register char *pat = SvPVx(*++MARK, fromlen);
4458 register char *patend = pat + fromlen;
4463 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4464 static char *space10 = " ";
4466 /* These must not be in registers: */
4481 #ifdef PERL_NATINT_PACK
4482 int natint; /* native integer */
4487 sv_setpvn(cat, "", 0);
4489 while (pat < patend) {
4490 SV *lengthcode = Nullsv;
4491 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4492 datumtype = *pat++ & 0xFF;
4493 #ifdef PERL_NATINT_PACK
4496 if (isSPACE(datumtype)) {
4500 if (datumtype == 'U' && pat == patcopy+1)
4502 if (datumtype == '#') {
4503 while (pat < patend && *pat != '\n')
4508 char *natstr = "sSiIlL";
4510 if (strchr(natstr, datumtype)) {
4511 #ifdef PERL_NATINT_PACK
4517 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4520 len = strchr("@Xxu", datumtype) ? 0 : items;
4523 else if (isDIGIT(*pat)) {
4525 while (isDIGIT(*pat)) {
4526 len = (len * 10) + (*pat++ - '0');
4528 DIE(aTHX_ "Repeat count in pack overflows");
4535 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4536 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4537 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4538 ? *MARK : &PL_sv_no)
4539 + (*pat == 'Z' ? 1 : 0)));
4543 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4544 case ',': /* grandfather in commas but with a warning */
4545 if (commas++ == 0 && ckWARN(WARN_PACK))
4546 Perl_warner(aTHX_ WARN_PACK,
4547 "Invalid type in pack: '%c'", (int)datumtype);
4550 DIE(aTHX_ "%% may only be used in unpack");
4561 if (SvCUR(cat) < len)
4562 DIE(aTHX_ "X outside of string");
4569 sv_catpvn(cat, null10, 10);
4572 sv_catpvn(cat, null10, len);
4578 aptr = SvPV(fromstr, fromlen);
4579 if (pat[-1] == '*') {
4581 if (datumtype == 'Z')
4584 if (fromlen >= len) {
4585 sv_catpvn(cat, aptr, len);
4586 if (datumtype == 'Z')
4587 *(SvEND(cat)-1) = '\0';
4590 sv_catpvn(cat, aptr, fromlen);
4592 if (datumtype == 'A') {
4594 sv_catpvn(cat, space10, 10);
4597 sv_catpvn(cat, space10, len);
4601 sv_catpvn(cat, null10, 10);
4604 sv_catpvn(cat, null10, len);
4616 str = SvPV(fromstr, fromlen);
4620 SvCUR(cat) += (len+7)/8;
4621 SvGROW(cat, SvCUR(cat) + 1);
4622 aptr = SvPVX(cat) + aint;
4627 if (datumtype == 'B') {
4628 for (len = 0; len++ < aint;) {
4629 items |= *str++ & 1;
4633 *aptr++ = items & 0xff;
4639 for (len = 0; len++ < aint;) {
4645 *aptr++ = items & 0xff;
4651 if (datumtype == 'B')
4652 items <<= 7 - (aint & 7);
4654 items >>= 7 - (aint & 7);
4655 *aptr++ = items & 0xff;
4657 str = SvPVX(cat) + SvCUR(cat);
4672 str = SvPV(fromstr, fromlen);
4676 SvCUR(cat) += (len+1)/2;
4677 SvGROW(cat, SvCUR(cat) + 1);
4678 aptr = SvPVX(cat) + aint;
4683 if (datumtype == 'H') {
4684 for (len = 0; len++ < aint;) {
4686 items |= ((*str++ & 15) + 9) & 15;
4688 items |= *str++ & 15;
4692 *aptr++ = items & 0xff;
4698 for (len = 0; len++ < aint;) {
4700 items |= (((*str++ & 15) + 9) & 15) << 4;
4702 items |= (*str++ & 15) << 4;
4706 *aptr++ = items & 0xff;
4712 *aptr++ = items & 0xff;
4713 str = SvPVX(cat) + SvCUR(cat);
4724 aint = SvIV(fromstr);
4726 sv_catpvn(cat, &achar, sizeof(char));
4732 auint = SvUV(fromstr);
4733 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4734 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4739 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4744 afloat = (float)SvNV(fromstr);
4745 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4752 adouble = (double)SvNV(fromstr);
4753 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4759 ashort = (I16)SvIV(fromstr);
4761 ashort = PerlSock_htons(ashort);
4763 CAT16(cat, &ashort);
4769 ashort = (I16)SvIV(fromstr);
4771 ashort = htovs(ashort);
4773 CAT16(cat, &ashort);
4777 #if SHORTSIZE != SIZE16
4779 unsigned short aushort;
4783 aushort = SvUV(fromstr);
4784 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4794 aushort = (U16)SvUV(fromstr);
4795 CAT16(cat, &aushort);
4801 #if SHORTSIZE != SIZE16
4807 ashort = SvIV(fromstr);
4808 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4816 ashort = (I16)SvIV(fromstr);
4817 CAT16(cat, &ashort);
4824 auint = SvUV(fromstr);
4825 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4831 adouble = Perl_floor(SvNV(fromstr));
4834 DIE(aTHX_ "Cannot compress negative numbers");
4837 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4838 adouble <= 0xffffffff
4840 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4841 adouble <= UV_MAX_cxux
4848 char buf[1 + sizeof(UV)];
4849 char *in = buf + sizeof(buf);
4850 UV auv = U_V(adouble);
4853 *--in = (auv & 0x7f) | 0x80;
4856 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4857 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4859 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4860 char *from, *result, *in;
4865 /* Copy string and check for compliance */
4866 from = SvPV(fromstr, len);
4867 if ((norm = is_an_int(from, len)) == NULL)
4868 DIE(aTHX_ "can compress only unsigned integer");
4870 New('w', result, len, char);
4874 *--in = div128(norm, &done) | 0x80;
4875 result[len - 1] &= 0x7F; /* clear continue bit */
4876 sv_catpvn(cat, in, (result + len) - in);
4878 SvREFCNT_dec(norm); /* free norm */
4880 else if (SvNOKp(fromstr)) {
4881 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4882 char *in = buf + sizeof(buf);
4885 double next = floor(adouble / 128);
4886 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4887 if (in <= buf) /* this cannot happen ;-) */
4888 DIE(aTHX_ "Cannot compress integer");
4891 } while (adouble > 0);
4892 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4893 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4896 DIE(aTHX_ "Cannot compress non integer");
4902 aint = SvIV(fromstr);
4903 sv_catpvn(cat, (char*)&aint, sizeof(int));
4909 aulong = SvUV(fromstr);
4911 aulong = PerlSock_htonl(aulong);
4913 CAT32(cat, &aulong);
4919 aulong = SvUV(fromstr);
4921 aulong = htovl(aulong);
4923 CAT32(cat, &aulong);
4927 #if LONGSIZE != SIZE32
4929 unsigned long aulong;
4933 aulong = SvUV(fromstr);
4934 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4942 aulong = SvUV(fromstr);
4943 CAT32(cat, &aulong);
4948 #if LONGSIZE != SIZE32
4954 along = SvIV(fromstr);
4955 sv_catpvn(cat, (char *)&along, sizeof(long));
4963 along = SvIV(fromstr);
4972 auquad = (Uquad_t)SvUV(fromstr);
4973 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4979 aquad = (Quad_t)SvIV(fromstr);
4980 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4985 len = 1; /* assume SV is correct length */
4990 if (fromstr == &PL_sv_undef)
4994 /* XXX better yet, could spirit away the string to
4995 * a safe spot and hang on to it until the result
4996 * of pack() (and all copies of the result) are
4999 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5000 || (SvPADTMP(fromstr)
5001 && !SvREADONLY(fromstr))))
5003 Perl_warner(aTHX_ WARN_PACK,
5004 "Attempt to pack pointer to temporary value");
5006 if (SvPOK(fromstr) || SvNIOK(fromstr))
5007 aptr = SvPV(fromstr,n_a);
5009 aptr = SvPV_force(fromstr,n_a);
5011 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5016 aptr = SvPV(fromstr, fromlen);
5017 SvGROW(cat, fromlen * 4 / 3);
5022 while (fromlen > 0) {
5029 doencodes(cat, aptr, todo);
5048 register IV limit = POPi; /* note, negative is forever */
5050 bool doutf8 = DO_UTF8(sv);
5052 register char *s = SvPV(sv, len);
5053 char *strend = s + len;
5055 register REGEXP *rx;
5059 I32 maxiters = (strend - s) + 10;
5062 I32 origlimit = limit;
5065 AV *oldstack = PL_curstack;
5066 I32 gimme = GIMME_V;
5067 I32 oldsave = PL_savestack_ix;
5068 I32 make_mortal = 1;
5069 MAGIC *mg = (MAGIC *) NULL;
5072 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5077 DIE(aTHX_ "panic: do_split");
5078 rx = pm->op_pmregexp;
5080 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5081 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5083 if (pm->op_pmreplroot) {
5085 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5087 ary = GvAVn((GV*)pm->op_pmreplroot);
5090 else if (gimme != G_ARRAY)
5092 ary = (AV*)PL_curpad[0];
5094 ary = GvAVn(PL_defgv);
5095 #endif /* USE_THREADS */
5098 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5104 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5106 XPUSHs(SvTIED_obj((SV*)ary, mg));
5112 for (i = AvFILLp(ary); i >= 0; i--)
5113 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5115 /* temporarily switch stacks */
5116 SWITCHSTACK(PL_curstack, ary);
5120 base = SP - PL_stack_base;
5122 if (pm->op_pmflags & PMf_SKIPWHITE) {
5123 if (pm->op_pmflags & PMf_LOCALE) {
5124 while (isSPACE_LC(*s))
5132 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5133 SAVEINT(PL_multiline);
5134 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5138 limit = maxiters + 2;
5139 if (pm->op_pmflags & PMf_WHITE) {
5142 while (m < strend &&
5143 !((pm->op_pmflags & PMf_LOCALE)
5144 ? isSPACE_LC(*m) : isSPACE(*m)))
5149 dstr = NEWSV(30, m-s);
5150 sv_setpvn(dstr, s, m-s);
5154 (void)SvUTF8_on(dstr);
5158 while (s < strend &&
5159 ((pm->op_pmflags & PMf_LOCALE)
5160 ? isSPACE_LC(*s) : isSPACE(*s)))
5164 else if (strEQ("^", rx->precomp)) {
5167 for (m = s; m < strend && *m != '\n'; m++) ;
5171 dstr = NEWSV(30, m-s);
5172 sv_setpvn(dstr, s, m-s);
5176 (void)SvUTF8_on(dstr);
5181 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5182 && (rx->reganch & ROPT_CHECK_ALL)
5183 && !(rx->reganch & ROPT_ANCH)) {
5184 int tail = (rx->reganch & RE_INTUIT_TAIL);
5185 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5188 if (len == 1 && !tail) {
5190 char c = *SvPV(csv, n_a);
5193 for (m = s; m < strend && *m != c; m++) ;
5196 dstr = NEWSV(30, m-s);
5197 sv_setpvn(dstr, s, m-s);
5201 (void)SvUTF8_on(dstr);
5203 /* The rx->minlen is in characters but we want to step
5204 * s ahead by bytes. */
5205 s = m + (doutf8 ? SvCUR(csv) : len);
5210 while (s < strend && --limit &&
5211 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5212 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5215 dstr = NEWSV(31, m-s);
5216 sv_setpvn(dstr, s, m-s);
5220 (void)SvUTF8_on(dstr);
5222 /* The rx->minlen is in characters but we want to step
5223 * s ahead by bytes. */
5224 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5229 maxiters += (strend - s) * rx->nparens;
5230 while (s < strend && --limit
5231 /* && (!rx->check_substr
5232 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5234 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5235 1 /* minend */, sv, NULL, 0))
5237 TAINT_IF(RX_MATCH_TAINTED(rx));
5238 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5243 strend = s + (strend - m);
5245 m = rx->startp[0] + orig;
5246 dstr = NEWSV(32, m-s);
5247 sv_setpvn(dstr, s, m-s);
5251 (void)SvUTF8_on(dstr);
5254 for (i = 1; i <= rx->nparens; i++) {
5255 s = rx->startp[i] + orig;
5256 m = rx->endp[i] + orig;
5258 dstr = NEWSV(33, m-s);
5259 sv_setpvn(dstr, s, m-s);
5262 dstr = NEWSV(33, 0);
5266 (void)SvUTF8_on(dstr);
5270 s = rx->endp[0] + orig;
5274 LEAVE_SCOPE(oldsave);
5275 iters = (SP - PL_stack_base) - base;
5276 if (iters > maxiters)
5277 DIE(aTHX_ "Split loop");
5279 /* keep field after final delim? */
5280 if (s < strend || (iters && origlimit)) {
5281 STRLEN l = strend - s;
5282 dstr = NEWSV(34, l);
5283 sv_setpvn(dstr, s, l);
5287 (void)SvUTF8_on(dstr);
5291 else if (!origlimit) {
5292 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5298 SWITCHSTACK(ary, oldstack);
5299 if (SvSMAGICAL(ary)) {
5304 if (gimme == G_ARRAY) {
5306 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5314 call_method("PUSH",G_SCALAR|G_DISCARD);
5317 if (gimme == G_ARRAY) {
5318 /* EXTEND should not be needed - we just popped them */
5320 for (i=0; i < iters; i++) {
5321 SV **svp = av_fetch(ary, i, FALSE);
5322 PUSHs((svp) ? *svp : &PL_sv_undef);
5329 if (gimme == G_ARRAY)
5332 if (iters || !pm->op_pmreplroot) {
5342 Perl_unlock_condpair(pTHX_ void *svv)
5345 MAGIC *mg = mg_find((SV*)svv, 'm');
5348 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5349 MUTEX_LOCK(MgMUTEXP(mg));
5350 if (MgOWNER(mg) != thr)
5351 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5353 COND_SIGNAL(MgOWNERCONDP(mg));
5354 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5355 PTR2UV(thr), PTR2UV(svv));)
5356 MUTEX_UNLOCK(MgMUTEXP(mg));
5358 #endif /* USE_THREADS */
5367 #endif /* USE_THREADS */
5368 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5369 || SvTYPE(retsv) == SVt_PVCV) {
5370 retsv = refto(retsv);
5381 if (PL_op->op_private & OPpLVAL_INTRO)
5382 PUSHs(*save_threadsv(PL_op->op_targ));
5384 PUSHs(THREADSV(PL_op->op_targ));
5387 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5388 #endif /* USE_THREADS */