3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if LONGSIZE > 4 && defined(_CRAY)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
89 /* XXX I can't imagine anyone who doesn't have this actually _needs_
90 it, since pid_t is an integral type.
93 #ifdef NEED_GETPID_PROTO
94 extern Pid_t getpid (void);
100 if (GIMME_V == G_SCALAR)
101 XPUSHs(&PL_sv_undef);
115 if (PL_op->op_private & OPpLVAL_INTRO)
116 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
118 if (PL_op->op_flags & OPf_REF) {
122 if (GIMME == G_ARRAY) {
123 I32 maxarg = AvFILL((AV*)TARG) + 1;
125 if (SvMAGICAL(TARG)) {
127 for (i=0; i < maxarg; i++) {
128 SV **svp = av_fetch((AV*)TARG, i, FALSE);
129 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
133 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
138 SV* sv = sv_newmortal();
139 I32 maxarg = AvFILL((AV*)TARG) + 1;
140 sv_setiv(sv, maxarg);
152 if (PL_op->op_private & OPpLVAL_INTRO)
153 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
154 if (PL_op->op_flags & OPf_REF)
157 if (gimme == G_ARRAY) {
160 else if (gimme == G_SCALAR) {
161 SV* sv = sv_newmortal();
162 if (HvFILL((HV*)TARG))
163 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
164 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
174 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
185 tryAMAGICunDEREF(to_gv);
188 if (SvTYPE(sv) == SVt_PVIO) {
189 GV *gv = (GV*) sv_newmortal();
190 gv_init(gv, 0, "", 0, 0);
191 GvIOp(gv) = (IO *)sv;
192 (void)SvREFCNT_inc(sv);
195 else if (SvTYPE(sv) != SVt_PVGV)
196 DIE(aTHX_ "Not a GLOB reference");
199 if (SvTYPE(sv) != SVt_PVGV) {
203 if (SvGMAGICAL(sv)) {
208 if (!SvOK(sv) && sv != &PL_sv_undef) {
209 /* If this is a 'my' scalar and flag is set then vivify
212 if (PL_op->op_private & OPpDEREF) {
215 if (cUNOP->op_targ) {
217 SV *namesv = PL_curpad[cUNOP->op_targ];
218 name = SvPV(namesv, len);
219 gv = (GV*)NEWSV(0,0);
220 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
223 name = CopSTASHPV(PL_curcop);
226 sv_upgrade(sv, SVt_RV);
232 if (PL_op->op_flags & OPf_REF ||
233 PL_op->op_private & HINT_STRICT_REFS)
234 DIE(aTHX_ PL_no_usym, "a symbol");
235 if (ckWARN(WARN_UNINITIALIZED))
240 if ((PL_op->op_flags & OPf_SPECIAL) &&
241 !(PL_op->op_flags & OPf_MOD))
243 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
245 && (!is_gv_magical(sym,len,0)
246 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
252 if (PL_op->op_private & HINT_STRICT_REFS)
253 DIE(aTHX_ PL_no_symref, sym, "a symbol");
254 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
258 if (PL_op->op_private & OPpLVAL_INTRO)
259 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
270 tryAMAGICunDEREF(to_sv);
273 switch (SvTYPE(sv)) {
277 DIE(aTHX_ "Not a SCALAR reference");
285 if (SvTYPE(gv) != SVt_PVGV) {
286 if (SvGMAGICAL(sv)) {
292 if (PL_op->op_flags & OPf_REF ||
293 PL_op->op_private & HINT_STRICT_REFS)
294 DIE(aTHX_ PL_no_usym, "a SCALAR");
295 if (ckWARN(WARN_UNINITIALIZED))
300 if ((PL_op->op_flags & OPf_SPECIAL) &&
301 !(PL_op->op_flags & OPf_MOD))
303 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
305 && (!is_gv_magical(sym,len,0)
306 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
312 if (PL_op->op_private & HINT_STRICT_REFS)
313 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
314 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
319 if (PL_op->op_flags & OPf_MOD) {
320 if (PL_op->op_private & OPpLVAL_INTRO)
321 sv = save_scalar((GV*)TOPs);
322 else if (PL_op->op_private & OPpDEREF)
323 vivify_ref(sv, PL_op->op_private & OPpDEREF);
333 SV *sv = AvARYLEN(av);
335 AvARYLEN(av) = sv = NEWSV(0,0);
336 sv_upgrade(sv, SVt_IV);
337 sv_magic(sv, (SV*)av, '#', Nullch, 0);
345 djSP; dTARGET; dPOPss;
347 if (PL_op->op_flags & OPf_MOD) {
348 if (SvTYPE(TARG) < SVt_PVLV) {
349 sv_upgrade(TARG, SVt_PVLV);
350 sv_magic(TARG, Nullsv, '.', Nullch, 0);
354 if (LvTARG(TARG) != sv) {
356 SvREFCNT_dec(LvTARG(TARG));
357 LvTARG(TARG) = SvREFCNT_inc(sv);
359 PUSHs(TARG); /* no SvSETMAGIC */
365 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
366 mg = mg_find(sv, 'g');
367 if (mg && mg->mg_len >= 0) {
371 PUSHi(i + PL_curcop->cop_arybase);
385 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
386 /* (But not in defined().) */
387 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
390 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
391 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
392 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
395 cv = (CV*)&PL_sv_undef;
409 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
410 char *s = SvPVX(TOPs);
411 if (strnEQ(s, "CORE::", 6)) {
414 code = keyword(s + 6, SvCUR(TOPs) - 6);
415 if (code < 0) { /* Overridable. */
416 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
417 int i = 0, n = 0, seen_question = 0;
419 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
421 while (i < MAXO) { /* The slow way. */
422 if (strEQ(s + 6, PL_op_name[i])
423 || strEQ(s + 6, PL_op_desc[i]))
429 goto nonesuch; /* Should not happen... */
431 oa = PL_opargs[i] >> OASHIFT;
433 if (oa & OA_OPTIONAL) {
437 else if (n && str[0] == ';' && seen_question)
438 goto set; /* XXXX system, exec */
439 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
440 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
443 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
444 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
448 ret = sv_2mortal(newSVpvn(str, n - 1));
450 else if (code) /* Non-Overridable */
452 else { /* None such */
454 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
458 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
460 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
469 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
471 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
487 if (GIMME != G_ARRAY) {
491 *MARK = &PL_sv_undef;
492 *MARK = refto(*MARK);
496 EXTEND_MORTAL(SP - MARK);
498 *MARK = refto(*MARK);
503 S_refto(pTHX_ SV *sv)
507 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
510 if (!(sv = LvTARG(sv)))
513 (void)SvREFCNT_inc(sv);
515 else if (SvTYPE(sv) == SVt_PVAV) {
516 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
519 (void)SvREFCNT_inc(sv);
521 else if (SvPADTMP(sv))
525 (void)SvREFCNT_inc(sv);
528 sv_upgrade(rv, SVt_RV);
542 if (sv && SvGMAGICAL(sv))
545 if (!sv || !SvROK(sv))
549 pv = sv_reftype(sv,TRUE);
550 PUSHp(pv, strlen(pv));
560 stash = CopSTASH(PL_curcop);
566 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
567 Perl_croak(aTHX_ "Attempt to bless into a reference");
569 if (ckWARN(WARN_MISC) && len == 0)
570 Perl_warner(aTHX_ WARN_MISC,
571 "Explicit blessing to '' (assuming package main)");
572 stash = gv_stashpvn(ptr, len, TRUE);
575 (void)sv_bless(TOPs, stash);
589 elem = SvPV(sv, n_a);
593 switch (elem ? *elem : '\0')
596 if (strEQ(elem, "ARRAY"))
597 tmpRef = (SV*)GvAV(gv);
600 if (strEQ(elem, "CODE"))
601 tmpRef = (SV*)GvCVu(gv);
604 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
605 tmpRef = (SV*)GvIOp(gv);
607 if (strEQ(elem, "FORMAT"))
608 tmpRef = (SV*)GvFORM(gv);
611 if (strEQ(elem, "GLOB"))
615 if (strEQ(elem, "HASH"))
616 tmpRef = (SV*)GvHV(gv);
619 if (strEQ(elem, "IO"))
620 tmpRef = (SV*)GvIOp(gv);
623 if (strEQ(elem, "NAME"))
624 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
627 if (strEQ(elem, "PACKAGE"))
628 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
631 if (strEQ(elem, "SCALAR"))
645 /* Pattern matching */
650 register unsigned char *s;
653 register I32 *sfirst;
657 if (sv == PL_lastscream) {
663 SvSCREAM_off(PL_lastscream);
664 SvREFCNT_dec(PL_lastscream);
666 PL_lastscream = SvREFCNT_inc(sv);
669 s = (unsigned char*)(SvPV(sv, len));
673 if (pos > PL_maxscream) {
674 if (PL_maxscream < 0) {
675 PL_maxscream = pos + 80;
676 New(301, PL_screamfirst, 256, I32);
677 New(302, PL_screamnext, PL_maxscream, I32);
680 PL_maxscream = pos + pos / 4;
681 Renew(PL_screamnext, PL_maxscream, I32);
685 sfirst = PL_screamfirst;
686 snext = PL_screamnext;
688 if (!sfirst || !snext)
689 DIE(aTHX_ "do_study: out of memory");
691 for (ch = 256; ch; --ch)
698 snext[pos] = sfirst[ch] - pos;
705 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
714 if (PL_op->op_flags & OPf_STACKED)
720 TARG = sv_newmortal();
725 /* Lvalue operators. */
737 djSP; dMARK; dTARGET;
747 SETi(do_chomp(TOPs));
753 djSP; dMARK; dTARGET;
754 register I32 count = 0;
757 count += do_chomp(POPs);
768 if (!sv || !SvANY(sv))
770 switch (SvTYPE(sv)) {
772 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
776 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
780 if (CvROOT(sv) || CvXSUB(sv))
797 if (!PL_op->op_private) {
806 if (SvTHINKFIRST(sv))
809 switch (SvTYPE(sv)) {
819 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
820 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
821 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
825 /* let user-undef'd sub keep its identity */
826 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
833 SvSetMagicSV(sv, &PL_sv_undef);
837 Newz(602, gp, 1, GP);
838 GvGP(sv) = gp_ref(gp);
839 GvSV(sv) = NEWSV(72,0);
840 GvLINE(sv) = CopLINE(PL_curcop);
846 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
849 SvPV_set(sv, Nullch);
862 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
863 DIE(aTHX_ PL_no_modify);
864 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
865 SvIVX(TOPs) != IV_MIN)
868 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
879 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
880 DIE(aTHX_ PL_no_modify);
881 sv_setsv(TARG, TOPs);
882 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
883 SvIVX(TOPs) != IV_MAX)
886 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
900 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
901 DIE(aTHX_ PL_no_modify);
902 sv_setsv(TARG, TOPs);
903 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
904 SvIVX(TOPs) != IV_MIN)
907 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
916 /* Ordinary operators. */
920 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
923 SETn( Perl_pow( left, right) );
930 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
933 SETn( left * right );
940 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
945 DIE(aTHX_ "Illegal division by zero");
947 /* insure that 20./5. == 4. */
950 if ((NV)I_V(left) == left &&
951 (NV)I_V(right) == right &&
952 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
956 value = left / right;
960 value = left / right;
969 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
979 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
981 right = (right_neg = (i < 0)) ? -i : i;
986 right_neg = dright < 0;
991 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
993 left = (left_neg = (i < 0)) ? -i : i;
1001 left_neg = dleft < 0;
1010 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1012 # define CAST_D2UV(d) U_V(d)
1014 # define CAST_D2UV(d) ((UV)(d))
1016 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1017 * or, in other words, precision of UV more than of NV.
1018 * But in fact the approach below turned out to be an
1019 * optimization - floor() may be slow */
1020 if (dright <= UV_MAX && dleft <= UV_MAX) {
1021 right = CAST_D2UV(dright);
1022 left = CAST_D2UV(dleft);
1027 /* Backward-compatibility clause: */
1028 dright = Perl_floor(dright + 0.5);
1029 dleft = Perl_floor(dleft + 0.5);
1032 DIE(aTHX_ "Illegal modulus zero");
1034 dans = Perl_fmod(dleft, dright);
1035 if ((left_neg != right_neg) && dans)
1036 dans = dright - dans;
1039 sv_setnv(TARG, dans);
1046 DIE(aTHX_ "Illegal modulus zero");
1049 if ((left_neg != right_neg) && ans)
1052 /* XXX may warn: unary minus operator applied to unsigned type */
1053 /* could change -foo to be (~foo)+1 instead */
1054 if (ans <= ~((UV)IV_MAX)+1)
1055 sv_setiv(TARG, ~ans+1);
1057 sv_setnv(TARG, -(NV)ans);
1060 sv_setuv(TARG, ans);
1069 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1071 register IV count = POPi;
1072 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1074 I32 items = SP - MARK;
1077 max = items * count;
1086 repeatcpy((char*)(MARK + items), (char*)MARK,
1087 items * sizeof(SV*), count - 1);
1090 else if (count <= 0)
1093 else { /* Note: mark already snarfed by pp_list */
1096 bool isutf = DO_UTF8(tmpstr);
1098 SvSetSV(TARG, tmpstr);
1099 SvPV_force(TARG, len);
1104 SvGROW(TARG, (count * len) + 1);
1105 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1106 SvCUR(TARG) *= count;
1108 *SvEND(TARG) = '\0';
1111 (void)SvPOK_only_UTF8(TARG);
1113 (void)SvPOK_only(TARG);
1122 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1125 SETn( left - right );
1132 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1135 if (PL_op->op_private & HINT_INTEGER) {
1149 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1152 if (PL_op->op_private & HINT_INTEGER) {
1166 djSP; tryAMAGICbinSET(lt,0);
1169 SETs(boolSV(TOPn < value));
1176 djSP; tryAMAGICbinSET(gt,0);
1179 SETs(boolSV(TOPn > value));
1186 djSP; tryAMAGICbinSET(le,0);
1189 SETs(boolSV(TOPn <= value));
1196 djSP; tryAMAGICbinSET(ge,0);
1199 SETs(boolSV(TOPn >= value));
1206 djSP; tryAMAGICbinSET(ne,0);
1209 SETs(boolSV(TOPn != value));
1216 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1222 if (Perl_isnan(left) || Perl_isnan(right)) {
1226 value = (left > right) - (left < right);
1230 else if (left < right)
1232 else if (left > right)
1246 djSP; tryAMAGICbinSET(slt,0);
1249 int cmp = ((PL_op->op_private & OPpLOCALE)
1250 ? sv_cmp_locale(left, right)
1251 : sv_cmp(left, right));
1252 SETs(boolSV(cmp < 0));
1259 djSP; tryAMAGICbinSET(sgt,0);
1262 int cmp = ((PL_op->op_private & OPpLOCALE)
1263 ? sv_cmp_locale(left, right)
1264 : sv_cmp(left, right));
1265 SETs(boolSV(cmp > 0));
1272 djSP; tryAMAGICbinSET(sle,0);
1275 int cmp = ((PL_op->op_private & OPpLOCALE)
1276 ? sv_cmp_locale(left, right)
1277 : sv_cmp(left, right));
1278 SETs(boolSV(cmp <= 0));
1285 djSP; tryAMAGICbinSET(sge,0);
1288 int cmp = ((PL_op->op_private & OPpLOCALE)
1289 ? sv_cmp_locale(left, right)
1290 : sv_cmp(left, right));
1291 SETs(boolSV(cmp >= 0));
1298 djSP; tryAMAGICbinSET(seq,0);
1301 SETs(boolSV(sv_eq(left, right)));
1308 djSP; tryAMAGICbinSET(sne,0);
1311 SETs(boolSV(!sv_eq(left, right)));
1318 djSP; dTARGET; tryAMAGICbin(scmp,0);
1321 int cmp = ((PL_op->op_private & OPpLOCALE)
1322 ? sv_cmp_locale(left, right)
1323 : sv_cmp(left, right));
1331 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1334 if (SvNIOKp(left) || SvNIOKp(right)) {
1335 if (PL_op->op_private & HINT_INTEGER) {
1336 IV i = SvIV(left) & SvIV(right);
1340 UV u = SvUV(left) & SvUV(right);
1345 do_vop(PL_op->op_type, TARG, left, right);
1354 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1357 if (SvNIOKp(left) || SvNIOKp(right)) {
1358 if (PL_op->op_private & HINT_INTEGER) {
1359 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1363 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1368 do_vop(PL_op->op_type, TARG, left, right);
1377 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1380 if (SvNIOKp(left) || SvNIOKp(right)) {
1381 if (PL_op->op_private & HINT_INTEGER) {
1382 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1386 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1391 do_vop(PL_op->op_type, TARG, left, right);
1400 djSP; dTARGET; tryAMAGICun(neg);
1405 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1407 if (SvIVX(sv) == IV_MIN) {
1408 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1411 else if (SvUVX(sv) <= IV_MAX) {
1416 else if (SvIVX(sv) != IV_MIN) {
1423 else if (SvPOKp(sv)) {
1425 char *s = SvPV(sv, len);
1426 if (isIDFIRST(*s)) {
1427 sv_setpvn(TARG, "-", 1);
1430 else if (*s == '+' || *s == '-') {
1432 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1434 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1435 sv_setpvn(TARG, "-", 1);
1439 sv_setnv(TARG, -SvNV(sv));
1450 djSP; tryAMAGICunSET(not);
1451 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1457 djSP; dTARGET; tryAMAGICun(compl);
1461 if (PL_op->op_private & HINT_INTEGER) {
1476 tmps = (U8*)SvPV_force(TARG, len);
1479 /* Calculate exact length, let's not estimate */
1486 while (tmps < send) {
1487 UV c = utf8_to_uv(tmps, &l);
1488 tmps += UTF8SKIP(tmps);
1489 targlen += UTF8LEN(~c);
1492 /* Now rewind strings and write them. */
1494 Newz(0, result, targlen + 1, U8);
1495 while (tmps < send) {
1496 UV c = utf8_to_uv(tmps, &l);
1497 tmps += UTF8SKIP(tmps);
1498 result = uv_to_utf8(result,(UV)~c);
1502 sv_setpvn(TARG, (char*)result, targlen);
1510 register long *tmpl;
1511 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1514 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1519 for ( ; anum > 0; anum--, tmps++)
1528 /* integer versions of some of the above */
1532 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1535 SETi( left * right );
1542 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1546 DIE(aTHX_ "Illegal division by zero");
1547 value = POPi / value;
1555 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1559 DIE(aTHX_ "Illegal modulus zero");
1560 SETi( left % right );
1567 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1570 SETi( left + right );
1577 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1580 SETi( left - right );
1587 djSP; tryAMAGICbinSET(lt,0);
1590 SETs(boolSV(left < right));
1597 djSP; tryAMAGICbinSET(gt,0);
1600 SETs(boolSV(left > right));
1607 djSP; tryAMAGICbinSET(le,0);
1610 SETs(boolSV(left <= right));
1617 djSP; tryAMAGICbinSET(ge,0);
1620 SETs(boolSV(left >= right));
1627 djSP; tryAMAGICbinSET(eq,0);
1630 SETs(boolSV(left == right));
1637 djSP; tryAMAGICbinSET(ne,0);
1640 SETs(boolSV(left != right));
1647 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1654 else if (left < right)
1665 djSP; dTARGET; tryAMAGICun(neg);
1670 /* High falutin' math. */
1674 djSP; dTARGET; tryAMAGICbin(atan2,0);
1677 SETn(Perl_atan2(left, right));
1684 djSP; dTARGET; tryAMAGICun(sin);
1688 value = Perl_sin(value);
1696 djSP; dTARGET; tryAMAGICun(cos);
1700 value = Perl_cos(value);
1706 /* Support Configure command-line overrides for rand() functions.
1707 After 5.005, perhaps we should replace this by Configure support
1708 for drand48(), random(), or rand(). For 5.005, though, maintain
1709 compatibility by calling rand() but allow the user to override it.
1710 See INSTALL for details. --Andy Dougherty 15 July 1998
1712 /* Now it's after 5.005, and Configure supports drand48() and random(),
1713 in addition to rand(). So the overrides should not be needed any more.
1714 --Jarkko Hietaniemi 27 September 1998
1717 #ifndef HAS_DRAND48_PROTO
1718 extern double drand48 (void);
1731 if (!PL_srand_called) {
1732 (void)seedDrand01((Rand_seed_t)seed());
1733 PL_srand_called = TRUE;
1748 (void)seedDrand01((Rand_seed_t)anum);
1749 PL_srand_called = TRUE;
1758 * This is really just a quick hack which grabs various garbage
1759 * values. It really should be a real hash algorithm which
1760 * spreads the effect of every input bit onto every output bit,
1761 * if someone who knows about such things would bother to write it.
1762 * Might be a good idea to add that function to CORE as well.
1763 * No numbers below come from careful analysis or anything here,
1764 * except they are primes and SEED_C1 > 1E6 to get a full-width
1765 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1766 * probably be bigger too.
1769 # define SEED_C1 1000003
1770 #define SEED_C4 73819
1772 # define SEED_C1 25747
1773 #define SEED_C4 20639
1777 #define SEED_C5 26107
1780 #ifndef PERL_NO_DEV_RANDOM
1785 # include <starlet.h>
1786 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1787 * in 100-ns units, typically incremented ever 10 ms. */
1788 unsigned int when[2];
1790 # ifdef HAS_GETTIMEOFDAY
1791 struct timeval when;
1797 /* This test is an escape hatch, this symbol isn't set by Configure. */
1798 #ifndef PERL_NO_DEV_RANDOM
1799 #ifndef PERL_RANDOM_DEVICE
1800 /* /dev/random isn't used by default because reads from it will block
1801 * if there isn't enough entropy available. You can compile with
1802 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1803 * is enough real entropy to fill the seed. */
1804 # define PERL_RANDOM_DEVICE "/dev/urandom"
1806 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1808 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1817 _ckvmssts(sys$gettim(when));
1818 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1820 # ifdef HAS_GETTIMEOFDAY
1821 gettimeofday(&when,(struct timezone *) 0);
1822 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1825 u = (U32)SEED_C1 * when;
1828 u += SEED_C3 * (U32)PerlProc_getpid();
1829 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1830 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1831 u += SEED_C5 * (U32)PTR2UV(&when);
1838 djSP; dTARGET; tryAMAGICun(exp);
1842 value = Perl_exp(value);
1850 djSP; dTARGET; tryAMAGICun(log);
1855 SET_NUMERIC_STANDARD();
1856 DIE(aTHX_ "Can't take log of %g", value);
1858 value = Perl_log(value);
1866 djSP; dTARGET; tryAMAGICun(sqrt);
1871 SET_NUMERIC_STANDARD();
1872 DIE(aTHX_ "Can't take sqrt of %g", value);
1874 value = Perl_sqrt(value);
1887 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1893 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1894 (void)Perl_modf(value, &value);
1896 double tmp = (double)value;
1897 (void)Perl_modf(tmp, &tmp);
1902 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1903 (void)Perl_modf(-value, &value);
1906 double tmp = (double)value;
1907 (void)Perl_modf(-tmp, &tmp);
1923 djSP; dTARGET; tryAMAGICun(abs);
1928 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1929 (iv = SvIVX(TOPs)) != IV_MIN) {
1951 argtype = 1; /* allow underscores */
1952 XPUSHn(scan_hex(tmps, 99, &argtype));
1965 while (*tmps && isSPACE(*tmps))
1969 argtype = 1; /* allow underscores */
1971 value = scan_hex(++tmps, 99, &argtype);
1972 else if (*tmps == 'b')
1973 value = scan_bin(++tmps, 99, &argtype);
1975 value = scan_oct(tmps, 99, &argtype);
1988 SETi(sv_len_utf8(sv));
2004 I32 lvalue = PL_op->op_flags & OPf_MOD;
2006 I32 arybase = PL_curcop->cop_arybase;
2010 SvTAINTED_off(TARG); /* decontaminate */
2011 SvUTF8_off(TARG); /* decontaminate */
2015 repl = SvPV(sv, repl_len);
2022 tmps = SvPV(sv, curlen);
2024 utfcurlen = sv_len_utf8(sv);
2025 if (utfcurlen == curlen)
2033 if (pos >= arybase) {
2051 else if (len >= 0) {
2053 if (rem > (I32)curlen)
2068 Perl_croak(aTHX_ "substr outside of string");
2069 if (ckWARN(WARN_SUBSTR))
2070 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2075 sv_pos_u2b(sv, &pos, &rem);
2077 sv_setpvn(TARG, tmps, rem);
2081 sv_insert(sv, pos, rem, repl, repl_len);
2082 else if (lvalue) { /* it's an lvalue! */
2083 if (!SvGMAGICAL(sv)) {
2087 if (ckWARN(WARN_SUBSTR))
2088 Perl_warner(aTHX_ WARN_SUBSTR,
2089 "Attempt to use reference as lvalue in substr");
2091 if (SvOK(sv)) /* is it defined ? */
2092 (void)SvPOK_only_UTF8(sv);
2094 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2097 if (SvTYPE(TARG) < SVt_PVLV) {
2098 sv_upgrade(TARG, SVt_PVLV);
2099 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2103 if (LvTARG(TARG) != sv) {
2105 SvREFCNT_dec(LvTARG(TARG));
2106 LvTARG(TARG) = SvREFCNT_inc(sv);
2108 LvTARGOFF(TARG) = pos;
2109 LvTARGLEN(TARG) = rem;
2113 PUSHs(TARG); /* avoid SvSETMAGIC here */
2120 register IV size = POPi;
2121 register IV offset = POPi;
2122 register SV *src = POPs;
2123 I32 lvalue = PL_op->op_flags & OPf_MOD;
2125 SvTAINTED_off(TARG); /* decontaminate */
2126 if (lvalue) { /* it's an lvalue! */
2127 if (SvTYPE(TARG) < SVt_PVLV) {
2128 sv_upgrade(TARG, SVt_PVLV);
2129 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2132 if (LvTARG(TARG) != src) {
2134 SvREFCNT_dec(LvTARG(TARG));
2135 LvTARG(TARG) = SvREFCNT_inc(src);
2137 LvTARGOFF(TARG) = offset;
2138 LvTARGLEN(TARG) = size;
2141 sv_setuv(TARG, do_vecget(src, offset, size));
2156 I32 arybase = PL_curcop->cop_arybase;
2161 offset = POPi - arybase;
2164 tmps = SvPV(big, biglen);
2165 if (offset > 0 && DO_UTF8(big))
2166 sv_pos_u2b(big, &offset, 0);
2169 else if (offset > biglen)
2171 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2172 (unsigned char*)tmps + biglen, little, 0)))
2175 retval = tmps2 - tmps;
2176 if (retval > 0 && DO_UTF8(big))
2177 sv_pos_b2u(big, &retval);
2178 PUSHi(retval + arybase);
2193 I32 arybase = PL_curcop->cop_arybase;
2199 tmps2 = SvPV(little, llen);
2200 tmps = SvPV(big, blen);
2204 if (offset > 0 && DO_UTF8(big))
2205 sv_pos_u2b(big, &offset, 0);
2206 offset = offset - arybase + llen;
2210 else if (offset > blen)
2212 if (!(tmps2 = rninstr(tmps, tmps + offset,
2213 tmps2, tmps2 + llen)))
2216 retval = tmps2 - tmps;
2217 if (retval > 0 && DO_UTF8(big))
2218 sv_pos_b2u(big, &retval);
2219 PUSHi(retval + arybase);
2225 djSP; dMARK; dORIGMARK; dTARGET;
2226 do_sprintf(TARG, SP-MARK, MARK+1);
2227 TAINT_IF(SvTAINTED(TARG));
2239 U8 *tmps = (U8*)SvPVx(tmpsv, len);
2242 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2243 value = utf8_to_uv_chk(tmps, len, &retlen, 0);
2245 value = (UV)(*tmps & 255);
2256 (void)SvUPGRADE(TARG,SVt_PV);
2258 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2259 SvGROW(TARG, UTF8_MAXLEN+1);
2261 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2262 SvCUR_set(TARG, tmps - SvPVX(TARG));
2264 (void)SvPOK_only(TARG);
2275 (void)SvPOK_only(TARG);
2282 djSP; dTARGET; dPOPTOPssrl;
2285 char *tmps = SvPV(left, n_a);
2287 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2289 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2293 "The crypt() function is unimplemented due to excessive paranoia.");
2306 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2308 U8 tmpbuf[UTF8_MAXLEN];
2310 UV uv = utf8_to_uv_chk(s, slen, &ulen, 0);
2312 if (PL_op->op_private & OPpLOCALE) {
2315 uv = toTITLE_LC_uni(uv);
2318 uv = toTITLE_utf8(s);
2320 tend = uv_to_utf8(tmpbuf, uv);
2322 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2324 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2325 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2330 s = (U8*)SvPV_force(sv, slen);
2331 Copy(tmpbuf, s, ulen, U8);
2335 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2337 SvUTF8_off(TARG); /* decontaminate */
2342 s = (U8*)SvPV_force(sv, slen);
2344 if (PL_op->op_private & OPpLOCALE) {
2347 *s = toUPPER_LC(*s);
2365 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2367 U8 tmpbuf[UTF8_MAXLEN];
2369 UV uv = utf8_to_uv_chk(s, slen, &ulen, 0);
2371 if (PL_op->op_private & OPpLOCALE) {
2374 uv = toLOWER_LC_uni(uv);
2377 uv = toLOWER_utf8(s);
2379 tend = uv_to_utf8(tmpbuf, uv);
2381 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2383 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2384 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2389 s = (U8*)SvPV_force(sv, slen);
2390 Copy(tmpbuf, s, ulen, U8);
2394 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2396 SvUTF8_off(TARG); /* decontaminate */
2401 s = (U8*)SvPV_force(sv, slen);
2403 if (PL_op->op_private & OPpLOCALE) {
2406 *s = toLOWER_LC(*s);
2430 s = (U8*)SvPV(sv,len);
2432 SvUTF8_off(TARG); /* decontaminate */
2433 sv_setpvn(TARG, "", 0);
2437 (void)SvUPGRADE(TARG, SVt_PV);
2438 SvGROW(TARG, (len * 2) + 1);
2439 (void)SvPOK_only(TARG);
2440 d = (U8*)SvPVX(TARG);
2442 if (PL_op->op_private & OPpLOCALE) {
2446 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv_chk(s, len, &ulen, 0)));
2452 d = uv_to_utf8(d, toUPPER_utf8( s ));
2458 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2463 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2465 SvUTF8_off(TARG); /* decontaminate */
2470 s = (U8*)SvPV_force(sv, len);
2472 register U8 *send = s + len;
2474 if (PL_op->op_private & OPpLOCALE) {
2477 for (; s < send; s++)
2478 *s = toUPPER_LC(*s);
2481 for (; s < send; s++)
2504 s = (U8*)SvPV(sv,len);
2506 SvUTF8_off(TARG); /* decontaminate */
2507 sv_setpvn(TARG, "", 0);
2511 (void)SvUPGRADE(TARG, SVt_PV);
2512 SvGROW(TARG, (len * 2) + 1);
2513 (void)SvPOK_only(TARG);
2514 d = (U8*)SvPVX(TARG);
2516 if (PL_op->op_private & OPpLOCALE) {
2520 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv_chk(s, len, &ulen, 0)));
2526 d = uv_to_utf8(d, toLOWER_utf8(s));
2532 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2537 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2539 SvUTF8_off(TARG); /* decontaminate */
2545 s = (U8*)SvPV_force(sv, len);
2547 register U8 *send = s + len;
2549 if (PL_op->op_private & OPpLOCALE) {
2552 for (; s < send; s++)
2553 *s = toLOWER_LC(*s);
2556 for (; s < send; s++)
2571 register char *s = SvPV(sv,len);
2574 SvUTF8_off(TARG); /* decontaminate */
2576 (void)SvUPGRADE(TARG, SVt_PV);
2577 SvGROW(TARG, (len * 2) + 1);
2582 STRLEN ulen = UTF8SKIP(s);
2606 SvCUR_set(TARG, d - SvPVX(TARG));
2607 (void)SvPOK_only_UTF8(TARG);
2610 sv_setpvn(TARG, s, len);
2612 if (SvSMAGICAL(TARG))
2621 djSP; dMARK; dORIGMARK;
2623 register AV* av = (AV*)POPs;
2624 register I32 lval = PL_op->op_flags & OPf_MOD;
2625 I32 arybase = PL_curcop->cop_arybase;
2628 if (SvTYPE(av) == SVt_PVAV) {
2629 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2631 for (svp = MARK + 1; svp <= SP; svp++) {
2636 if (max > AvMAX(av))
2639 while (++MARK <= SP) {
2640 elem = SvIVx(*MARK);
2644 svp = av_fetch(av, elem, lval);
2646 if (!svp || *svp == &PL_sv_undef)
2647 DIE(aTHX_ PL_no_aelem, elem);
2648 if (PL_op->op_private & OPpLVAL_INTRO)
2649 save_aelem(av, elem, svp);
2651 *MARK = svp ? *svp : &PL_sv_undef;
2654 if (GIMME != G_ARRAY) {
2662 /* Associative arrays. */
2667 HV *hash = (HV*)POPs;
2669 I32 gimme = GIMME_V;
2670 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2673 /* might clobber stack_sp */
2674 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2679 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2680 if (gimme == G_ARRAY) {
2683 /* might clobber stack_sp */
2685 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2690 else if (gimme == G_SCALAR)
2709 I32 gimme = GIMME_V;
2710 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2714 if (PL_op->op_private & OPpSLICE) {
2718 hvtype = SvTYPE(hv);
2719 if (hvtype == SVt_PVHV) { /* hash element */
2720 while (++MARK <= SP) {
2721 sv = hv_delete_ent(hv, *MARK, discard, 0);
2722 *MARK = sv ? sv : &PL_sv_undef;
2725 else if (hvtype == SVt_PVAV) {
2726 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2727 while (++MARK <= SP) {
2728 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2729 *MARK = sv ? sv : &PL_sv_undef;
2732 else { /* pseudo-hash element */
2733 while (++MARK <= SP) {
2734 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2735 *MARK = sv ? sv : &PL_sv_undef;
2740 DIE(aTHX_ "Not a HASH reference");
2743 else if (gimme == G_SCALAR) {
2752 if (SvTYPE(hv) == SVt_PVHV)
2753 sv = hv_delete_ent(hv, keysv, discard, 0);
2754 else if (SvTYPE(hv) == SVt_PVAV) {
2755 if (PL_op->op_flags & OPf_SPECIAL)
2756 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2758 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2761 DIE(aTHX_ "Not a HASH reference");
2776 if (PL_op->op_private & OPpEXISTS_SUB) {
2780 cv = sv_2cv(sv, &hv, &gv, FALSE);
2783 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2789 if (SvTYPE(hv) == SVt_PVHV) {
2790 if (hv_exists_ent(hv, tmpsv, 0))
2793 else if (SvTYPE(hv) == SVt_PVAV) {
2794 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2795 if (av_exists((AV*)hv, SvIV(tmpsv)))
2798 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2802 DIE(aTHX_ "Not a HASH reference");
2809 djSP; dMARK; dORIGMARK;
2810 register HV *hv = (HV*)POPs;
2811 register I32 lval = PL_op->op_flags & OPf_MOD;
2812 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2814 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2815 DIE(aTHX_ "Can't localize pseudo-hash element");
2817 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2818 while (++MARK <= SP) {
2822 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2823 svp = he ? &HeVAL(he) : 0;
2826 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2829 if (!svp || *svp == &PL_sv_undef) {
2831 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2833 if (PL_op->op_private & OPpLVAL_INTRO)
2834 save_helem(hv, keysv, svp);
2836 *MARK = svp ? *svp : &PL_sv_undef;
2839 if (GIMME != G_ARRAY) {
2847 /* List operators. */
2852 if (GIMME != G_ARRAY) {
2854 *MARK = *SP; /* unwanted list, return last item */
2856 *MARK = &PL_sv_undef;
2865 SV **lastrelem = PL_stack_sp;
2866 SV **lastlelem = PL_stack_base + POPMARK;
2867 SV **firstlelem = PL_stack_base + POPMARK + 1;
2868 register SV **firstrelem = lastlelem + 1;
2869 I32 arybase = PL_curcop->cop_arybase;
2870 I32 lval = PL_op->op_flags & OPf_MOD;
2871 I32 is_something_there = lval;
2873 register I32 max = lastrelem - lastlelem;
2874 register SV **lelem;
2877 if (GIMME != G_ARRAY) {
2878 ix = SvIVx(*lastlelem);
2883 if (ix < 0 || ix >= max)
2884 *firstlelem = &PL_sv_undef;
2886 *firstlelem = firstrelem[ix];
2892 SP = firstlelem - 1;
2896 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2902 if (ix < 0 || ix >= max)
2903 *lelem = &PL_sv_undef;
2905 is_something_there = TRUE;
2906 if (!(*lelem = firstrelem[ix]))
2907 *lelem = &PL_sv_undef;
2910 if (is_something_there)
2913 SP = firstlelem - 1;
2919 djSP; dMARK; dORIGMARK;
2920 I32 items = SP - MARK;
2921 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2922 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2929 djSP; dMARK; dORIGMARK;
2930 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2934 SV *val = NEWSV(46, 0);
2936 sv_setsv(val, *++MARK);
2937 else if (ckWARN(WARN_MISC))
2938 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2939 (void)hv_store_ent(hv,key,val,0);
2948 djSP; dMARK; dORIGMARK;
2949 register AV *ary = (AV*)*++MARK;
2953 register I32 offset;
2954 register I32 length;
2961 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2962 *MARK-- = SvTIED_obj((SV*)ary, mg);
2966 call_method("SPLICE",GIMME_V);
2975 offset = i = SvIVx(*MARK);
2977 offset += AvFILLp(ary) + 1;
2979 offset -= PL_curcop->cop_arybase;
2981 DIE(aTHX_ PL_no_aelem, i);
2983 length = SvIVx(*MARK++);
2985 length += AvFILLp(ary) - offset + 1;
2991 length = AvMAX(ary) + 1; /* close enough to infinity */
2995 length = AvMAX(ary) + 1;
2997 if (offset > AvFILLp(ary) + 1)
2998 offset = AvFILLp(ary) + 1;
2999 after = AvFILLp(ary) + 1 - (offset + length);
3000 if (after < 0) { /* not that much array */
3001 length += after; /* offset+length now in array */
3007 /* At this point, MARK .. SP-1 is our new LIST */
3010 diff = newlen - length;
3011 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3014 if (diff < 0) { /* shrinking the area */
3016 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3017 Copy(MARK, tmparyval, newlen, SV*);
3020 MARK = ORIGMARK + 1;
3021 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3022 MEXTEND(MARK, length);
3023 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3025 EXTEND_MORTAL(length);
3026 for (i = length, dst = MARK; i; i--) {
3027 sv_2mortal(*dst); /* free them eventualy */
3034 *MARK = AvARRAY(ary)[offset+length-1];
3037 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3038 SvREFCNT_dec(*dst++); /* free them now */
3041 AvFILLp(ary) += diff;
3043 /* pull up or down? */
3045 if (offset < after) { /* easier to pull up */
3046 if (offset) { /* esp. if nothing to pull */
3047 src = &AvARRAY(ary)[offset-1];
3048 dst = src - diff; /* diff is negative */
3049 for (i = offset; i > 0; i--) /* can't trust Copy */
3053 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3057 if (after) { /* anything to pull down? */
3058 src = AvARRAY(ary) + offset + length;
3059 dst = src + diff; /* diff is negative */
3060 Move(src, dst, after, SV*);
3062 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3063 /* avoid later double free */
3067 dst[--i] = &PL_sv_undef;
3070 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3072 *dst = NEWSV(46, 0);
3073 sv_setsv(*dst++, *src++);
3075 Safefree(tmparyval);
3078 else { /* no, expanding (or same) */
3080 New(452, tmparyval, length, SV*); /* so remember deletion */
3081 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3084 if (diff > 0) { /* expanding */
3086 /* push up or down? */
3088 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3092 Move(src, dst, offset, SV*);
3094 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3096 AvFILLp(ary) += diff;
3099 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3100 av_extend(ary, AvFILLp(ary) + diff);
3101 AvFILLp(ary) += diff;
3104 dst = AvARRAY(ary) + AvFILLp(ary);
3106 for (i = after; i; i--) {
3113 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3114 *dst = NEWSV(46, 0);
3115 sv_setsv(*dst++, *src++);
3117 MARK = ORIGMARK + 1;
3118 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3120 Copy(tmparyval, MARK, length, SV*);
3122 EXTEND_MORTAL(length);
3123 for (i = length, dst = MARK; i; i--) {
3124 sv_2mortal(*dst); /* free them eventualy */
3128 Safefree(tmparyval);
3132 else if (length--) {
3133 *MARK = tmparyval[length];
3136 while (length-- > 0)
3137 SvREFCNT_dec(tmparyval[length]);
3139 Safefree(tmparyval);
3142 *MARK = &PL_sv_undef;
3150 djSP; dMARK; dORIGMARK; dTARGET;
3151 register AV *ary = (AV*)*++MARK;
3152 register SV *sv = &PL_sv_undef;
3155 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3156 *MARK-- = SvTIED_obj((SV*)ary, mg);
3160 call_method("PUSH",G_SCALAR|G_DISCARD);
3165 /* Why no pre-extend of ary here ? */
3166 for (++MARK; MARK <= SP; MARK++) {
3169 sv_setsv(sv, *MARK);
3174 PUSHi( AvFILL(ary) + 1 );
3182 SV *sv = av_pop(av);
3184 (void)sv_2mortal(sv);
3193 SV *sv = av_shift(av);
3198 (void)sv_2mortal(sv);
3205 djSP; dMARK; dORIGMARK; dTARGET;
3206 register AV *ary = (AV*)*++MARK;
3211 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3212 *MARK-- = SvTIED_obj((SV*)ary, mg);
3216 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3221 av_unshift(ary, SP - MARK);
3224 sv_setsv(sv, *++MARK);
3225 (void)av_store(ary, i++, sv);
3229 PUSHi( AvFILL(ary) + 1 );
3239 if (GIMME == G_ARRAY) {
3246 /* safe as long as stack cannot get extended in the above */
3251 register char *down;
3256 SvUTF8_off(TARG); /* decontaminate */
3258 do_join(TARG, &PL_sv_no, MARK, SP);
3260 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3261 up = SvPV_force(TARG, len);
3263 if (DO_UTF8(TARG)) { /* first reverse each character */
3264 U8* s = (U8*)SvPVX(TARG);
3265 U8* send = (U8*)(s + len);
3274 down = (char*)(s - 1);
3275 if (s > send || !((*down & 0xc0) == 0x80)) {
3276 if (ckWARN_d(WARN_UTF8))
3277 Perl_warner(aTHX_ WARN_UTF8,
3278 "Malformed UTF-8 character");
3290 down = SvPVX(TARG) + len - 1;
3296 (void)SvPOK_only_UTF8(TARG);
3305 S_mul128(pTHX_ SV *sv, U8 m)
3308 char *s = SvPV(sv, len);
3312 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3313 SV *tmpNew = newSVpvn("0000000000", 10);
3315 sv_catsv(tmpNew, sv);
3316 SvREFCNT_dec(sv); /* free old sv */
3321 while (!*t) /* trailing '\0'? */
3324 i = ((*t - '0') << 7) + m;
3325 *(t--) = '0' + (i % 10);
3331 /* Explosives and implosives. */
3333 #if 'I' == 73 && 'J' == 74
3334 /* On an ASCII/ISO kind of system */
3335 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3338 Some other sort of character set - use memchr() so we don't match
3341 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3348 I32 start_sp_offset = SP - PL_stack_base;
3349 I32 gimme = GIMME_V;
3353 register char *pat = SvPV(left, llen);
3354 register char *s = SvPV(right, rlen);
3355 char *strend = s + rlen;
3357 register char *patend = pat + llen;
3363 /* These must not be in registers: */
3380 register U32 culong;
3384 #ifdef PERL_NATINT_PACK
3385 int natint; /* native integer */
3386 int unatint; /* unsigned native integer */
3389 if (gimme != G_ARRAY) { /* arrange to do first one only */
3391 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3392 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3394 while (isDIGIT(*patend) || *patend == '*')
3400 while (pat < patend) {
3402 datumtype = *pat++ & 0xFF;
3403 #ifdef PERL_NATINT_PACK
3406 if (isSPACE(datumtype))
3408 if (datumtype == '#') {
3409 while (pat < patend && *pat != '\n')
3414 char *natstr = "sSiIlL";
3416 if (strchr(natstr, datumtype)) {
3417 #ifdef PERL_NATINT_PACK
3423 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3428 else if (*pat == '*') {
3429 len = strend - strbeg; /* long enough */
3433 else if (isDIGIT(*pat)) {
3435 while (isDIGIT(*pat)) {
3436 len = (len * 10) + (*pat++ - '0');
3438 DIE(aTHX_ "Repeat count in unpack overflows");
3442 len = (datumtype != '@');
3446 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3447 case ',': /* grandfather in commas but with a warning */
3448 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3449 Perl_warner(aTHX_ WARN_UNPACK,
3450 "Invalid type in unpack: '%c'", (int)datumtype);
3453 if (len == 1 && pat[-1] != '1')
3462 if (len > strend - strbeg)
3463 DIE(aTHX_ "@ outside of string");
3467 if (len > s - strbeg)
3468 DIE(aTHX_ "X outside of string");
3472 if (len > strend - s)
3473 DIE(aTHX_ "x outside of string");
3477 if (start_sp_offset >= SP - PL_stack_base)
3478 DIE(aTHX_ "/ must follow a numeric type");
3481 pat++; /* ignore '*' for compatibility with pack */
3483 DIE(aTHX_ "/ cannot take a count" );
3490 if (len > strend - s)
3493 goto uchar_checksum;
3494 sv = NEWSV(35, len);
3495 sv_setpvn(sv, s, len);
3497 if (datumtype == 'A' || datumtype == 'Z') {
3498 aptr = s; /* borrow register */
3499 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3504 else { /* 'A' strips both nulls and spaces */
3505 s = SvPVX(sv) + len - 1;
3506 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3510 SvCUR_set(sv, s - SvPVX(sv));
3511 s = aptr; /* unborrow register */
3513 XPUSHs(sv_2mortal(sv));
3517 if (star || len > (strend - s) * 8)
3518 len = (strend - s) * 8;
3521 Newz(601, PL_bitcount, 256, char);
3522 for (bits = 1; bits < 256; bits++) {
3523 if (bits & 1) PL_bitcount[bits]++;
3524 if (bits & 2) PL_bitcount[bits]++;
3525 if (bits & 4) PL_bitcount[bits]++;
3526 if (bits & 8) PL_bitcount[bits]++;
3527 if (bits & 16) PL_bitcount[bits]++;
3528 if (bits & 32) PL_bitcount[bits]++;
3529 if (bits & 64) PL_bitcount[bits]++;
3530 if (bits & 128) PL_bitcount[bits]++;
3534 culong += PL_bitcount[*(unsigned char*)s++];
3539 if (datumtype == 'b') {
3541 if (bits & 1) culong++;
3547 if (bits & 128) culong++;
3554 sv = NEWSV(35, len + 1);
3558 if (datumtype == 'b') {
3560 for (len = 0; len < aint; len++) {
3561 if (len & 7) /*SUPPRESS 595*/
3565 *str++ = '0' + (bits & 1);
3570 for (len = 0; len < aint; len++) {
3575 *str++ = '0' + ((bits & 128) != 0);
3579 XPUSHs(sv_2mortal(sv));
3583 if (star || len > (strend - s) * 2)
3584 len = (strend - s) * 2;
3585 sv = NEWSV(35, len + 1);
3589 if (datumtype == 'h') {
3591 for (len = 0; len < aint; len++) {
3596 *str++ = PL_hexdigit[bits & 15];
3601 for (len = 0; len < aint; len++) {
3606 *str++ = PL_hexdigit[(bits >> 4) & 15];
3610 XPUSHs(sv_2mortal(sv));
3613 if (len > strend - s)
3618 if (aint >= 128) /* fake up signed chars */
3628 if (aint >= 128) /* fake up signed chars */
3631 sv_setiv(sv, (IV)aint);
3632 PUSHs(sv_2mortal(sv));
3637 if (len > strend - s)
3652 sv_setiv(sv, (IV)auint);
3653 PUSHs(sv_2mortal(sv));
3658 if (len > strend - s)
3661 while (len-- > 0 && s < strend) {
3662 auint = utf8_to_uv_chk((U8*)s, strend - s, &along, 0);
3665 cdouble += (NV)auint;
3673 while (len-- > 0 && s < strend) {
3674 auint = utf8_to_uv_chk((U8*)s, strend - s, &along, 0);
3677 sv_setuv(sv, (UV)auint);
3678 PUSHs(sv_2mortal(sv));
3683 #if SHORTSIZE == SIZE16
3684 along = (strend - s) / SIZE16;
3686 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3691 #if SHORTSIZE != SIZE16
3695 COPYNN(s, &ashort, sizeof(short));
3706 #if SHORTSIZE > SIZE16
3718 #if SHORTSIZE != SIZE16
3722 COPYNN(s, &ashort, sizeof(short));
3725 sv_setiv(sv, (IV)ashort);
3726 PUSHs(sv_2mortal(sv));
3734 #if SHORTSIZE > SIZE16
3740 sv_setiv(sv, (IV)ashort);
3741 PUSHs(sv_2mortal(sv));
3749 #if SHORTSIZE == SIZE16
3750 along = (strend - s) / SIZE16;
3752 unatint = natint && datumtype == 'S';
3753 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3758 #if SHORTSIZE != SIZE16
3760 unsigned short aushort;
3762 COPYNN(s, &aushort, sizeof(unsigned short));
3763 s += sizeof(unsigned short);
3771 COPY16(s, &aushort);
3774 if (datumtype == 'n')
3775 aushort = PerlSock_ntohs(aushort);
3778 if (datumtype == 'v')
3779 aushort = vtohs(aushort);
3788 #if SHORTSIZE != SIZE16
3790 unsigned short aushort;
3792 COPYNN(s, &aushort, sizeof(unsigned short));
3793 s += sizeof(unsigned short);
3795 sv_setiv(sv, (UV)aushort);
3796 PUSHs(sv_2mortal(sv));
3803 COPY16(s, &aushort);
3807 if (datumtype == 'n')
3808 aushort = PerlSock_ntohs(aushort);
3811 if (datumtype == 'v')
3812 aushort = vtohs(aushort);
3814 sv_setiv(sv, (UV)aushort);
3815 PUSHs(sv_2mortal(sv));
3821 along = (strend - s) / sizeof(int);
3826 Copy(s, &aint, 1, int);
3829 cdouble += (NV)aint;
3838 Copy(s, &aint, 1, int);
3842 /* Without the dummy below unpack("i", pack("i",-1))
3843 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3844 * cc with optimization turned on.
3846 * The bug was detected in
3847 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3848 * with optimization (-O4) turned on.
3849 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3850 * does not have this problem even with -O4.
3852 * This bug was reported as DECC_BUGS 1431
3853 * and tracked internally as GEM_BUGS 7775.
3855 * The bug is fixed in
3856 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3857 * UNIX V4.0F support: DEC C V5.9-006 or later
3858 * UNIX V4.0E support: DEC C V5.8-011 or later
3861 * See also few lines later for the same bug.
3864 sv_setiv(sv, (IV)aint) :
3866 sv_setiv(sv, (IV)aint);
3867 PUSHs(sv_2mortal(sv));
3872 along = (strend - s) / sizeof(unsigned int);
3877 Copy(s, &auint, 1, unsigned int);
3878 s += sizeof(unsigned int);
3880 cdouble += (NV)auint;
3889 Copy(s, &auint, 1, unsigned int);
3890 s += sizeof(unsigned int);
3893 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3894 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3895 * See details few lines earlier. */
3897 sv_setuv(sv, (UV)auint) :
3899 sv_setuv(sv, (UV)auint);
3900 PUSHs(sv_2mortal(sv));
3905 #if LONGSIZE == SIZE32
3906 along = (strend - s) / SIZE32;
3908 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3913 #if LONGSIZE != SIZE32
3917 COPYNN(s, &along, sizeof(long));
3920 cdouble += (NV)along;
3930 #if LONGSIZE > SIZE32
3931 if (along > 2147483647)
3932 along -= 4294967296;
3936 cdouble += (NV)along;
3945 #if LONGSIZE != SIZE32
3949 COPYNN(s, &along, sizeof(long));
3952 sv_setiv(sv, (IV)along);
3953 PUSHs(sv_2mortal(sv));
3961 #if LONGSIZE > SIZE32
3962 if (along > 2147483647)
3963 along -= 4294967296;
3967 sv_setiv(sv, (IV)along);
3968 PUSHs(sv_2mortal(sv));
3976 #if LONGSIZE == SIZE32
3977 along = (strend - s) / SIZE32;
3979 unatint = natint && datumtype == 'L';
3980 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3985 #if LONGSIZE != SIZE32
3987 unsigned long aulong;
3989 COPYNN(s, &aulong, sizeof(unsigned long));
3990 s += sizeof(unsigned long);
3992 cdouble += (NV)aulong;
4004 if (datumtype == 'N')
4005 aulong = PerlSock_ntohl(aulong);
4008 if (datumtype == 'V')
4009 aulong = vtohl(aulong);
4012 cdouble += (NV)aulong;
4021 #if LONGSIZE != SIZE32
4023 unsigned long aulong;
4025 COPYNN(s, &aulong, sizeof(unsigned long));
4026 s += sizeof(unsigned long);
4028 sv_setuv(sv, (UV)aulong);
4029 PUSHs(sv_2mortal(sv));
4039 if (datumtype == 'N')
4040 aulong = PerlSock_ntohl(aulong);
4043 if (datumtype == 'V')
4044 aulong = vtohl(aulong);
4047 sv_setuv(sv, (UV)aulong);
4048 PUSHs(sv_2mortal(sv));
4054 along = (strend - s) / sizeof(char*);
4060 if (sizeof(char*) > strend - s)
4063 Copy(s, &aptr, 1, char*);
4069 PUSHs(sv_2mortal(sv));
4079 while ((len > 0) && (s < strend)) {
4080 auv = (auv << 7) | (*s & 0x7f);
4081 if (!(*s++ & 0x80)) {
4085 PUSHs(sv_2mortal(sv));
4089 else if (++bytes >= sizeof(UV)) { /* promote to string */
4093 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4094 while (s < strend) {
4095 sv = mul128(sv, *s & 0x7f);
4096 if (!(*s++ & 0x80)) {
4105 PUSHs(sv_2mortal(sv));
4110 if ((s >= strend) && bytes)
4111 DIE(aTHX_ "Unterminated compressed integer");
4116 if (sizeof(char*) > strend - s)
4119 Copy(s, &aptr, 1, char*);
4124 sv_setpvn(sv, aptr, len);
4125 PUSHs(sv_2mortal(sv));
4129 along = (strend - s) / sizeof(Quad_t);
4135 if (s + sizeof(Quad_t) > strend)
4138 Copy(s, &aquad, 1, Quad_t);
4139 s += sizeof(Quad_t);
4142 if (aquad >= IV_MIN && aquad <= IV_MAX)
4143 sv_setiv(sv, (IV)aquad);
4145 sv_setnv(sv, (NV)aquad);
4146 PUSHs(sv_2mortal(sv));
4150 along = (strend - s) / sizeof(Quad_t);
4156 if (s + sizeof(Uquad_t) > strend)
4159 Copy(s, &auquad, 1, Uquad_t);
4160 s += sizeof(Uquad_t);
4163 if (auquad <= UV_MAX)
4164 sv_setuv(sv, (UV)auquad);
4166 sv_setnv(sv, (NV)auquad);
4167 PUSHs(sv_2mortal(sv));
4171 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4174 along = (strend - s) / sizeof(float);
4179 Copy(s, &afloat, 1, float);
4188 Copy(s, &afloat, 1, float);
4191 sv_setnv(sv, (NV)afloat);
4192 PUSHs(sv_2mortal(sv));
4198 along = (strend - s) / sizeof(double);
4203 Copy(s, &adouble, 1, double);
4204 s += sizeof(double);
4212 Copy(s, &adouble, 1, double);
4213 s += sizeof(double);
4215 sv_setnv(sv, (NV)adouble);
4216 PUSHs(sv_2mortal(sv));
4222 * Initialise the decode mapping. By using a table driven
4223 * algorithm, the code will be character-set independent
4224 * (and just as fast as doing character arithmetic)
4226 if (PL_uudmap['M'] == 0) {
4229 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4230 PL_uudmap[(U8)PL_uuemap[i]] = i;
4232 * Because ' ' and '`' map to the same value,
4233 * we need to decode them both the same.
4238 along = (strend - s) * 3 / 4;
4239 sv = NEWSV(42, along);
4242 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4247 len = PL_uudmap[*(U8*)s++] & 077;
4249 if (s < strend && ISUUCHAR(*s))
4250 a = PL_uudmap[*(U8*)s++] & 077;
4253 if (s < strend && ISUUCHAR(*s))
4254 b = PL_uudmap[*(U8*)s++] & 077;
4257 if (s < strend && ISUUCHAR(*s))
4258 c = PL_uudmap[*(U8*)s++] & 077;
4261 if (s < strend && ISUUCHAR(*s))
4262 d = PL_uudmap[*(U8*)s++] & 077;
4265 hunk[0] = (a << 2) | (b >> 4);
4266 hunk[1] = (b << 4) | (c >> 2);
4267 hunk[2] = (c << 6) | d;
4268 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4273 else if (s[1] == '\n') /* possible checksum byte */
4276 XPUSHs(sv_2mortal(sv));
4281 if (strchr("fFdD", datumtype) ||
4282 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4286 while (checksum >= 16) {
4290 while (checksum >= 4) {
4296 along = (1 << checksum) - 1;
4297 while (cdouble < 0.0)
4299 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4300 sv_setnv(sv, cdouble);
4303 if (checksum < 32) {
4304 aulong = (1 << checksum) - 1;
4307 sv_setuv(sv, (UV)culong);
4309 XPUSHs(sv_2mortal(sv));
4313 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4314 PUSHs(&PL_sv_undef);
4319 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4323 *hunk = PL_uuemap[len];
4324 sv_catpvn(sv, hunk, 1);
4327 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4328 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4329 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4330 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4331 sv_catpvn(sv, hunk, 4);
4336 char r = (len > 1 ? s[1] : '\0');
4337 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4338 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4339 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4340 hunk[3] = PL_uuemap[0];
4341 sv_catpvn(sv, hunk, 4);
4343 sv_catpvn(sv, "\n", 1);
4347 S_is_an_int(pTHX_ char *s, STRLEN l)
4350 SV *result = newSVpvn(s, l);
4351 char *result_c = SvPV(result, n_a); /* convenience */
4352 char *out = result_c;
4362 SvREFCNT_dec(result);
4385 SvREFCNT_dec(result);
4391 SvCUR_set(result, out - result_c);
4395 /* pnum must be '\0' terminated */
4397 S_div128(pTHX_ SV *pnum, bool *done)
4400 char *s = SvPV(pnum, len);
4409 i = m * 10 + (*t - '0');
4411 r = (i >> 7); /* r < 10 */
4418 SvCUR_set(pnum, (STRLEN) (t - s));
4425 djSP; dMARK; dORIGMARK; dTARGET;
4426 register SV *cat = TARG;
4429 register char *pat = SvPVx(*++MARK, fromlen);
4431 register char *patend = pat + fromlen;
4436 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4437 static char *space10 = " ";
4439 /* These must not be in registers: */
4454 #ifdef PERL_NATINT_PACK
4455 int natint; /* native integer */
4460 sv_setpvn(cat, "", 0);
4462 while (pat < patend) {
4463 SV *lengthcode = Nullsv;
4464 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4465 datumtype = *pat++ & 0xFF;
4466 #ifdef PERL_NATINT_PACK
4469 if (isSPACE(datumtype)) {
4473 if (datumtype == 'U' && pat == patcopy+1)
4475 if (datumtype == '#') {
4476 while (pat < patend && *pat != '\n')
4481 char *natstr = "sSiIlL";
4483 if (strchr(natstr, datumtype)) {
4484 #ifdef PERL_NATINT_PACK
4490 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4493 len = strchr("@Xxu", datumtype) ? 0 : items;
4496 else if (isDIGIT(*pat)) {
4498 while (isDIGIT(*pat)) {
4499 len = (len * 10) + (*pat++ - '0');
4501 DIE(aTHX_ "Repeat count in pack overflows");
4508 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4509 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4510 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4511 ? *MARK : &PL_sv_no)
4512 + (*pat == 'Z' ? 1 : 0)));
4516 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4517 case ',': /* grandfather in commas but with a warning */
4518 if (commas++ == 0 && ckWARN(WARN_PACK))
4519 Perl_warner(aTHX_ WARN_PACK,
4520 "Invalid type in pack: '%c'", (int)datumtype);
4523 DIE(aTHX_ "%% may only be used in unpack");
4534 if (SvCUR(cat) < len)
4535 DIE(aTHX_ "X outside of string");
4542 sv_catpvn(cat, null10, 10);
4545 sv_catpvn(cat, null10, len);
4551 aptr = SvPV(fromstr, fromlen);
4552 if (pat[-1] == '*') {
4554 if (datumtype == 'Z')
4557 if (fromlen >= len) {
4558 sv_catpvn(cat, aptr, len);
4559 if (datumtype == 'Z')
4560 *(SvEND(cat)-1) = '\0';
4563 sv_catpvn(cat, aptr, fromlen);
4565 if (datumtype == 'A') {
4567 sv_catpvn(cat, space10, 10);
4570 sv_catpvn(cat, space10, len);
4574 sv_catpvn(cat, null10, 10);
4577 sv_catpvn(cat, null10, len);
4589 str = SvPV(fromstr, fromlen);
4593 SvCUR(cat) += (len+7)/8;
4594 SvGROW(cat, SvCUR(cat) + 1);
4595 aptr = SvPVX(cat) + aint;
4600 if (datumtype == 'B') {
4601 for (len = 0; len++ < aint;) {
4602 items |= *str++ & 1;
4606 *aptr++ = items & 0xff;
4612 for (len = 0; len++ < aint;) {
4618 *aptr++ = items & 0xff;
4624 if (datumtype == 'B')
4625 items <<= 7 - (aint & 7);
4627 items >>= 7 - (aint & 7);
4628 *aptr++ = items & 0xff;
4630 str = SvPVX(cat) + SvCUR(cat);
4645 str = SvPV(fromstr, fromlen);
4649 SvCUR(cat) += (len+1)/2;
4650 SvGROW(cat, SvCUR(cat) + 1);
4651 aptr = SvPVX(cat) + aint;
4656 if (datumtype == 'H') {
4657 for (len = 0; len++ < aint;) {
4659 items |= ((*str++ & 15) + 9) & 15;
4661 items |= *str++ & 15;
4665 *aptr++ = items & 0xff;
4671 for (len = 0; len++ < aint;) {
4673 items |= (((*str++ & 15) + 9) & 15) << 4;
4675 items |= (*str++ & 15) << 4;
4679 *aptr++ = items & 0xff;
4685 *aptr++ = items & 0xff;
4686 str = SvPVX(cat) + SvCUR(cat);
4697 aint = SvIV(fromstr);
4699 sv_catpvn(cat, &achar, sizeof(char));
4705 auint = SvUV(fromstr);
4706 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4707 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4712 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4717 afloat = (float)SvNV(fromstr);
4718 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4725 adouble = (double)SvNV(fromstr);
4726 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4732 ashort = (I16)SvIV(fromstr);
4734 ashort = PerlSock_htons(ashort);
4736 CAT16(cat, &ashort);
4742 ashort = (I16)SvIV(fromstr);
4744 ashort = htovs(ashort);
4746 CAT16(cat, &ashort);
4750 #if SHORTSIZE != SIZE16
4752 unsigned short aushort;
4756 aushort = SvUV(fromstr);
4757 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4767 aushort = (U16)SvUV(fromstr);
4768 CAT16(cat, &aushort);
4774 #if SHORTSIZE != SIZE16
4780 ashort = SvIV(fromstr);
4781 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4789 ashort = (I16)SvIV(fromstr);
4790 CAT16(cat, &ashort);
4797 auint = SvUV(fromstr);
4798 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4804 adouble = Perl_floor(SvNV(fromstr));
4807 DIE(aTHX_ "Cannot compress negative numbers");
4810 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4811 adouble <= 0xffffffff
4813 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4814 adouble <= UV_MAX_cxux
4821 char buf[1 + sizeof(UV)];
4822 char *in = buf + sizeof(buf);
4823 UV auv = U_V(adouble);
4826 *--in = (auv & 0x7f) | 0x80;
4829 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4830 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4832 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4833 char *from, *result, *in;
4838 /* Copy string and check for compliance */
4839 from = SvPV(fromstr, len);
4840 if ((norm = is_an_int(from, len)) == NULL)
4841 DIE(aTHX_ "can compress only unsigned integer");
4843 New('w', result, len, char);
4847 *--in = div128(norm, &done) | 0x80;
4848 result[len - 1] &= 0x7F; /* clear continue bit */
4849 sv_catpvn(cat, in, (result + len) - in);
4851 SvREFCNT_dec(norm); /* free norm */
4853 else if (SvNOKp(fromstr)) {
4854 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4855 char *in = buf + sizeof(buf);
4858 double next = floor(adouble / 128);
4859 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4860 if (in <= buf) /* this cannot happen ;-) */
4861 DIE(aTHX_ "Cannot compress integer");
4864 } while (adouble > 0);
4865 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4866 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4869 DIE(aTHX_ "Cannot compress non integer");
4875 aint = SvIV(fromstr);
4876 sv_catpvn(cat, (char*)&aint, sizeof(int));
4882 aulong = SvUV(fromstr);
4884 aulong = PerlSock_htonl(aulong);
4886 CAT32(cat, &aulong);
4892 aulong = SvUV(fromstr);
4894 aulong = htovl(aulong);
4896 CAT32(cat, &aulong);
4900 #if LONGSIZE != SIZE32
4902 unsigned long aulong;
4906 aulong = SvUV(fromstr);
4907 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4915 aulong = SvUV(fromstr);
4916 CAT32(cat, &aulong);
4921 #if LONGSIZE != SIZE32
4927 along = SvIV(fromstr);
4928 sv_catpvn(cat, (char *)&along, sizeof(long));
4936 along = SvIV(fromstr);
4945 auquad = (Uquad_t)SvUV(fromstr);
4946 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4952 aquad = (Quad_t)SvIV(fromstr);
4953 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4958 len = 1; /* assume SV is correct length */
4963 if (fromstr == &PL_sv_undef)
4967 /* XXX better yet, could spirit away the string to
4968 * a safe spot and hang on to it until the result
4969 * of pack() (and all copies of the result) are
4972 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4973 || (SvPADTMP(fromstr)
4974 && !SvREADONLY(fromstr))))
4976 Perl_warner(aTHX_ WARN_PACK,
4977 "Attempt to pack pointer to temporary value");
4979 if (SvPOK(fromstr) || SvNIOK(fromstr))
4980 aptr = SvPV(fromstr,n_a);
4982 aptr = SvPV_force(fromstr,n_a);
4984 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4989 aptr = SvPV(fromstr, fromlen);
4990 SvGROW(cat, fromlen * 4 / 3);
4995 while (fromlen > 0) {
5002 doencodes(cat, aptr, todo);
5021 register IV limit = POPi; /* note, negative is forever */
5023 bool doutf8 = DO_UTF8(sv);
5025 register char *s = SvPV(sv, len);
5026 char *strend = s + len;
5028 register REGEXP *rx;
5032 I32 maxiters = (strend - s) + 10;
5035 I32 origlimit = limit;
5038 AV *oldstack = PL_curstack;
5039 I32 gimme = GIMME_V;
5040 I32 oldsave = PL_savestack_ix;
5041 I32 make_mortal = 1;
5042 MAGIC *mg = (MAGIC *) NULL;
5045 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5050 DIE(aTHX_ "panic: do_split");
5051 rx = pm->op_pmregexp;
5053 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5054 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5056 if (pm->op_pmreplroot) {
5058 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5060 ary = GvAVn((GV*)pm->op_pmreplroot);
5063 else if (gimme != G_ARRAY)
5065 ary = (AV*)PL_curpad[0];
5067 ary = GvAVn(PL_defgv);
5068 #endif /* USE_THREADS */
5071 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5077 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5079 XPUSHs(SvTIED_obj((SV*)ary, mg));
5085 for (i = AvFILLp(ary); i >= 0; i--)
5086 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5088 /* temporarily switch stacks */
5089 SWITCHSTACK(PL_curstack, ary);
5093 base = SP - PL_stack_base;
5095 if (pm->op_pmflags & PMf_SKIPWHITE) {
5096 if (pm->op_pmflags & PMf_LOCALE) {
5097 while (isSPACE_LC(*s))
5105 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5106 SAVEINT(PL_multiline);
5107 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5111 limit = maxiters + 2;
5112 if (pm->op_pmflags & PMf_WHITE) {
5115 while (m < strend &&
5116 !((pm->op_pmflags & PMf_LOCALE)
5117 ? isSPACE_LC(*m) : isSPACE(*m)))
5122 dstr = NEWSV(30, m-s);
5123 sv_setpvn(dstr, s, m-s);
5127 (void)SvUTF8_on(dstr);
5131 while (s < strend &&
5132 ((pm->op_pmflags & PMf_LOCALE)
5133 ? isSPACE_LC(*s) : isSPACE(*s)))
5137 else if (strEQ("^", rx->precomp)) {
5140 for (m = s; m < strend && *m != '\n'; m++) ;
5144 dstr = NEWSV(30, m-s);
5145 sv_setpvn(dstr, s, m-s);
5149 (void)SvUTF8_on(dstr);
5154 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5155 && (rx->reganch & ROPT_CHECK_ALL)
5156 && !(rx->reganch & ROPT_ANCH)) {
5157 int tail = (rx->reganch & RE_INTUIT_TAIL);
5158 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5161 if (len == 1 && !tail) {
5163 char c = *SvPV(csv, n_a);
5166 for (m = s; m < strend && *m != c; m++) ;
5169 dstr = NEWSV(30, m-s);
5170 sv_setpvn(dstr, s, m-s);
5174 (void)SvUTF8_on(dstr);
5176 /* The rx->minlen is in characters but we want to step
5177 * s ahead by bytes. */
5178 s = m + (doutf8 ? SvCUR(csv) : len);
5183 while (s < strend && --limit &&
5184 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5185 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5188 dstr = NEWSV(31, m-s);
5189 sv_setpvn(dstr, s, m-s);
5193 (void)SvUTF8_on(dstr);
5195 /* The rx->minlen is in characters but we want to step
5196 * s ahead by bytes. */
5197 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5202 maxiters += (strend - s) * rx->nparens;
5203 while (s < strend && --limit
5204 /* && (!rx->check_substr
5205 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5207 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5208 1 /* minend */, sv, NULL, 0))
5210 TAINT_IF(RX_MATCH_TAINTED(rx));
5211 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5216 strend = s + (strend - m);
5218 m = rx->startp[0] + orig;
5219 dstr = NEWSV(32, m-s);
5220 sv_setpvn(dstr, s, m-s);
5224 (void)SvUTF8_on(dstr);
5227 for (i = 1; i <= rx->nparens; i++) {
5228 s = rx->startp[i] + orig;
5229 m = rx->endp[i] + orig;
5231 dstr = NEWSV(33, m-s);
5232 sv_setpvn(dstr, s, m-s);
5235 dstr = NEWSV(33, 0);
5239 (void)SvUTF8_on(dstr);
5243 s = rx->endp[0] + orig;
5247 LEAVE_SCOPE(oldsave);
5248 iters = (SP - PL_stack_base) - base;
5249 if (iters > maxiters)
5250 DIE(aTHX_ "Split loop");
5252 /* keep field after final delim? */
5253 if (s < strend || (iters && origlimit)) {
5254 STRLEN l = strend - s;
5255 dstr = NEWSV(34, l);
5256 sv_setpvn(dstr, s, l);
5260 (void)SvUTF8_on(dstr);
5264 else if (!origlimit) {
5265 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5271 SWITCHSTACK(ary, oldstack);
5272 if (SvSMAGICAL(ary)) {
5277 if (gimme == G_ARRAY) {
5279 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5287 call_method("PUSH",G_SCALAR|G_DISCARD);
5290 if (gimme == G_ARRAY) {
5291 /* EXTEND should not be needed - we just popped them */
5293 for (i=0; i < iters; i++) {
5294 SV **svp = av_fetch(ary, i, FALSE);
5295 PUSHs((svp) ? *svp : &PL_sv_undef);
5302 if (gimme == G_ARRAY)
5305 if (iters || !pm->op_pmreplroot) {
5315 Perl_unlock_condpair(pTHX_ void *svv)
5318 MAGIC *mg = mg_find((SV*)svv, 'm');
5321 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5322 MUTEX_LOCK(MgMUTEXP(mg));
5323 if (MgOWNER(mg) != thr)
5324 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5326 COND_SIGNAL(MgOWNERCONDP(mg));
5327 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5328 PTR2UV(thr), PTR2UV(svv));)
5329 MUTEX_UNLOCK(MgMUTEXP(mg));
5331 #endif /* USE_THREADS */
5340 #endif /* USE_THREADS */
5341 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5342 || SvTYPE(retsv) == SVt_PVCV) {
5343 retsv = refto(retsv);
5354 if (PL_op->op_private & OPpLVAL_INTRO)
5355 PUSHs(*save_threadsv(PL_op->op_targ));
5357 PUSHs(THREADSV(PL_op->op_targ));
5360 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5361 #endif /* USE_THREADS */