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_chk(tmps, 0, &l, UTF8_ALLOW_ANY);
1488 tmps += UTF8SKIP(tmps);
1489 targlen += UNISKIP(~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_chk(tmps, 0, &l, UTF8_ALLOW_ANY);
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) {
3663 auint = utf8_to_uv_chk((U8*)s, strend - s, &alen, 0);
3667 cdouble += (NV)auint;
3675 while (len-- > 0 && s < strend) {
3677 auint = utf8_to_uv_chk((U8*)s, strend - s, &alen, 0);
3681 sv_setuv(sv, (UV)auint);
3682 PUSHs(sv_2mortal(sv));
3687 #if SHORTSIZE == SIZE16
3688 along = (strend - s) / SIZE16;
3690 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3695 #if SHORTSIZE != SIZE16
3699 COPYNN(s, &ashort, sizeof(short));
3710 #if SHORTSIZE > SIZE16
3722 #if SHORTSIZE != SIZE16
3726 COPYNN(s, &ashort, sizeof(short));
3729 sv_setiv(sv, (IV)ashort);
3730 PUSHs(sv_2mortal(sv));
3738 #if SHORTSIZE > SIZE16
3744 sv_setiv(sv, (IV)ashort);
3745 PUSHs(sv_2mortal(sv));
3753 #if SHORTSIZE == SIZE16
3754 along = (strend - s) / SIZE16;
3756 unatint = natint && datumtype == 'S';
3757 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3762 #if SHORTSIZE != SIZE16
3764 unsigned short aushort;
3766 COPYNN(s, &aushort, sizeof(unsigned short));
3767 s += sizeof(unsigned short);
3775 COPY16(s, &aushort);
3778 if (datumtype == 'n')
3779 aushort = PerlSock_ntohs(aushort);
3782 if (datumtype == 'v')
3783 aushort = vtohs(aushort);
3792 #if SHORTSIZE != SIZE16
3794 unsigned short aushort;
3796 COPYNN(s, &aushort, sizeof(unsigned short));
3797 s += sizeof(unsigned short);
3799 sv_setiv(sv, (UV)aushort);
3800 PUSHs(sv_2mortal(sv));
3807 COPY16(s, &aushort);
3811 if (datumtype == 'n')
3812 aushort = PerlSock_ntohs(aushort);
3815 if (datumtype == 'v')
3816 aushort = vtohs(aushort);
3818 sv_setiv(sv, (UV)aushort);
3819 PUSHs(sv_2mortal(sv));
3825 along = (strend - s) / sizeof(int);
3830 Copy(s, &aint, 1, int);
3833 cdouble += (NV)aint;
3842 Copy(s, &aint, 1, int);
3846 /* Without the dummy below unpack("i", pack("i",-1))
3847 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3848 * cc with optimization turned on.
3850 * The bug was detected in
3851 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3852 * with optimization (-O4) turned on.
3853 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3854 * does not have this problem even with -O4.
3856 * This bug was reported as DECC_BUGS 1431
3857 * and tracked internally as GEM_BUGS 7775.
3859 * The bug is fixed in
3860 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3861 * UNIX V4.0F support: DEC C V5.9-006 or later
3862 * UNIX V4.0E support: DEC C V5.8-011 or later
3865 * See also few lines later for the same bug.
3868 sv_setiv(sv, (IV)aint) :
3870 sv_setiv(sv, (IV)aint);
3871 PUSHs(sv_2mortal(sv));
3876 along = (strend - s) / sizeof(unsigned int);
3881 Copy(s, &auint, 1, unsigned int);
3882 s += sizeof(unsigned int);
3884 cdouble += (NV)auint;
3893 Copy(s, &auint, 1, unsigned int);
3894 s += sizeof(unsigned int);
3897 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3898 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3899 * See details few lines earlier. */
3901 sv_setuv(sv, (UV)auint) :
3903 sv_setuv(sv, (UV)auint);
3904 PUSHs(sv_2mortal(sv));
3909 #if LONGSIZE == SIZE32
3910 along = (strend - s) / SIZE32;
3912 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3917 #if LONGSIZE != SIZE32
3921 COPYNN(s, &along, sizeof(long));
3924 cdouble += (NV)along;
3934 #if LONGSIZE > SIZE32
3935 if (along > 2147483647)
3936 along -= 4294967296;
3940 cdouble += (NV)along;
3949 #if LONGSIZE != SIZE32
3953 COPYNN(s, &along, sizeof(long));
3956 sv_setiv(sv, (IV)along);
3957 PUSHs(sv_2mortal(sv));
3965 #if LONGSIZE > SIZE32
3966 if (along > 2147483647)
3967 along -= 4294967296;
3971 sv_setiv(sv, (IV)along);
3972 PUSHs(sv_2mortal(sv));
3980 #if LONGSIZE == SIZE32
3981 along = (strend - s) / SIZE32;
3983 unatint = natint && datumtype == 'L';
3984 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3989 #if LONGSIZE != SIZE32
3991 unsigned long aulong;
3993 COPYNN(s, &aulong, sizeof(unsigned long));
3994 s += sizeof(unsigned long);
3996 cdouble += (NV)aulong;
4008 if (datumtype == 'N')
4009 aulong = PerlSock_ntohl(aulong);
4012 if (datumtype == 'V')
4013 aulong = vtohl(aulong);
4016 cdouble += (NV)aulong;
4025 #if LONGSIZE != SIZE32
4027 unsigned long aulong;
4029 COPYNN(s, &aulong, sizeof(unsigned long));
4030 s += sizeof(unsigned long);
4032 sv_setuv(sv, (UV)aulong);
4033 PUSHs(sv_2mortal(sv));
4043 if (datumtype == 'N')
4044 aulong = PerlSock_ntohl(aulong);
4047 if (datumtype == 'V')
4048 aulong = vtohl(aulong);
4051 sv_setuv(sv, (UV)aulong);
4052 PUSHs(sv_2mortal(sv));
4058 along = (strend - s) / sizeof(char*);
4064 if (sizeof(char*) > strend - s)
4067 Copy(s, &aptr, 1, char*);
4073 PUSHs(sv_2mortal(sv));
4083 while ((len > 0) && (s < strend)) {
4084 auv = (auv << 7) | (*s & 0x7f);
4085 if (!(*s++ & 0x80)) {
4089 PUSHs(sv_2mortal(sv));
4093 else if (++bytes >= sizeof(UV)) { /* promote to string */
4097 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4098 while (s < strend) {
4099 sv = mul128(sv, *s & 0x7f);
4100 if (!(*s++ & 0x80)) {
4109 PUSHs(sv_2mortal(sv));
4114 if ((s >= strend) && bytes)
4115 DIE(aTHX_ "Unterminated compressed integer");
4120 if (sizeof(char*) > strend - s)
4123 Copy(s, &aptr, 1, char*);
4128 sv_setpvn(sv, aptr, len);
4129 PUSHs(sv_2mortal(sv));
4133 along = (strend - s) / sizeof(Quad_t);
4139 if (s + sizeof(Quad_t) > strend)
4142 Copy(s, &aquad, 1, Quad_t);
4143 s += sizeof(Quad_t);
4146 if (aquad >= IV_MIN && aquad <= IV_MAX)
4147 sv_setiv(sv, (IV)aquad);
4149 sv_setnv(sv, (NV)aquad);
4150 PUSHs(sv_2mortal(sv));
4154 along = (strend - s) / sizeof(Quad_t);
4160 if (s + sizeof(Uquad_t) > strend)
4163 Copy(s, &auquad, 1, Uquad_t);
4164 s += sizeof(Uquad_t);
4167 if (auquad <= UV_MAX)
4168 sv_setuv(sv, (UV)auquad);
4170 sv_setnv(sv, (NV)auquad);
4171 PUSHs(sv_2mortal(sv));
4175 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4178 along = (strend - s) / sizeof(float);
4183 Copy(s, &afloat, 1, float);
4192 Copy(s, &afloat, 1, float);
4195 sv_setnv(sv, (NV)afloat);
4196 PUSHs(sv_2mortal(sv));
4202 along = (strend - s) / sizeof(double);
4207 Copy(s, &adouble, 1, double);
4208 s += sizeof(double);
4216 Copy(s, &adouble, 1, double);
4217 s += sizeof(double);
4219 sv_setnv(sv, (NV)adouble);
4220 PUSHs(sv_2mortal(sv));
4226 * Initialise the decode mapping. By using a table driven
4227 * algorithm, the code will be character-set independent
4228 * (and just as fast as doing character arithmetic)
4230 if (PL_uudmap['M'] == 0) {
4233 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4234 PL_uudmap[(U8)PL_uuemap[i]] = i;
4236 * Because ' ' and '`' map to the same value,
4237 * we need to decode them both the same.
4242 along = (strend - s) * 3 / 4;
4243 sv = NEWSV(42, along);
4246 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4251 len = PL_uudmap[*(U8*)s++] & 077;
4253 if (s < strend && ISUUCHAR(*s))
4254 a = PL_uudmap[*(U8*)s++] & 077;
4257 if (s < strend && ISUUCHAR(*s))
4258 b = PL_uudmap[*(U8*)s++] & 077;
4261 if (s < strend && ISUUCHAR(*s))
4262 c = PL_uudmap[*(U8*)s++] & 077;
4265 if (s < strend && ISUUCHAR(*s))
4266 d = PL_uudmap[*(U8*)s++] & 077;
4269 hunk[0] = (a << 2) | (b >> 4);
4270 hunk[1] = (b << 4) | (c >> 2);
4271 hunk[2] = (c << 6) | d;
4272 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4277 else if (s[1] == '\n') /* possible checksum byte */
4280 XPUSHs(sv_2mortal(sv));
4285 if (strchr("fFdD", datumtype) ||
4286 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4290 while (checksum >= 16) {
4294 while (checksum >= 4) {
4300 along = (1 << checksum) - 1;
4301 while (cdouble < 0.0)
4303 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4304 sv_setnv(sv, cdouble);
4307 if (checksum < 32) {
4308 aulong = (1 << checksum) - 1;
4311 sv_setuv(sv, (UV)culong);
4313 XPUSHs(sv_2mortal(sv));
4317 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4318 PUSHs(&PL_sv_undef);
4323 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4327 *hunk = PL_uuemap[len];
4328 sv_catpvn(sv, hunk, 1);
4331 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4332 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4333 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4334 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4335 sv_catpvn(sv, hunk, 4);
4340 char r = (len > 1 ? s[1] : '\0');
4341 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4342 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4343 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4344 hunk[3] = PL_uuemap[0];
4345 sv_catpvn(sv, hunk, 4);
4347 sv_catpvn(sv, "\n", 1);
4351 S_is_an_int(pTHX_ char *s, STRLEN l)
4354 SV *result = newSVpvn(s, l);
4355 char *result_c = SvPV(result, n_a); /* convenience */
4356 char *out = result_c;
4366 SvREFCNT_dec(result);
4389 SvREFCNT_dec(result);
4395 SvCUR_set(result, out - result_c);
4399 /* pnum must be '\0' terminated */
4401 S_div128(pTHX_ SV *pnum, bool *done)
4404 char *s = SvPV(pnum, len);
4413 i = m * 10 + (*t - '0');
4415 r = (i >> 7); /* r < 10 */
4422 SvCUR_set(pnum, (STRLEN) (t - s));
4429 djSP; dMARK; dORIGMARK; dTARGET;
4430 register SV *cat = TARG;
4433 register char *pat = SvPVx(*++MARK, fromlen);
4435 register char *patend = pat + fromlen;
4440 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4441 static char *space10 = " ";
4443 /* These must not be in registers: */
4458 #ifdef PERL_NATINT_PACK
4459 int natint; /* native integer */
4464 sv_setpvn(cat, "", 0);
4466 while (pat < patend) {
4467 SV *lengthcode = Nullsv;
4468 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4469 datumtype = *pat++ & 0xFF;
4470 #ifdef PERL_NATINT_PACK
4473 if (isSPACE(datumtype)) {
4477 if (datumtype == 'U' && pat == patcopy+1)
4479 if (datumtype == '#') {
4480 while (pat < patend && *pat != '\n')
4485 char *natstr = "sSiIlL";
4487 if (strchr(natstr, datumtype)) {
4488 #ifdef PERL_NATINT_PACK
4494 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4497 len = strchr("@Xxu", datumtype) ? 0 : items;
4500 else if (isDIGIT(*pat)) {
4502 while (isDIGIT(*pat)) {
4503 len = (len * 10) + (*pat++ - '0');
4505 DIE(aTHX_ "Repeat count in pack overflows");
4512 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4513 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4514 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4515 ? *MARK : &PL_sv_no)
4516 + (*pat == 'Z' ? 1 : 0)));
4520 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4521 case ',': /* grandfather in commas but with a warning */
4522 if (commas++ == 0 && ckWARN(WARN_PACK))
4523 Perl_warner(aTHX_ WARN_PACK,
4524 "Invalid type in pack: '%c'", (int)datumtype);
4527 DIE(aTHX_ "%% may only be used in unpack");
4538 if (SvCUR(cat) < len)
4539 DIE(aTHX_ "X outside of string");
4546 sv_catpvn(cat, null10, 10);
4549 sv_catpvn(cat, null10, len);
4555 aptr = SvPV(fromstr, fromlen);
4556 if (pat[-1] == '*') {
4558 if (datumtype == 'Z')
4561 if (fromlen >= len) {
4562 sv_catpvn(cat, aptr, len);
4563 if (datumtype == 'Z')
4564 *(SvEND(cat)-1) = '\0';
4567 sv_catpvn(cat, aptr, fromlen);
4569 if (datumtype == 'A') {
4571 sv_catpvn(cat, space10, 10);
4574 sv_catpvn(cat, space10, len);
4578 sv_catpvn(cat, null10, 10);
4581 sv_catpvn(cat, null10, len);
4593 str = SvPV(fromstr, fromlen);
4597 SvCUR(cat) += (len+7)/8;
4598 SvGROW(cat, SvCUR(cat) + 1);
4599 aptr = SvPVX(cat) + aint;
4604 if (datumtype == 'B') {
4605 for (len = 0; len++ < aint;) {
4606 items |= *str++ & 1;
4610 *aptr++ = items & 0xff;
4616 for (len = 0; len++ < aint;) {
4622 *aptr++ = items & 0xff;
4628 if (datumtype == 'B')
4629 items <<= 7 - (aint & 7);
4631 items >>= 7 - (aint & 7);
4632 *aptr++ = items & 0xff;
4634 str = SvPVX(cat) + SvCUR(cat);
4649 str = SvPV(fromstr, fromlen);
4653 SvCUR(cat) += (len+1)/2;
4654 SvGROW(cat, SvCUR(cat) + 1);
4655 aptr = SvPVX(cat) + aint;
4660 if (datumtype == 'H') {
4661 for (len = 0; len++ < aint;) {
4663 items |= ((*str++ & 15) + 9) & 15;
4665 items |= *str++ & 15;
4669 *aptr++ = items & 0xff;
4675 for (len = 0; len++ < aint;) {
4677 items |= (((*str++ & 15) + 9) & 15) << 4;
4679 items |= (*str++ & 15) << 4;
4683 *aptr++ = items & 0xff;
4689 *aptr++ = items & 0xff;
4690 str = SvPVX(cat) + SvCUR(cat);
4701 aint = SvIV(fromstr);
4703 sv_catpvn(cat, &achar, sizeof(char));
4709 auint = SvUV(fromstr);
4710 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4711 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4716 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4721 afloat = (float)SvNV(fromstr);
4722 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4729 adouble = (double)SvNV(fromstr);
4730 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4736 ashort = (I16)SvIV(fromstr);
4738 ashort = PerlSock_htons(ashort);
4740 CAT16(cat, &ashort);
4746 ashort = (I16)SvIV(fromstr);
4748 ashort = htovs(ashort);
4750 CAT16(cat, &ashort);
4754 #if SHORTSIZE != SIZE16
4756 unsigned short aushort;
4760 aushort = SvUV(fromstr);
4761 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4771 aushort = (U16)SvUV(fromstr);
4772 CAT16(cat, &aushort);
4778 #if SHORTSIZE != SIZE16
4784 ashort = SvIV(fromstr);
4785 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4793 ashort = (I16)SvIV(fromstr);
4794 CAT16(cat, &ashort);
4801 auint = SvUV(fromstr);
4802 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4808 adouble = Perl_floor(SvNV(fromstr));
4811 DIE(aTHX_ "Cannot compress negative numbers");
4814 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4815 adouble <= 0xffffffff
4817 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4818 adouble <= UV_MAX_cxux
4825 char buf[1 + sizeof(UV)];
4826 char *in = buf + sizeof(buf);
4827 UV auv = U_V(adouble);
4830 *--in = (auv & 0x7f) | 0x80;
4833 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4834 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4836 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4837 char *from, *result, *in;
4842 /* Copy string and check for compliance */
4843 from = SvPV(fromstr, len);
4844 if ((norm = is_an_int(from, len)) == NULL)
4845 DIE(aTHX_ "can compress only unsigned integer");
4847 New('w', result, len, char);
4851 *--in = div128(norm, &done) | 0x80;
4852 result[len - 1] &= 0x7F; /* clear continue bit */
4853 sv_catpvn(cat, in, (result + len) - in);
4855 SvREFCNT_dec(norm); /* free norm */
4857 else if (SvNOKp(fromstr)) {
4858 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4859 char *in = buf + sizeof(buf);
4862 double next = floor(adouble / 128);
4863 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4864 if (in <= buf) /* this cannot happen ;-) */
4865 DIE(aTHX_ "Cannot compress integer");
4868 } while (adouble > 0);
4869 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4870 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4873 DIE(aTHX_ "Cannot compress non integer");
4879 aint = SvIV(fromstr);
4880 sv_catpvn(cat, (char*)&aint, sizeof(int));
4886 aulong = SvUV(fromstr);
4888 aulong = PerlSock_htonl(aulong);
4890 CAT32(cat, &aulong);
4896 aulong = SvUV(fromstr);
4898 aulong = htovl(aulong);
4900 CAT32(cat, &aulong);
4904 #if LONGSIZE != SIZE32
4906 unsigned long aulong;
4910 aulong = SvUV(fromstr);
4911 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4919 aulong = SvUV(fromstr);
4920 CAT32(cat, &aulong);
4925 #if LONGSIZE != SIZE32
4931 along = SvIV(fromstr);
4932 sv_catpvn(cat, (char *)&along, sizeof(long));
4940 along = SvIV(fromstr);
4949 auquad = (Uquad_t)SvUV(fromstr);
4950 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4956 aquad = (Quad_t)SvIV(fromstr);
4957 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4962 len = 1; /* assume SV is correct length */
4967 if (fromstr == &PL_sv_undef)
4971 /* XXX better yet, could spirit away the string to
4972 * a safe spot and hang on to it until the result
4973 * of pack() (and all copies of the result) are
4976 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4977 || (SvPADTMP(fromstr)
4978 && !SvREADONLY(fromstr))))
4980 Perl_warner(aTHX_ WARN_PACK,
4981 "Attempt to pack pointer to temporary value");
4983 if (SvPOK(fromstr) || SvNIOK(fromstr))
4984 aptr = SvPV(fromstr,n_a);
4986 aptr = SvPV_force(fromstr,n_a);
4988 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4993 aptr = SvPV(fromstr, fromlen);
4994 SvGROW(cat, fromlen * 4 / 3);
4999 while (fromlen > 0) {
5006 doencodes(cat, aptr, todo);
5025 register IV limit = POPi; /* note, negative is forever */
5027 bool doutf8 = DO_UTF8(sv);
5029 register char *s = SvPV(sv, len);
5030 char *strend = s + len;
5032 register REGEXP *rx;
5036 I32 maxiters = (strend - s) + 10;
5039 I32 origlimit = limit;
5042 AV *oldstack = PL_curstack;
5043 I32 gimme = GIMME_V;
5044 I32 oldsave = PL_savestack_ix;
5045 I32 make_mortal = 1;
5046 MAGIC *mg = (MAGIC *) NULL;
5049 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5054 DIE(aTHX_ "panic: do_split");
5055 rx = pm->op_pmregexp;
5057 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5058 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5060 if (pm->op_pmreplroot) {
5062 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5064 ary = GvAVn((GV*)pm->op_pmreplroot);
5067 else if (gimme != G_ARRAY)
5069 ary = (AV*)PL_curpad[0];
5071 ary = GvAVn(PL_defgv);
5072 #endif /* USE_THREADS */
5075 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5081 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5083 XPUSHs(SvTIED_obj((SV*)ary, mg));
5089 for (i = AvFILLp(ary); i >= 0; i--)
5090 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5092 /* temporarily switch stacks */
5093 SWITCHSTACK(PL_curstack, ary);
5097 base = SP - PL_stack_base;
5099 if (pm->op_pmflags & PMf_SKIPWHITE) {
5100 if (pm->op_pmflags & PMf_LOCALE) {
5101 while (isSPACE_LC(*s))
5109 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5110 SAVEINT(PL_multiline);
5111 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5115 limit = maxiters + 2;
5116 if (pm->op_pmflags & PMf_WHITE) {
5119 while (m < strend &&
5120 !((pm->op_pmflags & PMf_LOCALE)
5121 ? isSPACE_LC(*m) : isSPACE(*m)))
5126 dstr = NEWSV(30, m-s);
5127 sv_setpvn(dstr, s, m-s);
5131 (void)SvUTF8_on(dstr);
5135 while (s < strend &&
5136 ((pm->op_pmflags & PMf_LOCALE)
5137 ? isSPACE_LC(*s) : isSPACE(*s)))
5141 else if (strEQ("^", rx->precomp)) {
5144 for (m = s; m < strend && *m != '\n'; m++) ;
5148 dstr = NEWSV(30, m-s);
5149 sv_setpvn(dstr, s, m-s);
5153 (void)SvUTF8_on(dstr);
5158 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5159 && (rx->reganch & ROPT_CHECK_ALL)
5160 && !(rx->reganch & ROPT_ANCH)) {
5161 int tail = (rx->reganch & RE_INTUIT_TAIL);
5162 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5165 if (len == 1 && !tail) {
5167 char c = *SvPV(csv, n_a);
5170 for (m = s; m < strend && *m != c; m++) ;
5173 dstr = NEWSV(30, m-s);
5174 sv_setpvn(dstr, s, m-s);
5178 (void)SvUTF8_on(dstr);
5180 /* The rx->minlen is in characters but we want to step
5181 * s ahead by bytes. */
5182 s = m + (doutf8 ? SvCUR(csv) : len);
5187 while (s < strend && --limit &&
5188 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5189 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5192 dstr = NEWSV(31, m-s);
5193 sv_setpvn(dstr, s, m-s);
5197 (void)SvUTF8_on(dstr);
5199 /* The rx->minlen is in characters but we want to step
5200 * s ahead by bytes. */
5201 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5206 maxiters += (strend - s) * rx->nparens;
5207 while (s < strend && --limit
5208 /* && (!rx->check_substr
5209 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5211 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5212 1 /* minend */, sv, NULL, 0))
5214 TAINT_IF(RX_MATCH_TAINTED(rx));
5215 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5220 strend = s + (strend - m);
5222 m = rx->startp[0] + orig;
5223 dstr = NEWSV(32, m-s);
5224 sv_setpvn(dstr, s, m-s);
5228 (void)SvUTF8_on(dstr);
5231 for (i = 1; i <= rx->nparens; i++) {
5232 s = rx->startp[i] + orig;
5233 m = rx->endp[i] + orig;
5235 dstr = NEWSV(33, m-s);
5236 sv_setpvn(dstr, s, m-s);
5239 dstr = NEWSV(33, 0);
5243 (void)SvUTF8_on(dstr);
5247 s = rx->endp[0] + orig;
5251 LEAVE_SCOPE(oldsave);
5252 iters = (SP - PL_stack_base) - base;
5253 if (iters > maxiters)
5254 DIE(aTHX_ "Split loop");
5256 /* keep field after final delim? */
5257 if (s < strend || (iters && origlimit)) {
5258 STRLEN l = strend - s;
5259 dstr = NEWSV(34, l);
5260 sv_setpvn(dstr, s, l);
5264 (void)SvUTF8_on(dstr);
5268 else if (!origlimit) {
5269 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5275 SWITCHSTACK(ary, oldstack);
5276 if (SvSMAGICAL(ary)) {
5281 if (gimme == G_ARRAY) {
5283 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5291 call_method("PUSH",G_SCALAR|G_DISCARD);
5294 if (gimme == G_ARRAY) {
5295 /* EXTEND should not be needed - we just popped them */
5297 for (i=0; i < iters; i++) {
5298 SV **svp = av_fetch(ary, i, FALSE);
5299 PUSHs((svp) ? *svp : &PL_sv_undef);
5306 if (gimme == G_ARRAY)
5309 if (iters || !pm->op_pmreplroot) {
5319 Perl_unlock_condpair(pTHX_ void *svv)
5322 MAGIC *mg = mg_find((SV*)svv, 'm');
5325 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5326 MUTEX_LOCK(MgMUTEXP(mg));
5327 if (MgOWNER(mg) != thr)
5328 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5330 COND_SIGNAL(MgOWNERCONDP(mg));
5331 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5332 PTR2UV(thr), PTR2UV(svv));)
5333 MUTEX_UNLOCK(MgMUTEXP(mg));
5335 #endif /* USE_THREADS */
5344 #endif /* USE_THREADS */
5345 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5346 || SvTYPE(retsv) == SVt_PVCV) {
5347 retsv = refto(retsv);
5358 if (PL_op->op_private & OPpLVAL_INTRO)
5359 PUSHs(*save_threadsv(PL_op->op_targ));
5361 PUSHs(THREADSV(PL_op->op_targ));
5364 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5365 #endif /* USE_THREADS */