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 */
85 /* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
89 #ifdef NEED_GETPID_PROTO
90 extern Pid_t getpid (void);
96 if (GIMME_V == G_SCALAR)
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
114 if (PL_op->op_flags & OPf_REF) {
118 if (GIMME == G_ARRAY) {
119 I32 maxarg = AvFILL((AV*)TARG) + 1;
121 if (SvMAGICAL(TARG)) {
123 for (i=0; i < maxarg; i++) {
124 SV **svp = av_fetch((AV*)TARG, i, FALSE);
125 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
129 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
134 SV* sv = sv_newmortal();
135 I32 maxarg = AvFILL((AV*)TARG) + 1;
136 sv_setiv(sv, maxarg);
148 if (PL_op->op_private & OPpLVAL_INTRO)
149 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
150 if (PL_op->op_flags & OPf_REF)
153 if (gimme == G_ARRAY) {
156 else if (gimme == G_SCALAR) {
157 SV* sv = sv_newmortal();
158 if (HvFILL((HV*)TARG))
159 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
160 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
170 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
181 tryAMAGICunDEREF(to_gv);
184 if (SvTYPE(sv) == SVt_PVIO) {
185 GV *gv = (GV*) sv_newmortal();
186 gv_init(gv, 0, "", 0, 0);
187 GvIOp(gv) = (IO *)sv;
188 (void)SvREFCNT_inc(sv);
191 else if (SvTYPE(sv) != SVt_PVGV)
192 DIE(aTHX_ "Not a GLOB reference");
195 if (SvTYPE(sv) != SVt_PVGV) {
199 if (SvGMAGICAL(sv)) {
204 if (!SvOK(sv) && sv != &PL_sv_undef) {
205 /* If this is a 'my' scalar and flag is set then vivify
208 if (PL_op->op_private & OPpDEREF) {
211 if (cUNOP->op_targ) {
213 SV *namesv = PL_curpad[cUNOP->op_targ];
214 name = SvPV(namesv, len);
215 gv = (GV*)NEWSV(0,0);
216 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
219 name = CopSTASHPV(PL_curcop);
222 if (SvTYPE(sv) < SVt_RV)
223 sv_upgrade(sv, SVt_RV);
229 if (PL_op->op_flags & OPf_REF ||
230 PL_op->op_private & HINT_STRICT_REFS)
231 DIE(aTHX_ PL_no_usym, "a symbol");
232 if (ckWARN(WARN_UNINITIALIZED))
237 if ((PL_op->op_flags & OPf_SPECIAL) &&
238 !(PL_op->op_flags & OPf_MOD))
240 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
242 && (!is_gv_magical(sym,len,0)
243 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
249 if (PL_op->op_private & HINT_STRICT_REFS)
250 DIE(aTHX_ PL_no_symref, sym, "a symbol");
251 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
255 if (PL_op->op_private & OPpLVAL_INTRO)
256 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
267 tryAMAGICunDEREF(to_sv);
270 switch (SvTYPE(sv)) {
274 DIE(aTHX_ "Not a SCALAR reference");
282 if (SvTYPE(gv) != SVt_PVGV) {
283 if (SvGMAGICAL(sv)) {
289 if (PL_op->op_flags & OPf_REF ||
290 PL_op->op_private & HINT_STRICT_REFS)
291 DIE(aTHX_ PL_no_usym, "a SCALAR");
292 if (ckWARN(WARN_UNINITIALIZED))
297 if ((PL_op->op_flags & OPf_SPECIAL) &&
298 !(PL_op->op_flags & OPf_MOD))
300 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
302 && (!is_gv_magical(sym,len,0)
303 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
309 if (PL_op->op_private & HINT_STRICT_REFS)
310 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
311 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
316 if (PL_op->op_flags & OPf_MOD) {
317 if (PL_op->op_private & OPpLVAL_INTRO)
318 sv = save_scalar((GV*)TOPs);
319 else if (PL_op->op_private & OPpDEREF)
320 vivify_ref(sv, PL_op->op_private & OPpDEREF);
330 SV *sv = AvARYLEN(av);
332 AvARYLEN(av) = sv = NEWSV(0,0);
333 sv_upgrade(sv, SVt_IV);
334 sv_magic(sv, (SV*)av, '#', Nullch, 0);
342 djSP; dTARGET; dPOPss;
344 if (PL_op->op_flags & OPf_MOD) {
345 if (SvTYPE(TARG) < SVt_PVLV) {
346 sv_upgrade(TARG, SVt_PVLV);
347 sv_magic(TARG, Nullsv, '.', Nullch, 0);
351 if (LvTARG(TARG) != sv) {
353 SvREFCNT_dec(LvTARG(TARG));
354 LvTARG(TARG) = SvREFCNT_inc(sv);
356 PUSHs(TARG); /* no SvSETMAGIC */
362 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
363 mg = mg_find(sv, 'g');
364 if (mg && mg->mg_len >= 0) {
368 PUSHi(i + PL_curcop->cop_arybase);
382 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
383 /* (But not in defined().) */
384 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
387 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
388 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
389 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
392 cv = (CV*)&PL_sv_undef;
406 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
407 char *s = SvPVX(TOPs);
408 if (strnEQ(s, "CORE::", 6)) {
411 code = keyword(s + 6, SvCUR(TOPs) - 6);
412 if (code < 0) { /* Overridable. */
413 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
414 int i = 0, n = 0, seen_question = 0;
416 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
418 while (i < MAXO) { /* The slow way. */
419 if (strEQ(s + 6, PL_op_name[i])
420 || strEQ(s + 6, PL_op_desc[i]))
426 goto nonesuch; /* Should not happen... */
428 oa = PL_opargs[i] >> OASHIFT;
430 if (oa & OA_OPTIONAL) {
434 else if (n && str[0] == ';' && seen_question)
435 goto set; /* XXXX system, exec */
436 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
437 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
440 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
441 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
445 ret = sv_2mortal(newSVpvn(str, n - 1));
447 else if (code) /* Non-Overridable */
449 else { /* None such */
451 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
455 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
457 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
466 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
468 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
484 if (GIMME != G_ARRAY) {
488 *MARK = &PL_sv_undef;
489 *MARK = refto(*MARK);
493 EXTEND_MORTAL(SP - MARK);
495 *MARK = refto(*MARK);
500 S_refto(pTHX_ SV *sv)
504 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
507 if (!(sv = LvTARG(sv)))
510 (void)SvREFCNT_inc(sv);
512 else if (SvTYPE(sv) == SVt_PVAV) {
513 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
516 (void)SvREFCNT_inc(sv);
518 else if (SvPADTMP(sv))
522 (void)SvREFCNT_inc(sv);
525 sv_upgrade(rv, SVt_RV);
539 if (sv && SvGMAGICAL(sv))
542 if (!sv || !SvROK(sv))
546 pv = sv_reftype(sv,TRUE);
547 PUSHp(pv, strlen(pv));
557 stash = CopSTASH(PL_curcop);
563 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
564 Perl_croak(aTHX_ "Attempt to bless into a reference");
566 if (ckWARN(WARN_MISC) && len == 0)
567 Perl_warner(aTHX_ WARN_MISC,
568 "Explicit blessing to '' (assuming package main)");
569 stash = gv_stashpvn(ptr, len, TRUE);
572 (void)sv_bless(TOPs, stash);
586 elem = SvPV(sv, n_a);
590 switch (elem ? *elem : '\0')
593 if (strEQ(elem, "ARRAY"))
594 tmpRef = (SV*)GvAV(gv);
597 if (strEQ(elem, "CODE"))
598 tmpRef = (SV*)GvCVu(gv);
601 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
602 tmpRef = (SV*)GvIOp(gv);
604 if (strEQ(elem, "FORMAT"))
605 tmpRef = (SV*)GvFORM(gv);
608 if (strEQ(elem, "GLOB"))
612 if (strEQ(elem, "HASH"))
613 tmpRef = (SV*)GvHV(gv);
616 if (strEQ(elem, "IO"))
617 tmpRef = (SV*)GvIOp(gv);
620 if (strEQ(elem, "NAME"))
621 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
624 if (strEQ(elem, "PACKAGE"))
625 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
628 if (strEQ(elem, "SCALAR"))
642 /* Pattern matching */
647 register unsigned char *s;
650 register I32 *sfirst;
654 if (sv == PL_lastscream) {
660 SvSCREAM_off(PL_lastscream);
661 SvREFCNT_dec(PL_lastscream);
663 PL_lastscream = SvREFCNT_inc(sv);
666 s = (unsigned char*)(SvPV(sv, len));
670 if (pos > PL_maxscream) {
671 if (PL_maxscream < 0) {
672 PL_maxscream = pos + 80;
673 New(301, PL_screamfirst, 256, I32);
674 New(302, PL_screamnext, PL_maxscream, I32);
677 PL_maxscream = pos + pos / 4;
678 Renew(PL_screamnext, PL_maxscream, I32);
682 sfirst = PL_screamfirst;
683 snext = PL_screamnext;
685 if (!sfirst || !snext)
686 DIE(aTHX_ "do_study: out of memory");
688 for (ch = 256; ch; --ch)
695 snext[pos] = sfirst[ch] - pos;
702 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
711 if (PL_op->op_flags & OPf_STACKED)
717 TARG = sv_newmortal();
722 /* Lvalue operators. */
734 djSP; dMARK; dTARGET;
744 SETi(do_chomp(TOPs));
750 djSP; dMARK; dTARGET;
751 register I32 count = 0;
754 count += do_chomp(POPs);
765 if (!sv || !SvANY(sv))
767 switch (SvTYPE(sv)) {
769 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
773 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
777 if (CvROOT(sv) || CvXSUB(sv))
794 if (!PL_op->op_private) {
803 if (SvTHINKFIRST(sv))
806 switch (SvTYPE(sv)) {
816 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
817 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
818 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
822 /* let user-undef'd sub keep its identity */
823 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
830 SvSetMagicSV(sv, &PL_sv_undef);
834 Newz(602, gp, 1, GP);
835 GvGP(sv) = gp_ref(gp);
836 GvSV(sv) = NEWSV(72,0);
837 GvLINE(sv) = CopLINE(PL_curcop);
843 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
846 SvPV_set(sv, Nullch);
859 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
860 DIE(aTHX_ PL_no_modify);
861 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
862 SvIVX(TOPs) != IV_MIN)
865 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
876 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
877 DIE(aTHX_ PL_no_modify);
878 sv_setsv(TARG, TOPs);
879 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
880 SvIVX(TOPs) != IV_MAX)
883 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
897 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
898 DIE(aTHX_ PL_no_modify);
899 sv_setsv(TARG, TOPs);
900 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
901 SvIVX(TOPs) != IV_MIN)
904 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
913 /* Ordinary operators. */
917 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
920 SETn( Perl_pow( left, right) );
927 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
930 SETn( left * right );
937 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
942 DIE(aTHX_ "Illegal division by zero");
944 /* insure that 20./5. == 4. */
947 if ((NV)I_V(left) == left &&
948 (NV)I_V(right) == right &&
949 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
953 value = left / right;
957 value = left / right;
966 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
976 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
978 right = (right_neg = (i < 0)) ? -i : i;
983 right_neg = dright < 0;
988 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
990 left = (left_neg = (i < 0)) ? -i : i;
998 left_neg = dleft < 0;
1007 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1009 # define CAST_D2UV(d) U_V(d)
1011 # define CAST_D2UV(d) ((UV)(d))
1013 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1014 * or, in other words, precision of UV more than of NV.
1015 * But in fact the approach below turned out to be an
1016 * optimization - floor() may be slow */
1017 if (dright <= UV_MAX && dleft <= UV_MAX) {
1018 right = CAST_D2UV(dright);
1019 left = CAST_D2UV(dleft);
1024 /* Backward-compatibility clause: */
1025 dright = Perl_floor(dright + 0.5);
1026 dleft = Perl_floor(dleft + 0.5);
1029 DIE(aTHX_ "Illegal modulus zero");
1031 dans = Perl_fmod(dleft, dright);
1032 if ((left_neg != right_neg) && dans)
1033 dans = dright - dans;
1036 sv_setnv(TARG, dans);
1043 DIE(aTHX_ "Illegal modulus zero");
1046 if ((left_neg != right_neg) && ans)
1049 /* XXX may warn: unary minus operator applied to unsigned type */
1050 /* could change -foo to be (~foo)+1 instead */
1051 if (ans <= ~((UV)IV_MAX)+1)
1052 sv_setiv(TARG, ~ans+1);
1054 sv_setnv(TARG, -(NV)ans);
1057 sv_setuv(TARG, ans);
1066 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1068 register IV count = POPi;
1069 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1071 I32 items = SP - MARK;
1074 max = items * count;
1083 repeatcpy((char*)(MARK + items), (char*)MARK,
1084 items * sizeof(SV*), count - 1);
1087 else if (count <= 0)
1090 else { /* Note: mark already snarfed by pp_list */
1093 bool isutf = DO_UTF8(tmpstr);
1095 SvSetSV(TARG, tmpstr);
1096 SvPV_force(TARG, len);
1101 SvGROW(TARG, (count * len) + 1);
1102 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1103 SvCUR(TARG) *= count;
1105 *SvEND(TARG) = '\0';
1108 (void)SvPOK_only_UTF8(TARG);
1110 (void)SvPOK_only(TARG);
1119 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1122 SETn( left - right );
1129 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1132 if (PL_op->op_private & HINT_INTEGER) {
1146 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1149 if (PL_op->op_private & HINT_INTEGER) {
1163 djSP; tryAMAGICbinSET(lt,0);
1166 SETs(boolSV(TOPn < value));
1173 djSP; tryAMAGICbinSET(gt,0);
1176 SETs(boolSV(TOPn > value));
1183 djSP; tryAMAGICbinSET(le,0);
1186 SETs(boolSV(TOPn <= value));
1193 djSP; tryAMAGICbinSET(ge,0);
1196 SETs(boolSV(TOPn >= value));
1203 djSP; tryAMAGICbinSET(ne,0);
1206 SETs(boolSV(TOPn != value));
1213 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1219 if (Perl_isnan(left) || Perl_isnan(right)) {
1223 value = (left > right) - (left < right);
1227 else if (left < right)
1229 else if (left > right)
1243 djSP; tryAMAGICbinSET(slt,0);
1246 int cmp = ((PL_op->op_private & OPpLOCALE)
1247 ? sv_cmp_locale(left, right)
1248 : sv_cmp(left, right));
1249 SETs(boolSV(cmp < 0));
1256 djSP; tryAMAGICbinSET(sgt,0);
1259 int cmp = ((PL_op->op_private & OPpLOCALE)
1260 ? sv_cmp_locale(left, right)
1261 : sv_cmp(left, right));
1262 SETs(boolSV(cmp > 0));
1269 djSP; tryAMAGICbinSET(sle,0);
1272 int cmp = ((PL_op->op_private & OPpLOCALE)
1273 ? sv_cmp_locale(left, right)
1274 : sv_cmp(left, right));
1275 SETs(boolSV(cmp <= 0));
1282 djSP; tryAMAGICbinSET(sge,0);
1285 int cmp = ((PL_op->op_private & OPpLOCALE)
1286 ? sv_cmp_locale(left, right)
1287 : sv_cmp(left, right));
1288 SETs(boolSV(cmp >= 0));
1295 djSP; tryAMAGICbinSET(seq,0);
1298 SETs(boolSV(sv_eq(left, right)));
1305 djSP; tryAMAGICbinSET(sne,0);
1308 SETs(boolSV(!sv_eq(left, right)));
1315 djSP; dTARGET; tryAMAGICbin(scmp,0);
1318 int cmp = ((PL_op->op_private & OPpLOCALE)
1319 ? sv_cmp_locale(left, right)
1320 : sv_cmp(left, right));
1328 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1331 if (SvNIOKp(left) || SvNIOKp(right)) {
1332 if (PL_op->op_private & HINT_INTEGER) {
1333 IV i = SvIV(left) & SvIV(right);
1337 UV u = SvUV(left) & SvUV(right);
1342 do_vop(PL_op->op_type, TARG, left, right);
1351 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1354 if (SvNIOKp(left) || SvNIOKp(right)) {
1355 if (PL_op->op_private & HINT_INTEGER) {
1356 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1360 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1365 do_vop(PL_op->op_type, TARG, left, right);
1374 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1377 if (SvNIOKp(left) || SvNIOKp(right)) {
1378 if (PL_op->op_private & HINT_INTEGER) {
1379 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1383 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1388 do_vop(PL_op->op_type, TARG, left, right);
1397 djSP; dTARGET; tryAMAGICun(neg);
1402 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1404 if (SvIVX(sv) == IV_MIN) {
1405 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1408 else if (SvUVX(sv) <= IV_MAX) {
1413 else if (SvIVX(sv) != IV_MIN) {
1420 else if (SvPOKp(sv)) {
1422 char *s = SvPV(sv, len);
1423 if (isIDFIRST(*s)) {
1424 sv_setpvn(TARG, "-", 1);
1427 else if (*s == '+' || *s == '-') {
1429 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1431 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1432 sv_setpvn(TARG, "-", 1);
1436 sv_setnv(TARG, -SvNV(sv));
1447 djSP; tryAMAGICunSET(not);
1448 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1454 djSP; dTARGET; tryAMAGICun(compl);
1458 if (PL_op->op_private & HINT_INTEGER) {
1473 tmps = (U8*)SvPV_force(TARG, len);
1476 /* Calculate exact length, let's not estimate. */
1485 while (tmps < send) {
1486 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1487 tmps += UTF8SKIP(tmps);
1488 targlen += UNISKIP(~c);
1494 /* Now rewind strings and write them. */
1498 Newz(0, result, targlen + 1, U8);
1499 while (tmps < send) {
1500 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1501 tmps += UTF8SKIP(tmps);
1502 result = uv_to_utf8(result, ~c);
1506 sv_setpvn(TARG, (char*)result, targlen);
1510 Newz(0, result, nchar + 1, U8);
1511 while (tmps < send) {
1512 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
1513 tmps += UTF8SKIP(tmps);
1518 sv_setpvn(TARG, (char*)result, nchar);
1526 register long *tmpl;
1527 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1530 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1535 for ( ; anum > 0; anum--, tmps++)
1544 /* integer versions of some of the above */
1548 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1551 SETi( left * right );
1558 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1562 DIE(aTHX_ "Illegal division by zero");
1563 value = POPi / value;
1571 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1575 DIE(aTHX_ "Illegal modulus zero");
1576 SETi( left % right );
1583 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1586 SETi( left + right );
1593 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1596 SETi( left - right );
1603 djSP; tryAMAGICbinSET(lt,0);
1606 SETs(boolSV(left < right));
1613 djSP; tryAMAGICbinSET(gt,0);
1616 SETs(boolSV(left > right));
1623 djSP; tryAMAGICbinSET(le,0);
1626 SETs(boolSV(left <= right));
1633 djSP; tryAMAGICbinSET(ge,0);
1636 SETs(boolSV(left >= right));
1643 djSP; tryAMAGICbinSET(eq,0);
1646 SETs(boolSV(left == right));
1653 djSP; tryAMAGICbinSET(ne,0);
1656 SETs(boolSV(left != right));
1663 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1670 else if (left < right)
1681 djSP; dTARGET; tryAMAGICun(neg);
1686 /* High falutin' math. */
1690 djSP; dTARGET; tryAMAGICbin(atan2,0);
1693 SETn(Perl_atan2(left, right));
1700 djSP; dTARGET; tryAMAGICun(sin);
1704 value = Perl_sin(value);
1712 djSP; dTARGET; tryAMAGICun(cos);
1716 value = Perl_cos(value);
1722 /* Support Configure command-line overrides for rand() functions.
1723 After 5.005, perhaps we should replace this by Configure support
1724 for drand48(), random(), or rand(). For 5.005, though, maintain
1725 compatibility by calling rand() but allow the user to override it.
1726 See INSTALL for details. --Andy Dougherty 15 July 1998
1728 /* Now it's after 5.005, and Configure supports drand48() and random(),
1729 in addition to rand(). So the overrides should not be needed any more.
1730 --Jarkko Hietaniemi 27 September 1998
1733 #ifndef HAS_DRAND48_PROTO
1734 extern double drand48 (void);
1747 if (!PL_srand_called) {
1748 (void)seedDrand01((Rand_seed_t)seed());
1749 PL_srand_called = TRUE;
1764 (void)seedDrand01((Rand_seed_t)anum);
1765 PL_srand_called = TRUE;
1774 * This is really just a quick hack which grabs various garbage
1775 * values. It really should be a real hash algorithm which
1776 * spreads the effect of every input bit onto every output bit,
1777 * if someone who knows about such things would bother to write it.
1778 * Might be a good idea to add that function to CORE as well.
1779 * No numbers below come from careful analysis or anything here,
1780 * except they are primes and SEED_C1 > 1E6 to get a full-width
1781 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1782 * probably be bigger too.
1785 # define SEED_C1 1000003
1786 #define SEED_C4 73819
1788 # define SEED_C1 25747
1789 #define SEED_C4 20639
1793 #define SEED_C5 26107
1796 #ifndef PERL_NO_DEV_RANDOM
1801 # include <starlet.h>
1802 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1803 * in 100-ns units, typically incremented ever 10 ms. */
1804 unsigned int when[2];
1806 # ifdef HAS_GETTIMEOFDAY
1807 struct timeval when;
1813 /* This test is an escape hatch, this symbol isn't set by Configure. */
1814 #ifndef PERL_NO_DEV_RANDOM
1815 #ifndef PERL_RANDOM_DEVICE
1816 /* /dev/random isn't used by default because reads from it will block
1817 * if there isn't enough entropy available. You can compile with
1818 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1819 * is enough real entropy to fill the seed. */
1820 # define PERL_RANDOM_DEVICE "/dev/urandom"
1822 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1824 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1833 _ckvmssts(sys$gettim(when));
1834 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1836 # ifdef HAS_GETTIMEOFDAY
1837 gettimeofday(&when,(struct timezone *) 0);
1838 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1841 u = (U32)SEED_C1 * when;
1844 u += SEED_C3 * (U32)PerlProc_getpid();
1845 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1846 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1847 u += SEED_C5 * (U32)PTR2UV(&when);
1854 djSP; dTARGET; tryAMAGICun(exp);
1858 value = Perl_exp(value);
1866 djSP; dTARGET; tryAMAGICun(log);
1871 SET_NUMERIC_STANDARD();
1872 DIE(aTHX_ "Can't take log of %g", value);
1874 value = Perl_log(value);
1882 djSP; dTARGET; tryAMAGICun(sqrt);
1887 SET_NUMERIC_STANDARD();
1888 DIE(aTHX_ "Can't take sqrt of %g", value);
1890 value = Perl_sqrt(value);
1903 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1909 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1910 (void)Perl_modf(value, &value);
1912 double tmp = (double)value;
1913 (void)Perl_modf(tmp, &tmp);
1918 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1919 (void)Perl_modf(-value, &value);
1922 double tmp = (double)value;
1923 (void)Perl_modf(-tmp, &tmp);
1939 djSP; dTARGET; tryAMAGICun(abs);
1944 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1945 (iv = SvIVX(TOPs)) != IV_MIN) {
1967 argtype = 1; /* allow underscores */
1968 XPUSHn(scan_hex(tmps, 99, &argtype));
1981 while (*tmps && isSPACE(*tmps))
1985 argtype = 1; /* allow underscores */
1987 value = scan_hex(++tmps, 99, &argtype);
1988 else if (*tmps == 'b')
1989 value = scan_bin(++tmps, 99, &argtype);
1991 value = scan_oct(tmps, 99, &argtype);
2004 SETi(sv_len_utf8(sv));
2020 I32 lvalue = PL_op->op_flags & OPf_MOD;
2022 I32 arybase = PL_curcop->cop_arybase;
2026 SvTAINTED_off(TARG); /* decontaminate */
2027 SvUTF8_off(TARG); /* decontaminate */
2031 repl = SvPV(sv, repl_len);
2038 tmps = SvPV(sv, curlen);
2040 utfcurlen = sv_len_utf8(sv);
2041 if (utfcurlen == curlen)
2049 if (pos >= arybase) {
2067 else if (len >= 0) {
2069 if (rem > (I32)curlen)
2084 Perl_croak(aTHX_ "substr outside of string");
2085 if (ckWARN(WARN_SUBSTR))
2086 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2091 sv_pos_u2b(sv, &pos, &rem);
2093 sv_setpvn(TARG, tmps, rem);
2097 sv_insert(sv, pos, rem, repl, repl_len);
2098 else if (lvalue) { /* it's an lvalue! */
2099 if (!SvGMAGICAL(sv)) {
2103 if (ckWARN(WARN_SUBSTR))
2104 Perl_warner(aTHX_ WARN_SUBSTR,
2105 "Attempt to use reference as lvalue in substr");
2107 if (SvOK(sv)) /* is it defined ? */
2108 (void)SvPOK_only_UTF8(sv);
2110 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2113 if (SvTYPE(TARG) < SVt_PVLV) {
2114 sv_upgrade(TARG, SVt_PVLV);
2115 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2119 if (LvTARG(TARG) != sv) {
2121 SvREFCNT_dec(LvTARG(TARG));
2122 LvTARG(TARG) = SvREFCNT_inc(sv);
2124 LvTARGOFF(TARG) = pos;
2125 LvTARGLEN(TARG) = rem;
2129 PUSHs(TARG); /* avoid SvSETMAGIC here */
2136 register IV size = POPi;
2137 register IV offset = POPi;
2138 register SV *src = POPs;
2139 I32 lvalue = PL_op->op_flags & OPf_MOD;
2141 SvTAINTED_off(TARG); /* decontaminate */
2142 if (lvalue) { /* it's an lvalue! */
2143 if (SvTYPE(TARG) < SVt_PVLV) {
2144 sv_upgrade(TARG, SVt_PVLV);
2145 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2148 if (LvTARG(TARG) != src) {
2150 SvREFCNT_dec(LvTARG(TARG));
2151 LvTARG(TARG) = SvREFCNT_inc(src);
2153 LvTARGOFF(TARG) = offset;
2154 LvTARGLEN(TARG) = size;
2157 sv_setuv(TARG, do_vecget(src, offset, size));
2172 I32 arybase = PL_curcop->cop_arybase;
2177 offset = POPi - arybase;
2180 tmps = SvPV(big, biglen);
2181 if (offset > 0 && DO_UTF8(big))
2182 sv_pos_u2b(big, &offset, 0);
2185 else if (offset > biglen)
2187 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2188 (unsigned char*)tmps + biglen, little, 0)))
2191 retval = tmps2 - tmps;
2192 if (retval > 0 && DO_UTF8(big))
2193 sv_pos_b2u(big, &retval);
2194 PUSHi(retval + arybase);
2209 I32 arybase = PL_curcop->cop_arybase;
2215 tmps2 = SvPV(little, llen);
2216 tmps = SvPV(big, blen);
2220 if (offset > 0 && DO_UTF8(big))
2221 sv_pos_u2b(big, &offset, 0);
2222 offset = offset - arybase + llen;
2226 else if (offset > blen)
2228 if (!(tmps2 = rninstr(tmps, tmps + offset,
2229 tmps2, tmps2 + llen)))
2232 retval = tmps2 - tmps;
2233 if (retval > 0 && DO_UTF8(big))
2234 sv_pos_b2u(big, &retval);
2235 PUSHi(retval + arybase);
2241 djSP; dMARK; dORIGMARK; dTARGET;
2242 do_sprintf(TARG, SP-MARK, MARK+1);
2243 TAINT_IF(SvTAINTED(TARG));
2255 U8 *tmps = (U8*)SvPVx(tmpsv, len);
2258 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2259 value = utf8_to_uv(tmps, len, &retlen, 0);
2261 value = (UV)(*tmps & 255);
2272 (void)SvUPGRADE(TARG,SVt_PV);
2274 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2275 SvGROW(TARG, UTF8_MAXLEN+1);
2277 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2278 SvCUR_set(TARG, tmps - SvPVX(TARG));
2280 (void)SvPOK_only(TARG);
2291 (void)SvPOK_only(TARG);
2298 djSP; dTARGET; dPOPTOPssrl;
2301 char *tmps = SvPV(left, n_a);
2303 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2305 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2309 "The crypt() function is unimplemented due to excessive paranoia.");
2322 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2324 U8 tmpbuf[UTF8_MAXLEN];
2326 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2328 if (PL_op->op_private & OPpLOCALE) {
2331 uv = toTITLE_LC_uni(uv);
2334 uv = toTITLE_utf8(s);
2336 tend = uv_to_utf8(tmpbuf, uv);
2338 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2340 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2341 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2346 s = (U8*)SvPV_force(sv, slen);
2347 Copy(tmpbuf, s, ulen, U8);
2351 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2353 SvUTF8_off(TARG); /* decontaminate */
2358 s = (U8*)SvPV_force(sv, slen);
2360 if (PL_op->op_private & OPpLOCALE) {
2363 *s = toUPPER_LC(*s);
2381 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2383 U8 tmpbuf[UTF8_MAXLEN];
2385 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2387 if (PL_op->op_private & OPpLOCALE) {
2390 uv = toLOWER_LC_uni(uv);
2393 uv = toLOWER_utf8(s);
2395 tend = uv_to_utf8(tmpbuf, uv);
2397 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2399 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2400 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2405 s = (U8*)SvPV_force(sv, slen);
2406 Copy(tmpbuf, s, ulen, U8);
2410 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2412 SvUTF8_off(TARG); /* decontaminate */
2417 s = (U8*)SvPV_force(sv, slen);
2419 if (PL_op->op_private & OPpLOCALE) {
2422 *s = toLOWER_LC(*s);
2446 s = (U8*)SvPV(sv,len);
2448 SvUTF8_off(TARG); /* decontaminate */
2449 sv_setpvn(TARG, "", 0);
2453 (void)SvUPGRADE(TARG, SVt_PV);
2454 SvGROW(TARG, (len * 2) + 1);
2455 (void)SvPOK_only(TARG);
2456 d = (U8*)SvPVX(TARG);
2458 if (PL_op->op_private & OPpLOCALE) {
2462 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2468 d = uv_to_utf8(d, toUPPER_utf8( s ));
2474 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2479 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2481 SvUTF8_off(TARG); /* decontaminate */
2486 s = (U8*)SvPV_force(sv, len);
2488 register U8 *send = s + len;
2490 if (PL_op->op_private & OPpLOCALE) {
2493 for (; s < send; s++)
2494 *s = toUPPER_LC(*s);
2497 for (; s < send; s++)
2520 s = (U8*)SvPV(sv,len);
2522 SvUTF8_off(TARG); /* decontaminate */
2523 sv_setpvn(TARG, "", 0);
2527 (void)SvUPGRADE(TARG, SVt_PV);
2528 SvGROW(TARG, (len * 2) + 1);
2529 (void)SvPOK_only(TARG);
2530 d = (U8*)SvPVX(TARG);
2532 if (PL_op->op_private & OPpLOCALE) {
2536 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2542 d = uv_to_utf8(d, toLOWER_utf8(s));
2548 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2553 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2555 SvUTF8_off(TARG); /* decontaminate */
2561 s = (U8*)SvPV_force(sv, len);
2563 register U8 *send = s + len;
2565 if (PL_op->op_private & OPpLOCALE) {
2568 for (; s < send; s++)
2569 *s = toLOWER_LC(*s);
2572 for (; s < send; s++)
2587 register char *s = SvPV(sv,len);
2590 SvUTF8_off(TARG); /* decontaminate */
2592 (void)SvUPGRADE(TARG, SVt_PV);
2593 SvGROW(TARG, (len * 2) + 1);
2598 STRLEN ulen = UTF8SKIP(s);
2622 SvCUR_set(TARG, d - SvPVX(TARG));
2623 (void)SvPOK_only_UTF8(TARG);
2626 sv_setpvn(TARG, s, len);
2628 if (SvSMAGICAL(TARG))
2637 djSP; dMARK; dORIGMARK;
2639 register AV* av = (AV*)POPs;
2640 register I32 lval = PL_op->op_flags & OPf_MOD;
2641 I32 arybase = PL_curcop->cop_arybase;
2644 if (SvTYPE(av) == SVt_PVAV) {
2645 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2647 for (svp = MARK + 1; svp <= SP; svp++) {
2652 if (max > AvMAX(av))
2655 while (++MARK <= SP) {
2656 elem = SvIVx(*MARK);
2660 svp = av_fetch(av, elem, lval);
2662 if (!svp || *svp == &PL_sv_undef)
2663 DIE(aTHX_ PL_no_aelem, elem);
2664 if (PL_op->op_private & OPpLVAL_INTRO)
2665 save_aelem(av, elem, svp);
2667 *MARK = svp ? *svp : &PL_sv_undef;
2670 if (GIMME != G_ARRAY) {
2678 /* Associative arrays. */
2683 HV *hash = (HV*)POPs;
2685 I32 gimme = GIMME_V;
2686 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2689 /* might clobber stack_sp */
2690 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2695 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2696 if (gimme == G_ARRAY) {
2699 /* might clobber stack_sp */
2701 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2706 else if (gimme == G_SCALAR)
2725 I32 gimme = GIMME_V;
2726 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2730 if (PL_op->op_private & OPpSLICE) {
2734 hvtype = SvTYPE(hv);
2735 if (hvtype == SVt_PVHV) { /* hash element */
2736 while (++MARK <= SP) {
2737 sv = hv_delete_ent(hv, *MARK, discard, 0);
2738 *MARK = sv ? sv : &PL_sv_undef;
2741 else if (hvtype == SVt_PVAV) {
2742 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2743 while (++MARK <= SP) {
2744 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2745 *MARK = sv ? sv : &PL_sv_undef;
2748 else { /* pseudo-hash element */
2749 while (++MARK <= SP) {
2750 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2751 *MARK = sv ? sv : &PL_sv_undef;
2756 DIE(aTHX_ "Not a HASH reference");
2759 else if (gimme == G_SCALAR) {
2768 if (SvTYPE(hv) == SVt_PVHV)
2769 sv = hv_delete_ent(hv, keysv, discard, 0);
2770 else if (SvTYPE(hv) == SVt_PVAV) {
2771 if (PL_op->op_flags & OPf_SPECIAL)
2772 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2774 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2777 DIE(aTHX_ "Not a HASH reference");
2792 if (PL_op->op_private & OPpEXISTS_SUB) {
2796 cv = sv_2cv(sv, &hv, &gv, FALSE);
2799 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2805 if (SvTYPE(hv) == SVt_PVHV) {
2806 if (hv_exists_ent(hv, tmpsv, 0))
2809 else if (SvTYPE(hv) == SVt_PVAV) {
2810 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2811 if (av_exists((AV*)hv, SvIV(tmpsv)))
2814 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2818 DIE(aTHX_ "Not a HASH reference");
2825 djSP; dMARK; dORIGMARK;
2826 register HV *hv = (HV*)POPs;
2827 register I32 lval = PL_op->op_flags & OPf_MOD;
2828 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2830 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2831 DIE(aTHX_ "Can't localize pseudo-hash element");
2833 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2834 while (++MARK <= SP) {
2838 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2839 svp = he ? &HeVAL(he) : 0;
2842 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2845 if (!svp || *svp == &PL_sv_undef) {
2847 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2849 if (PL_op->op_private & OPpLVAL_INTRO)
2850 save_helem(hv, keysv, svp);
2852 *MARK = svp ? *svp : &PL_sv_undef;
2855 if (GIMME != G_ARRAY) {
2863 /* List operators. */
2868 if (GIMME != G_ARRAY) {
2870 *MARK = *SP; /* unwanted list, return last item */
2872 *MARK = &PL_sv_undef;
2881 SV **lastrelem = PL_stack_sp;
2882 SV **lastlelem = PL_stack_base + POPMARK;
2883 SV **firstlelem = PL_stack_base + POPMARK + 1;
2884 register SV **firstrelem = lastlelem + 1;
2885 I32 arybase = PL_curcop->cop_arybase;
2886 I32 lval = PL_op->op_flags & OPf_MOD;
2887 I32 is_something_there = lval;
2889 register I32 max = lastrelem - lastlelem;
2890 register SV **lelem;
2893 if (GIMME != G_ARRAY) {
2894 ix = SvIVx(*lastlelem);
2899 if (ix < 0 || ix >= max)
2900 *firstlelem = &PL_sv_undef;
2902 *firstlelem = firstrelem[ix];
2908 SP = firstlelem - 1;
2912 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2918 if (ix < 0 || ix >= max)
2919 *lelem = &PL_sv_undef;
2921 is_something_there = TRUE;
2922 if (!(*lelem = firstrelem[ix]))
2923 *lelem = &PL_sv_undef;
2926 if (is_something_there)
2929 SP = firstlelem - 1;
2935 djSP; dMARK; dORIGMARK;
2936 I32 items = SP - MARK;
2937 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2938 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2945 djSP; dMARK; dORIGMARK;
2946 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2950 SV *val = NEWSV(46, 0);
2952 sv_setsv(val, *++MARK);
2953 else if (ckWARN(WARN_MISC))
2954 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2955 (void)hv_store_ent(hv,key,val,0);
2964 djSP; dMARK; dORIGMARK;
2965 register AV *ary = (AV*)*++MARK;
2969 register I32 offset;
2970 register I32 length;
2977 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2978 *MARK-- = SvTIED_obj((SV*)ary, mg);
2982 call_method("SPLICE",GIMME_V);
2991 offset = i = SvIVx(*MARK);
2993 offset += AvFILLp(ary) + 1;
2995 offset -= PL_curcop->cop_arybase;
2997 DIE(aTHX_ PL_no_aelem, i);
2999 length = SvIVx(*MARK++);
3001 length += AvFILLp(ary) - offset + 1;
3007 length = AvMAX(ary) + 1; /* close enough to infinity */
3011 length = AvMAX(ary) + 1;
3013 if (offset > AvFILLp(ary) + 1)
3014 offset = AvFILLp(ary) + 1;
3015 after = AvFILLp(ary) + 1 - (offset + length);
3016 if (after < 0) { /* not that much array */
3017 length += after; /* offset+length now in array */
3023 /* At this point, MARK .. SP-1 is our new LIST */
3026 diff = newlen - length;
3027 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3030 if (diff < 0) { /* shrinking the area */
3032 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3033 Copy(MARK, tmparyval, newlen, SV*);
3036 MARK = ORIGMARK + 1;
3037 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3038 MEXTEND(MARK, length);
3039 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3041 EXTEND_MORTAL(length);
3042 for (i = length, dst = MARK; i; i--) {
3043 sv_2mortal(*dst); /* free them eventualy */
3050 *MARK = AvARRAY(ary)[offset+length-1];
3053 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3054 SvREFCNT_dec(*dst++); /* free them now */
3057 AvFILLp(ary) += diff;
3059 /* pull up or down? */
3061 if (offset < after) { /* easier to pull up */
3062 if (offset) { /* esp. if nothing to pull */
3063 src = &AvARRAY(ary)[offset-1];
3064 dst = src - diff; /* diff is negative */
3065 for (i = offset; i > 0; i--) /* can't trust Copy */
3069 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3073 if (after) { /* anything to pull down? */
3074 src = AvARRAY(ary) + offset + length;
3075 dst = src + diff; /* diff is negative */
3076 Move(src, dst, after, SV*);
3078 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3079 /* avoid later double free */
3083 dst[--i] = &PL_sv_undef;
3086 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3088 *dst = NEWSV(46, 0);
3089 sv_setsv(*dst++, *src++);
3091 Safefree(tmparyval);
3094 else { /* no, expanding (or same) */
3096 New(452, tmparyval, length, SV*); /* so remember deletion */
3097 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3100 if (diff > 0) { /* expanding */
3102 /* push up or down? */
3104 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3108 Move(src, dst, offset, SV*);
3110 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3112 AvFILLp(ary) += diff;
3115 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3116 av_extend(ary, AvFILLp(ary) + diff);
3117 AvFILLp(ary) += diff;
3120 dst = AvARRAY(ary) + AvFILLp(ary);
3122 for (i = after; i; i--) {
3129 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3130 *dst = NEWSV(46, 0);
3131 sv_setsv(*dst++, *src++);
3133 MARK = ORIGMARK + 1;
3134 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3136 Copy(tmparyval, MARK, length, SV*);
3138 EXTEND_MORTAL(length);
3139 for (i = length, dst = MARK; i; i--) {
3140 sv_2mortal(*dst); /* free them eventualy */
3144 Safefree(tmparyval);
3148 else if (length--) {
3149 *MARK = tmparyval[length];
3152 while (length-- > 0)
3153 SvREFCNT_dec(tmparyval[length]);
3155 Safefree(tmparyval);
3158 *MARK = &PL_sv_undef;
3166 djSP; dMARK; dORIGMARK; dTARGET;
3167 register AV *ary = (AV*)*++MARK;
3168 register SV *sv = &PL_sv_undef;
3171 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3172 *MARK-- = SvTIED_obj((SV*)ary, mg);
3176 call_method("PUSH",G_SCALAR|G_DISCARD);
3181 /* Why no pre-extend of ary here ? */
3182 for (++MARK; MARK <= SP; MARK++) {
3185 sv_setsv(sv, *MARK);
3190 PUSHi( AvFILL(ary) + 1 );
3198 SV *sv = av_pop(av);
3200 (void)sv_2mortal(sv);
3209 SV *sv = av_shift(av);
3214 (void)sv_2mortal(sv);
3221 djSP; dMARK; dORIGMARK; dTARGET;
3222 register AV *ary = (AV*)*++MARK;
3227 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3228 *MARK-- = SvTIED_obj((SV*)ary, mg);
3232 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3237 av_unshift(ary, SP - MARK);
3240 sv_setsv(sv, *++MARK);
3241 (void)av_store(ary, i++, sv);
3245 PUSHi( AvFILL(ary) + 1 );
3255 if (GIMME == G_ARRAY) {
3262 /* safe as long as stack cannot get extended in the above */
3267 register char *down;
3272 SvUTF8_off(TARG); /* decontaminate */
3274 do_join(TARG, &PL_sv_no, MARK, SP);
3276 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3277 up = SvPV_force(TARG, len);
3279 if (DO_UTF8(TARG)) { /* first reverse each character */
3280 U8* s = (U8*)SvPVX(TARG);
3281 U8* send = (U8*)(s + len);
3290 down = (char*)(s - 1);
3291 if (s > send || !((*down & 0xc0) == 0x80)) {
3292 if (ckWARN_d(WARN_UTF8))
3293 Perl_warner(aTHX_ WARN_UTF8,
3294 "Malformed UTF-8 character");
3306 down = SvPVX(TARG) + len - 1;
3312 (void)SvPOK_only_UTF8(TARG);
3321 S_mul128(pTHX_ SV *sv, U8 m)
3324 char *s = SvPV(sv, len);
3328 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3329 SV *tmpNew = newSVpvn("0000000000", 10);
3331 sv_catsv(tmpNew, sv);
3332 SvREFCNT_dec(sv); /* free old sv */
3337 while (!*t) /* trailing '\0'? */
3340 i = ((*t - '0') << 7) + m;
3341 *(t--) = '0' + (i % 10);
3347 /* Explosives and implosives. */
3349 #if 'I' == 73 && 'J' == 74
3350 /* On an ASCII/ISO kind of system */
3351 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3354 Some other sort of character set - use memchr() so we don't match
3357 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3364 I32 start_sp_offset = SP - PL_stack_base;
3365 I32 gimme = GIMME_V;
3369 register char *pat = SvPV(left, llen);
3370 register char *s = SvPV(right, rlen);
3371 char *strend = s + rlen;
3373 register char *patend = pat + llen;
3379 /* These must not be in registers: */
3396 register U32 culong;
3400 #ifdef PERL_NATINT_PACK
3401 int natint; /* native integer */
3402 int unatint; /* unsigned native integer */
3405 if (gimme != G_ARRAY) { /* arrange to do first one only */
3407 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3408 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3410 while (isDIGIT(*patend) || *patend == '*')
3416 while (pat < patend) {
3418 datumtype = *pat++ & 0xFF;
3419 #ifdef PERL_NATINT_PACK
3422 if (isSPACE(datumtype))
3424 if (datumtype == '#') {
3425 while (pat < patend && *pat != '\n')
3430 char *natstr = "sSiIlL";
3432 if (strchr(natstr, datumtype)) {
3433 #ifdef PERL_NATINT_PACK
3439 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3444 else if (*pat == '*') {
3445 len = strend - strbeg; /* long enough */
3449 else if (isDIGIT(*pat)) {
3451 while (isDIGIT(*pat)) {
3452 len = (len * 10) + (*pat++ - '0');
3454 DIE(aTHX_ "Repeat count in unpack overflows");
3458 len = (datumtype != '@');
3462 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3463 case ',': /* grandfather in commas but with a warning */
3464 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3465 Perl_warner(aTHX_ WARN_UNPACK,
3466 "Invalid type in unpack: '%c'", (int)datumtype);
3469 if (len == 1 && pat[-1] != '1')
3478 if (len > strend - strbeg)
3479 DIE(aTHX_ "@ outside of string");
3483 if (len > s - strbeg)
3484 DIE(aTHX_ "X outside of string");
3488 if (len > strend - s)
3489 DIE(aTHX_ "x outside of string");
3493 if (start_sp_offset >= SP - PL_stack_base)
3494 DIE(aTHX_ "/ must follow a numeric type");
3497 pat++; /* ignore '*' for compatibility with pack */
3499 DIE(aTHX_ "/ cannot take a count" );
3506 if (len > strend - s)
3509 goto uchar_checksum;
3510 sv = NEWSV(35, len);
3511 sv_setpvn(sv, s, len);
3513 if (datumtype == 'A' || datumtype == 'Z') {
3514 aptr = s; /* borrow register */
3515 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3520 else { /* 'A' strips both nulls and spaces */
3521 s = SvPVX(sv) + len - 1;
3522 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3526 SvCUR_set(sv, s - SvPVX(sv));
3527 s = aptr; /* unborrow register */
3529 XPUSHs(sv_2mortal(sv));
3533 if (star || len > (strend - s) * 8)
3534 len = (strend - s) * 8;
3537 Newz(601, PL_bitcount, 256, char);
3538 for (bits = 1; bits < 256; bits++) {
3539 if (bits & 1) PL_bitcount[bits]++;
3540 if (bits & 2) PL_bitcount[bits]++;
3541 if (bits & 4) PL_bitcount[bits]++;
3542 if (bits & 8) PL_bitcount[bits]++;
3543 if (bits & 16) PL_bitcount[bits]++;
3544 if (bits & 32) PL_bitcount[bits]++;
3545 if (bits & 64) PL_bitcount[bits]++;
3546 if (bits & 128) PL_bitcount[bits]++;
3550 culong += PL_bitcount[*(unsigned char*)s++];
3555 if (datumtype == 'b') {
3557 if (bits & 1) culong++;
3563 if (bits & 128) culong++;
3570 sv = NEWSV(35, len + 1);
3574 if (datumtype == 'b') {
3576 for (len = 0; len < aint; len++) {
3577 if (len & 7) /*SUPPRESS 595*/
3581 *str++ = '0' + (bits & 1);
3586 for (len = 0; len < aint; len++) {
3591 *str++ = '0' + ((bits & 128) != 0);
3595 XPUSHs(sv_2mortal(sv));
3599 if (star || len > (strend - s) * 2)
3600 len = (strend - s) * 2;
3601 sv = NEWSV(35, len + 1);
3605 if (datumtype == 'h') {
3607 for (len = 0; len < aint; len++) {
3612 *str++ = PL_hexdigit[bits & 15];
3617 for (len = 0; len < aint; len++) {
3622 *str++ = PL_hexdigit[(bits >> 4) & 15];
3626 XPUSHs(sv_2mortal(sv));
3629 if (len > strend - s)
3634 if (aint >= 128) /* fake up signed chars */
3644 if (aint >= 128) /* fake up signed chars */
3647 sv_setiv(sv, (IV)aint);
3648 PUSHs(sv_2mortal(sv));
3653 if (len > strend - s)
3668 sv_setiv(sv, (IV)auint);
3669 PUSHs(sv_2mortal(sv));
3674 if (len > strend - s)
3677 while (len-- > 0 && s < strend) {
3679 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3683 cdouble += (NV)auint;
3691 while (len-- > 0 && s < strend) {
3693 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3697 sv_setuv(sv, (UV)auint);
3698 PUSHs(sv_2mortal(sv));
3703 #if SHORTSIZE == SIZE16
3704 along = (strend - s) / SIZE16;
3706 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3711 #if SHORTSIZE != SIZE16
3715 COPYNN(s, &ashort, sizeof(short));
3726 #if SHORTSIZE > SIZE16
3738 #if SHORTSIZE != SIZE16
3742 COPYNN(s, &ashort, sizeof(short));
3745 sv_setiv(sv, (IV)ashort);
3746 PUSHs(sv_2mortal(sv));
3754 #if SHORTSIZE > SIZE16
3760 sv_setiv(sv, (IV)ashort);
3761 PUSHs(sv_2mortal(sv));
3769 #if SHORTSIZE == SIZE16
3770 along = (strend - s) / SIZE16;
3772 unatint = natint && datumtype == 'S';
3773 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3778 #if SHORTSIZE != SIZE16
3780 unsigned short aushort;
3782 COPYNN(s, &aushort, sizeof(unsigned short));
3783 s += sizeof(unsigned short);
3791 COPY16(s, &aushort);
3794 if (datumtype == 'n')
3795 aushort = PerlSock_ntohs(aushort);
3798 if (datumtype == 'v')
3799 aushort = vtohs(aushort);
3808 #if SHORTSIZE != SIZE16
3810 unsigned short aushort;
3812 COPYNN(s, &aushort, sizeof(unsigned short));
3813 s += sizeof(unsigned short);
3815 sv_setiv(sv, (UV)aushort);
3816 PUSHs(sv_2mortal(sv));
3823 COPY16(s, &aushort);
3827 if (datumtype == 'n')
3828 aushort = PerlSock_ntohs(aushort);
3831 if (datumtype == 'v')
3832 aushort = vtohs(aushort);
3834 sv_setiv(sv, (UV)aushort);
3835 PUSHs(sv_2mortal(sv));
3841 along = (strend - s) / sizeof(int);
3846 Copy(s, &aint, 1, int);
3849 cdouble += (NV)aint;
3858 Copy(s, &aint, 1, int);
3862 /* Without the dummy below unpack("i", pack("i",-1))
3863 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3864 * cc with optimization turned on.
3866 * The bug was detected in
3867 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3868 * with optimization (-O4) turned on.
3869 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3870 * does not have this problem even with -O4.
3872 * This bug was reported as DECC_BUGS 1431
3873 * and tracked internally as GEM_BUGS 7775.
3875 * The bug is fixed in
3876 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3877 * UNIX V4.0F support: DEC C V5.9-006 or later
3878 * UNIX V4.0E support: DEC C V5.8-011 or later
3881 * See also few lines later for the same bug.
3884 sv_setiv(sv, (IV)aint) :
3886 sv_setiv(sv, (IV)aint);
3887 PUSHs(sv_2mortal(sv));
3892 along = (strend - s) / sizeof(unsigned int);
3897 Copy(s, &auint, 1, unsigned int);
3898 s += sizeof(unsigned int);
3900 cdouble += (NV)auint;
3909 Copy(s, &auint, 1, unsigned int);
3910 s += sizeof(unsigned int);
3913 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3914 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3915 * See details few lines earlier. */
3917 sv_setuv(sv, (UV)auint) :
3919 sv_setuv(sv, (UV)auint);
3920 PUSHs(sv_2mortal(sv));
3925 #if LONGSIZE == SIZE32
3926 along = (strend - s) / SIZE32;
3928 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3933 #if LONGSIZE != SIZE32
3936 COPYNN(s, &along, sizeof(long));
3939 cdouble += (NV)along;
3948 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3952 #if LONGSIZE > SIZE32
3953 if (along > 2147483647)
3954 along -= 4294967296;
3958 cdouble += (NV)along;
3967 #if LONGSIZE != SIZE32
3970 COPYNN(s, &along, sizeof(long));
3973 sv_setiv(sv, (IV)along);
3974 PUSHs(sv_2mortal(sv));
3981 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3985 #if LONGSIZE > SIZE32
3986 if (along > 2147483647)
3987 along -= 4294967296;
3991 sv_setiv(sv, (IV)along);
3992 PUSHs(sv_2mortal(sv));
4000 #if LONGSIZE == SIZE32
4001 along = (strend - s) / SIZE32;
4003 unatint = natint && datumtype == 'L';
4004 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4009 #if LONGSIZE != SIZE32
4011 unsigned long aulong;
4013 COPYNN(s, &aulong, sizeof(unsigned long));
4014 s += sizeof(unsigned long);
4016 cdouble += (NV)aulong;
4028 if (datumtype == 'N')
4029 aulong = PerlSock_ntohl(aulong);
4032 if (datumtype == 'V')
4033 aulong = vtohl(aulong);
4036 cdouble += (NV)aulong;
4045 #if LONGSIZE != SIZE32
4047 unsigned long aulong;
4049 COPYNN(s, &aulong, sizeof(unsigned long));
4050 s += sizeof(unsigned long);
4052 sv_setuv(sv, (UV)aulong);
4053 PUSHs(sv_2mortal(sv));
4063 if (datumtype == 'N')
4064 aulong = PerlSock_ntohl(aulong);
4067 if (datumtype == 'V')
4068 aulong = vtohl(aulong);
4071 sv_setuv(sv, (UV)aulong);
4072 PUSHs(sv_2mortal(sv));
4078 along = (strend - s) / sizeof(char*);
4084 if (sizeof(char*) > strend - s)
4087 Copy(s, &aptr, 1, char*);
4093 PUSHs(sv_2mortal(sv));
4103 while ((len > 0) && (s < strend)) {
4104 auv = (auv << 7) | (*s & 0x7f);
4105 if (!(*s++ & 0x80)) {
4109 PUSHs(sv_2mortal(sv));
4113 else if (++bytes >= sizeof(UV)) { /* promote to string */
4117 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4118 while (s < strend) {
4119 sv = mul128(sv, *s & 0x7f);
4120 if (!(*s++ & 0x80)) {
4129 PUSHs(sv_2mortal(sv));
4134 if ((s >= strend) && bytes)
4135 DIE(aTHX_ "Unterminated compressed integer");
4140 if (sizeof(char*) > strend - s)
4143 Copy(s, &aptr, 1, char*);
4148 sv_setpvn(sv, aptr, len);
4149 PUSHs(sv_2mortal(sv));
4153 along = (strend - s) / sizeof(Quad_t);
4159 if (s + sizeof(Quad_t) > strend)
4162 Copy(s, &aquad, 1, Quad_t);
4163 s += sizeof(Quad_t);
4166 if (aquad >= IV_MIN && aquad <= IV_MAX)
4167 sv_setiv(sv, (IV)aquad);
4169 sv_setnv(sv, (NV)aquad);
4170 PUSHs(sv_2mortal(sv));
4174 along = (strend - s) / sizeof(Quad_t);
4180 if (s + sizeof(Uquad_t) > strend)
4183 Copy(s, &auquad, 1, Uquad_t);
4184 s += sizeof(Uquad_t);
4187 if (auquad <= UV_MAX)
4188 sv_setuv(sv, (UV)auquad);
4190 sv_setnv(sv, (NV)auquad);
4191 PUSHs(sv_2mortal(sv));
4195 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4198 along = (strend - s) / sizeof(float);
4203 Copy(s, &afloat, 1, float);
4212 Copy(s, &afloat, 1, float);
4215 sv_setnv(sv, (NV)afloat);
4216 PUSHs(sv_2mortal(sv));
4222 along = (strend - s) / sizeof(double);
4227 Copy(s, &adouble, 1, double);
4228 s += sizeof(double);
4236 Copy(s, &adouble, 1, double);
4237 s += sizeof(double);
4239 sv_setnv(sv, (NV)adouble);
4240 PUSHs(sv_2mortal(sv));
4246 * Initialise the decode mapping. By using a table driven
4247 * algorithm, the code will be character-set independent
4248 * (and just as fast as doing character arithmetic)
4250 if (PL_uudmap['M'] == 0) {
4253 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4254 PL_uudmap[(U8)PL_uuemap[i]] = i;
4256 * Because ' ' and '`' map to the same value,
4257 * we need to decode them both the same.
4262 along = (strend - s) * 3 / 4;
4263 sv = NEWSV(42, along);
4266 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4271 len = PL_uudmap[*(U8*)s++] & 077;
4273 if (s < strend && ISUUCHAR(*s))
4274 a = PL_uudmap[*(U8*)s++] & 077;
4277 if (s < strend && ISUUCHAR(*s))
4278 b = PL_uudmap[*(U8*)s++] & 077;
4281 if (s < strend && ISUUCHAR(*s))
4282 c = PL_uudmap[*(U8*)s++] & 077;
4285 if (s < strend && ISUUCHAR(*s))
4286 d = PL_uudmap[*(U8*)s++] & 077;
4289 hunk[0] = (a << 2) | (b >> 4);
4290 hunk[1] = (b << 4) | (c >> 2);
4291 hunk[2] = (c << 6) | d;
4292 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4297 else if (s[1] == '\n') /* possible checksum byte */
4300 XPUSHs(sv_2mortal(sv));
4305 if (strchr("fFdD", datumtype) ||
4306 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4310 while (checksum >= 16) {
4314 while (checksum >= 4) {
4320 along = (1 << checksum) - 1;
4321 while (cdouble < 0.0)
4323 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4324 sv_setnv(sv, cdouble);
4327 if (checksum < 32) {
4328 aulong = (1 << checksum) - 1;
4331 sv_setuv(sv, (UV)culong);
4333 XPUSHs(sv_2mortal(sv));
4337 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4338 PUSHs(&PL_sv_undef);
4343 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4347 *hunk = PL_uuemap[len];
4348 sv_catpvn(sv, hunk, 1);
4351 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4352 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4353 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4354 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4355 sv_catpvn(sv, hunk, 4);
4360 char r = (len > 1 ? s[1] : '\0');
4361 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4362 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4363 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4364 hunk[3] = PL_uuemap[0];
4365 sv_catpvn(sv, hunk, 4);
4367 sv_catpvn(sv, "\n", 1);
4371 S_is_an_int(pTHX_ char *s, STRLEN l)
4374 SV *result = newSVpvn(s, l);
4375 char *result_c = SvPV(result, n_a); /* convenience */
4376 char *out = result_c;
4386 SvREFCNT_dec(result);
4409 SvREFCNT_dec(result);
4415 SvCUR_set(result, out - result_c);
4419 /* pnum must be '\0' terminated */
4421 S_div128(pTHX_ SV *pnum, bool *done)
4424 char *s = SvPV(pnum, len);
4433 i = m * 10 + (*t - '0');
4435 r = (i >> 7); /* r < 10 */
4442 SvCUR_set(pnum, (STRLEN) (t - s));
4449 djSP; dMARK; dORIGMARK; dTARGET;
4450 register SV *cat = TARG;
4453 register char *pat = SvPVx(*++MARK, fromlen);
4455 register char *patend = pat + fromlen;
4460 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4461 static char *space10 = " ";
4463 /* These must not be in registers: */
4478 #ifdef PERL_NATINT_PACK
4479 int natint; /* native integer */
4484 sv_setpvn(cat, "", 0);
4486 while (pat < patend) {
4487 SV *lengthcode = Nullsv;
4488 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4489 datumtype = *pat++ & 0xFF;
4490 #ifdef PERL_NATINT_PACK
4493 if (isSPACE(datumtype)) {
4497 if (datumtype == 'U' && pat == patcopy+1)
4499 if (datumtype == '#') {
4500 while (pat < patend && *pat != '\n')
4505 char *natstr = "sSiIlL";
4507 if (strchr(natstr, datumtype)) {
4508 #ifdef PERL_NATINT_PACK
4514 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4517 len = strchr("@Xxu", datumtype) ? 0 : items;
4520 else if (isDIGIT(*pat)) {
4522 while (isDIGIT(*pat)) {
4523 len = (len * 10) + (*pat++ - '0');
4525 DIE(aTHX_ "Repeat count in pack overflows");
4532 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4533 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4534 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4535 ? *MARK : &PL_sv_no)
4536 + (*pat == 'Z' ? 1 : 0)));
4540 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4541 case ',': /* grandfather in commas but with a warning */
4542 if (commas++ == 0 && ckWARN(WARN_PACK))
4543 Perl_warner(aTHX_ WARN_PACK,
4544 "Invalid type in pack: '%c'", (int)datumtype);
4547 DIE(aTHX_ "%% may only be used in unpack");
4558 if (SvCUR(cat) < len)
4559 DIE(aTHX_ "X outside of string");
4566 sv_catpvn(cat, null10, 10);
4569 sv_catpvn(cat, null10, len);
4575 aptr = SvPV(fromstr, fromlen);
4576 if (pat[-1] == '*') {
4578 if (datumtype == 'Z')
4581 if (fromlen >= len) {
4582 sv_catpvn(cat, aptr, len);
4583 if (datumtype == 'Z')
4584 *(SvEND(cat)-1) = '\0';
4587 sv_catpvn(cat, aptr, fromlen);
4589 if (datumtype == 'A') {
4591 sv_catpvn(cat, space10, 10);
4594 sv_catpvn(cat, space10, len);
4598 sv_catpvn(cat, null10, 10);
4601 sv_catpvn(cat, null10, len);
4613 str = SvPV(fromstr, fromlen);
4617 SvCUR(cat) += (len+7)/8;
4618 SvGROW(cat, SvCUR(cat) + 1);
4619 aptr = SvPVX(cat) + aint;
4624 if (datumtype == 'B') {
4625 for (len = 0; len++ < aint;) {
4626 items |= *str++ & 1;
4630 *aptr++ = items & 0xff;
4636 for (len = 0; len++ < aint;) {
4642 *aptr++ = items & 0xff;
4648 if (datumtype == 'B')
4649 items <<= 7 - (aint & 7);
4651 items >>= 7 - (aint & 7);
4652 *aptr++ = items & 0xff;
4654 str = SvPVX(cat) + SvCUR(cat);
4669 str = SvPV(fromstr, fromlen);
4673 SvCUR(cat) += (len+1)/2;
4674 SvGROW(cat, SvCUR(cat) + 1);
4675 aptr = SvPVX(cat) + aint;
4680 if (datumtype == 'H') {
4681 for (len = 0; len++ < aint;) {
4683 items |= ((*str++ & 15) + 9) & 15;
4685 items |= *str++ & 15;
4689 *aptr++ = items & 0xff;
4695 for (len = 0; len++ < aint;) {
4697 items |= (((*str++ & 15) + 9) & 15) << 4;
4699 items |= (*str++ & 15) << 4;
4703 *aptr++ = items & 0xff;
4709 *aptr++ = items & 0xff;
4710 str = SvPVX(cat) + SvCUR(cat);
4721 aint = SvIV(fromstr);
4723 sv_catpvn(cat, &achar, sizeof(char));
4729 auint = SvUV(fromstr);
4730 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4731 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4736 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4741 afloat = (float)SvNV(fromstr);
4742 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4749 adouble = (double)SvNV(fromstr);
4750 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4756 ashort = (I16)SvIV(fromstr);
4758 ashort = PerlSock_htons(ashort);
4760 CAT16(cat, &ashort);
4766 ashort = (I16)SvIV(fromstr);
4768 ashort = htovs(ashort);
4770 CAT16(cat, &ashort);
4774 #if SHORTSIZE != SIZE16
4776 unsigned short aushort;
4780 aushort = SvUV(fromstr);
4781 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4791 aushort = (U16)SvUV(fromstr);
4792 CAT16(cat, &aushort);
4798 #if SHORTSIZE != SIZE16
4804 ashort = SvIV(fromstr);
4805 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4813 ashort = (I16)SvIV(fromstr);
4814 CAT16(cat, &ashort);
4821 auint = SvUV(fromstr);
4822 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4828 adouble = Perl_floor(SvNV(fromstr));
4831 DIE(aTHX_ "Cannot compress negative numbers");
4834 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4835 adouble <= 0xffffffff
4837 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4838 adouble <= UV_MAX_cxux
4845 char buf[1 + sizeof(UV)];
4846 char *in = buf + sizeof(buf);
4847 UV auv = U_V(adouble);
4850 *--in = (auv & 0x7f) | 0x80;
4853 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4854 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4856 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4857 char *from, *result, *in;
4862 /* Copy string and check for compliance */
4863 from = SvPV(fromstr, len);
4864 if ((norm = is_an_int(from, len)) == NULL)
4865 DIE(aTHX_ "can compress only unsigned integer");
4867 New('w', result, len, char);
4871 *--in = div128(norm, &done) | 0x80;
4872 result[len - 1] &= 0x7F; /* clear continue bit */
4873 sv_catpvn(cat, in, (result + len) - in);
4875 SvREFCNT_dec(norm); /* free norm */
4877 else if (SvNOKp(fromstr)) {
4878 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4879 char *in = buf + sizeof(buf);
4882 double next = floor(adouble / 128);
4883 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4884 if (in <= buf) /* this cannot happen ;-) */
4885 DIE(aTHX_ "Cannot compress integer");
4888 } while (adouble > 0);
4889 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4890 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4893 DIE(aTHX_ "Cannot compress non integer");
4899 aint = SvIV(fromstr);
4900 sv_catpvn(cat, (char*)&aint, sizeof(int));
4906 aulong = SvUV(fromstr);
4908 aulong = PerlSock_htonl(aulong);
4910 CAT32(cat, &aulong);
4916 aulong = SvUV(fromstr);
4918 aulong = htovl(aulong);
4920 CAT32(cat, &aulong);
4924 #if LONGSIZE != SIZE32
4926 unsigned long aulong;
4930 aulong = SvUV(fromstr);
4931 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4939 aulong = SvUV(fromstr);
4940 CAT32(cat, &aulong);
4945 #if LONGSIZE != SIZE32
4951 along = SvIV(fromstr);
4952 sv_catpvn(cat, (char *)&along, sizeof(long));
4960 along = SvIV(fromstr);
4969 auquad = (Uquad_t)SvUV(fromstr);
4970 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4976 aquad = (Quad_t)SvIV(fromstr);
4977 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4982 len = 1; /* assume SV is correct length */
4987 if (fromstr == &PL_sv_undef)
4991 /* XXX better yet, could spirit away the string to
4992 * a safe spot and hang on to it until the result
4993 * of pack() (and all copies of the result) are
4996 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4997 || (SvPADTMP(fromstr)
4998 && !SvREADONLY(fromstr))))
5000 Perl_warner(aTHX_ WARN_PACK,
5001 "Attempt to pack pointer to temporary value");
5003 if (SvPOK(fromstr) || SvNIOK(fromstr))
5004 aptr = SvPV(fromstr,n_a);
5006 aptr = SvPV_force(fromstr,n_a);
5008 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5013 aptr = SvPV(fromstr, fromlen);
5014 SvGROW(cat, fromlen * 4 / 3);
5019 while (fromlen > 0) {
5026 doencodes(cat, aptr, todo);
5045 register IV limit = POPi; /* note, negative is forever */
5047 bool doutf8 = DO_UTF8(sv);
5049 register char *s = SvPV(sv, len);
5050 char *strend = s + len;
5052 register REGEXP *rx;
5056 I32 maxiters = (strend - s) + 10;
5059 I32 origlimit = limit;
5062 AV *oldstack = PL_curstack;
5063 I32 gimme = GIMME_V;
5064 I32 oldsave = PL_savestack_ix;
5065 I32 make_mortal = 1;
5066 MAGIC *mg = (MAGIC *) NULL;
5069 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5074 DIE(aTHX_ "panic: do_split");
5075 rx = pm->op_pmregexp;
5077 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5078 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5080 if (pm->op_pmreplroot) {
5082 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5084 ary = GvAVn((GV*)pm->op_pmreplroot);
5087 else if (gimme != G_ARRAY)
5089 ary = (AV*)PL_curpad[0];
5091 ary = GvAVn(PL_defgv);
5092 #endif /* USE_THREADS */
5095 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5101 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5103 XPUSHs(SvTIED_obj((SV*)ary, mg));
5109 for (i = AvFILLp(ary); i >= 0; i--)
5110 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5112 /* temporarily switch stacks */
5113 SWITCHSTACK(PL_curstack, ary);
5117 base = SP - PL_stack_base;
5119 if (pm->op_pmflags & PMf_SKIPWHITE) {
5120 if (pm->op_pmflags & PMf_LOCALE) {
5121 while (isSPACE_LC(*s))
5129 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5130 SAVEINT(PL_multiline);
5131 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5135 limit = maxiters + 2;
5136 if (pm->op_pmflags & PMf_WHITE) {
5139 while (m < strend &&
5140 !((pm->op_pmflags & PMf_LOCALE)
5141 ? isSPACE_LC(*m) : isSPACE(*m)))
5146 dstr = NEWSV(30, m-s);
5147 sv_setpvn(dstr, s, m-s);
5151 (void)SvUTF8_on(dstr);
5155 while (s < strend &&
5156 ((pm->op_pmflags & PMf_LOCALE)
5157 ? isSPACE_LC(*s) : isSPACE(*s)))
5161 else if (strEQ("^", rx->precomp)) {
5164 for (m = s; m < strend && *m != '\n'; m++) ;
5168 dstr = NEWSV(30, m-s);
5169 sv_setpvn(dstr, s, m-s);
5173 (void)SvUTF8_on(dstr);
5178 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5179 && (rx->reganch & ROPT_CHECK_ALL)
5180 && !(rx->reganch & ROPT_ANCH)) {
5181 int tail = (rx->reganch & RE_INTUIT_TAIL);
5182 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5185 if (len == 1 && !tail) {
5187 char c = *SvPV(csv, n_a);
5190 for (m = s; m < strend && *m != c; m++) ;
5193 dstr = NEWSV(30, m-s);
5194 sv_setpvn(dstr, s, m-s);
5198 (void)SvUTF8_on(dstr);
5200 /* The rx->minlen is in characters but we want to step
5201 * s ahead by bytes. */
5202 s = m + (doutf8 ? SvCUR(csv) : len);
5207 while (s < strend && --limit &&
5208 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5209 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5212 dstr = NEWSV(31, m-s);
5213 sv_setpvn(dstr, s, m-s);
5217 (void)SvUTF8_on(dstr);
5219 /* The rx->minlen is in characters but we want to step
5220 * s ahead by bytes. */
5221 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5226 maxiters += (strend - s) * rx->nparens;
5227 while (s < strend && --limit
5228 /* && (!rx->check_substr
5229 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5231 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5232 1 /* minend */, sv, NULL, 0))
5234 TAINT_IF(RX_MATCH_TAINTED(rx));
5235 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5240 strend = s + (strend - m);
5242 m = rx->startp[0] + orig;
5243 dstr = NEWSV(32, m-s);
5244 sv_setpvn(dstr, s, m-s);
5248 (void)SvUTF8_on(dstr);
5251 for (i = 1; i <= rx->nparens; i++) {
5252 s = rx->startp[i] + orig;
5253 m = rx->endp[i] + orig;
5255 dstr = NEWSV(33, m-s);
5256 sv_setpvn(dstr, s, m-s);
5259 dstr = NEWSV(33, 0);
5263 (void)SvUTF8_on(dstr);
5267 s = rx->endp[0] + orig;
5271 LEAVE_SCOPE(oldsave);
5272 iters = (SP - PL_stack_base) - base;
5273 if (iters > maxiters)
5274 DIE(aTHX_ "Split loop");
5276 /* keep field after final delim? */
5277 if (s < strend || (iters && origlimit)) {
5278 STRLEN l = strend - s;
5279 dstr = NEWSV(34, l);
5280 sv_setpvn(dstr, s, l);
5284 (void)SvUTF8_on(dstr);
5288 else if (!origlimit) {
5289 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5295 SWITCHSTACK(ary, oldstack);
5296 if (SvSMAGICAL(ary)) {
5301 if (gimme == G_ARRAY) {
5303 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5311 call_method("PUSH",G_SCALAR|G_DISCARD);
5314 if (gimme == G_ARRAY) {
5315 /* EXTEND should not be needed - we just popped them */
5317 for (i=0; i < iters; i++) {
5318 SV **svp = av_fetch(ary, i, FALSE);
5319 PUSHs((svp) ? *svp : &PL_sv_undef);
5326 if (gimme == G_ARRAY)
5329 if (iters || !pm->op_pmreplroot) {
5339 Perl_unlock_condpair(pTHX_ void *svv)
5342 MAGIC *mg = mg_find((SV*)svv, 'm');
5345 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5346 MUTEX_LOCK(MgMUTEXP(mg));
5347 if (MgOWNER(mg) != thr)
5348 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5350 COND_SIGNAL(MgOWNERCONDP(mg));
5351 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5352 PTR2UV(thr), PTR2UV(svv));)
5353 MUTEX_UNLOCK(MgMUTEXP(mg));
5355 #endif /* USE_THREADS */
5364 #endif /* USE_THREADS */
5365 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5366 || SvTYPE(retsv) == SVt_PVCV) {
5367 retsv = refto(retsv);
5378 if (PL_op->op_private & OPpLVAL_INTRO)
5379 PUSHs(*save_threadsv(PL_op->op_targ));
5381 PUSHs(THREADSV(PL_op->op_targ));
5384 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5385 #endif /* USE_THREADS */