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 && !seen_question) {
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
1795 #ifndef PERL_NO_DEV_RANDOM
1800 # include <starlet.h>
1801 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1802 * in 100-ns units, typically incremented ever 10 ms. */
1803 unsigned int when[2];
1805 # ifdef HAS_GETTIMEOFDAY
1806 struct timeval when;
1812 /* This test is an escape hatch, this symbol isn't set by Configure. */
1813 #ifndef PERL_NO_DEV_RANDOM
1814 #ifndef PERL_RANDOM_DEVICE
1815 /* /dev/random isn't used by default because reads from it will block
1816 * if there isn't enough entropy available. You can compile with
1817 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1818 * is enough real entropy to fill the seed. */
1819 # define PERL_RANDOM_DEVICE "/dev/urandom"
1821 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1823 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1832 _ckvmssts(sys$gettim(when));
1833 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1835 # ifdef HAS_GETTIMEOFDAY
1836 gettimeofday(&when,(struct timezone *) 0);
1837 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1840 u = (U32)SEED_C1 * when;
1843 u += SEED_C3 * (U32)PerlProc_getpid();
1844 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1845 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1846 u += SEED_C5 * (U32)PTR2UV(&when);
1853 djSP; dTARGET; tryAMAGICun(exp);
1857 value = Perl_exp(value);
1865 djSP; dTARGET; tryAMAGICun(log);
1870 SET_NUMERIC_STANDARD();
1871 DIE(aTHX_ "Can't take log of %g", value);
1873 value = Perl_log(value);
1881 djSP; dTARGET; tryAMAGICun(sqrt);
1886 SET_NUMERIC_STANDARD();
1887 DIE(aTHX_ "Can't take sqrt of %g", value);
1889 value = Perl_sqrt(value);
1902 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1908 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1909 (void)Perl_modf(value, &value);
1911 double tmp = (double)value;
1912 (void)Perl_modf(tmp, &tmp);
1917 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1918 (void)Perl_modf(-value, &value);
1921 double tmp = (double)value;
1922 (void)Perl_modf(-tmp, &tmp);
1938 djSP; dTARGET; tryAMAGICun(abs);
1943 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1944 (iv = SvIVX(TOPs)) != IV_MIN) {
1966 argtype = 1; /* allow underscores */
1967 XPUSHn(scan_hex(tmps, 99, &argtype));
1980 while (*tmps && isSPACE(*tmps))
1984 argtype = 1; /* allow underscores */
1986 value = scan_hex(++tmps, 99, &argtype);
1987 else if (*tmps == 'b')
1988 value = scan_bin(++tmps, 99, &argtype);
1990 value = scan_oct(tmps, 99, &argtype);
2003 SETi(sv_len_utf8(sv));
2019 I32 lvalue = PL_op->op_flags & OPf_MOD;
2021 I32 arybase = PL_curcop->cop_arybase;
2025 SvTAINTED_off(TARG); /* decontaminate */
2026 SvUTF8_off(TARG); /* decontaminate */
2030 repl = SvPV(sv, repl_len);
2037 tmps = SvPV(sv, curlen);
2039 utfcurlen = sv_len_utf8(sv);
2040 if (utfcurlen == curlen)
2048 if (pos >= arybase) {
2066 else if (len >= 0) {
2068 if (rem > (I32)curlen)
2083 Perl_croak(aTHX_ "substr outside of string");
2084 if (ckWARN(WARN_SUBSTR))
2085 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2090 sv_pos_u2b(sv, &pos, &rem);
2092 sv_setpvn(TARG, tmps, rem);
2096 sv_insert(sv, pos, rem, repl, repl_len);
2097 else if (lvalue) { /* it's an lvalue! */
2098 if (!SvGMAGICAL(sv)) {
2102 if (ckWARN(WARN_SUBSTR))
2103 Perl_warner(aTHX_ WARN_SUBSTR,
2104 "Attempt to use reference as lvalue in substr");
2106 if (SvOK(sv)) /* is it defined ? */
2107 (void)SvPOK_only_UTF8(sv);
2109 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2112 if (SvTYPE(TARG) < SVt_PVLV) {
2113 sv_upgrade(TARG, SVt_PVLV);
2114 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2118 if (LvTARG(TARG) != sv) {
2120 SvREFCNT_dec(LvTARG(TARG));
2121 LvTARG(TARG) = SvREFCNT_inc(sv);
2123 LvTARGOFF(TARG) = pos;
2124 LvTARGLEN(TARG) = rem;
2128 PUSHs(TARG); /* avoid SvSETMAGIC here */
2135 register IV size = POPi;
2136 register IV offset = POPi;
2137 register SV *src = POPs;
2138 I32 lvalue = PL_op->op_flags & OPf_MOD;
2140 SvTAINTED_off(TARG); /* decontaminate */
2141 if (lvalue) { /* it's an lvalue! */
2142 if (SvTYPE(TARG) < SVt_PVLV) {
2143 sv_upgrade(TARG, SVt_PVLV);
2144 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2147 if (LvTARG(TARG) != src) {
2149 SvREFCNT_dec(LvTARG(TARG));
2150 LvTARG(TARG) = SvREFCNT_inc(src);
2152 LvTARGOFF(TARG) = offset;
2153 LvTARGLEN(TARG) = size;
2156 sv_setuv(TARG, do_vecget(src, offset, size));
2171 I32 arybase = PL_curcop->cop_arybase;
2176 offset = POPi - arybase;
2179 tmps = SvPV(big, biglen);
2180 if (offset > 0 && DO_UTF8(big))
2181 sv_pos_u2b(big, &offset, 0);
2184 else if (offset > biglen)
2186 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2187 (unsigned char*)tmps + biglen, little, 0)))
2190 retval = tmps2 - tmps;
2191 if (retval > 0 && DO_UTF8(big))
2192 sv_pos_b2u(big, &retval);
2193 PUSHi(retval + arybase);
2208 I32 arybase = PL_curcop->cop_arybase;
2214 tmps2 = SvPV(little, llen);
2215 tmps = SvPV(big, blen);
2219 if (offset > 0 && DO_UTF8(big))
2220 sv_pos_u2b(big, &offset, 0);
2221 offset = offset - arybase + llen;
2225 else if (offset > blen)
2227 if (!(tmps2 = rninstr(tmps, tmps + offset,
2228 tmps2, tmps2 + llen)))
2231 retval = tmps2 - tmps;
2232 if (retval > 0 && DO_UTF8(big))
2233 sv_pos_b2u(big, &retval);
2234 PUSHi(retval + arybase);
2240 djSP; dMARK; dORIGMARK; dTARGET;
2241 do_sprintf(TARG, SP-MARK, MARK+1);
2242 TAINT_IF(SvTAINTED(TARG));
2254 U8 *tmps = (U8*)SvPVx(tmpsv, len);
2257 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2258 value = utf8_to_uv(tmps, len, &retlen, 0);
2260 value = (UV)(*tmps & 255);
2271 (void)SvUPGRADE(TARG,SVt_PV);
2273 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2274 SvGROW(TARG, UTF8_MAXLEN+1);
2276 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2277 SvCUR_set(TARG, tmps - SvPVX(TARG));
2279 (void)SvPOK_only(TARG);
2290 (void)SvPOK_only(TARG);
2297 djSP; dTARGET; dPOPTOPssrl;
2300 char *tmps = SvPV(left, n_a);
2302 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2304 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2308 "The crypt() function is unimplemented due to excessive paranoia.");
2321 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2323 U8 tmpbuf[UTF8_MAXLEN+1];
2325 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2327 if (PL_op->op_private & OPpLOCALE) {
2330 uv = toTITLE_LC_uni(uv);
2333 uv = toTITLE_utf8(s);
2335 tend = uv_to_utf8(tmpbuf, uv);
2337 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2339 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2340 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2345 s = (U8*)SvPV_force(sv, slen);
2346 Copy(tmpbuf, s, ulen, U8);
2350 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2352 SvUTF8_off(TARG); /* decontaminate */
2357 s = (U8*)SvPV_force(sv, slen);
2359 if (PL_op->op_private & OPpLOCALE) {
2362 *s = toUPPER_LC(*s);
2380 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2382 U8 tmpbuf[UTF8_MAXLEN+1];
2384 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2386 if (PL_op->op_private & OPpLOCALE) {
2389 uv = toLOWER_LC_uni(uv);
2392 uv = toLOWER_utf8(s);
2394 tend = uv_to_utf8(tmpbuf, uv);
2396 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2398 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2399 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2404 s = (U8*)SvPV_force(sv, slen);
2405 Copy(tmpbuf, s, ulen, U8);
2409 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2411 SvUTF8_off(TARG); /* decontaminate */
2416 s = (U8*)SvPV_force(sv, slen);
2418 if (PL_op->op_private & OPpLOCALE) {
2421 *s = toLOWER_LC(*s);
2445 s = (U8*)SvPV(sv,len);
2447 SvUTF8_off(TARG); /* decontaminate */
2448 sv_setpvn(TARG, "", 0);
2452 (void)SvUPGRADE(TARG, SVt_PV);
2453 SvGROW(TARG, (len * 2) + 1);
2454 (void)SvPOK_only(TARG);
2455 d = (U8*)SvPVX(TARG);
2457 if (PL_op->op_private & OPpLOCALE) {
2461 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2467 d = uv_to_utf8(d, toUPPER_utf8( s ));
2473 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2478 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2480 SvUTF8_off(TARG); /* decontaminate */
2485 s = (U8*)SvPV_force(sv, len);
2487 register U8 *send = s + len;
2489 if (PL_op->op_private & OPpLOCALE) {
2492 for (; s < send; s++)
2493 *s = toUPPER_LC(*s);
2496 for (; s < send; s++)
2519 s = (U8*)SvPV(sv,len);
2521 SvUTF8_off(TARG); /* decontaminate */
2522 sv_setpvn(TARG, "", 0);
2526 (void)SvUPGRADE(TARG, SVt_PV);
2527 SvGROW(TARG, (len * 2) + 1);
2528 (void)SvPOK_only(TARG);
2529 d = (U8*)SvPVX(TARG);
2531 if (PL_op->op_private & OPpLOCALE) {
2535 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2541 d = uv_to_utf8(d, toLOWER_utf8(s));
2547 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2552 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2554 SvUTF8_off(TARG); /* decontaminate */
2560 s = (U8*)SvPV_force(sv, len);
2562 register U8 *send = s + len;
2564 if (PL_op->op_private & OPpLOCALE) {
2567 for (; s < send; s++)
2568 *s = toLOWER_LC(*s);
2571 for (; s < send; s++)
2586 register char *s = SvPV(sv,len);
2589 SvUTF8_off(TARG); /* decontaminate */
2591 (void)SvUPGRADE(TARG, SVt_PV);
2592 SvGROW(TARG, (len * 2) + 1);
2597 STRLEN ulen = UTF8SKIP(s);
2621 SvCUR_set(TARG, d - SvPVX(TARG));
2622 (void)SvPOK_only_UTF8(TARG);
2625 sv_setpvn(TARG, s, len);
2627 if (SvSMAGICAL(TARG))
2636 djSP; dMARK; dORIGMARK;
2638 register AV* av = (AV*)POPs;
2639 register I32 lval = PL_op->op_flags & OPf_MOD;
2640 I32 arybase = PL_curcop->cop_arybase;
2643 if (SvTYPE(av) == SVt_PVAV) {
2644 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2646 for (svp = MARK + 1; svp <= SP; svp++) {
2651 if (max > AvMAX(av))
2654 while (++MARK <= SP) {
2655 elem = SvIVx(*MARK);
2659 svp = av_fetch(av, elem, lval);
2661 if (!svp || *svp == &PL_sv_undef)
2662 DIE(aTHX_ PL_no_aelem, elem);
2663 if (PL_op->op_private & OPpLVAL_INTRO)
2664 save_aelem(av, elem, svp);
2666 *MARK = svp ? *svp : &PL_sv_undef;
2669 if (GIMME != G_ARRAY) {
2677 /* Associative arrays. */
2682 HV *hash = (HV*)POPs;
2684 I32 gimme = GIMME_V;
2685 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2688 /* might clobber stack_sp */
2689 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2694 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2695 if (gimme == G_ARRAY) {
2698 /* might clobber stack_sp */
2700 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2705 else if (gimme == G_SCALAR)
2724 I32 gimme = GIMME_V;
2725 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2729 if (PL_op->op_private & OPpSLICE) {
2733 hvtype = SvTYPE(hv);
2734 if (hvtype == SVt_PVHV) { /* hash element */
2735 while (++MARK <= SP) {
2736 sv = hv_delete_ent(hv, *MARK, discard, 0);
2737 *MARK = sv ? sv : &PL_sv_undef;
2740 else if (hvtype == SVt_PVAV) {
2741 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2742 while (++MARK <= SP) {
2743 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2744 *MARK = sv ? sv : &PL_sv_undef;
2747 else { /* pseudo-hash element */
2748 while (++MARK <= SP) {
2749 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2750 *MARK = sv ? sv : &PL_sv_undef;
2755 DIE(aTHX_ "Not a HASH reference");
2758 else if (gimme == G_SCALAR) {
2767 if (SvTYPE(hv) == SVt_PVHV)
2768 sv = hv_delete_ent(hv, keysv, discard, 0);
2769 else if (SvTYPE(hv) == SVt_PVAV) {
2770 if (PL_op->op_flags & OPf_SPECIAL)
2771 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2773 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2776 DIE(aTHX_ "Not a HASH reference");
2791 if (PL_op->op_private & OPpEXISTS_SUB) {
2795 cv = sv_2cv(sv, &hv, &gv, FALSE);
2798 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2804 if (SvTYPE(hv) == SVt_PVHV) {
2805 if (hv_exists_ent(hv, tmpsv, 0))
2808 else if (SvTYPE(hv) == SVt_PVAV) {
2809 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2810 if (av_exists((AV*)hv, SvIV(tmpsv)))
2813 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2817 DIE(aTHX_ "Not a HASH reference");
2824 djSP; dMARK; dORIGMARK;
2825 register HV *hv = (HV*)POPs;
2826 register I32 lval = PL_op->op_flags & OPf_MOD;
2827 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2829 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2830 DIE(aTHX_ "Can't localize pseudo-hash element");
2832 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2833 while (++MARK <= SP) {
2837 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2838 svp = he ? &HeVAL(he) : 0;
2841 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2844 if (!svp || *svp == &PL_sv_undef) {
2846 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2848 if (PL_op->op_private & OPpLVAL_INTRO)
2849 save_helem(hv, keysv, svp);
2851 *MARK = svp ? *svp : &PL_sv_undef;
2854 if (GIMME != G_ARRAY) {
2862 /* List operators. */
2867 if (GIMME != G_ARRAY) {
2869 *MARK = *SP; /* unwanted list, return last item */
2871 *MARK = &PL_sv_undef;
2880 SV **lastrelem = PL_stack_sp;
2881 SV **lastlelem = PL_stack_base + POPMARK;
2882 SV **firstlelem = PL_stack_base + POPMARK + 1;
2883 register SV **firstrelem = lastlelem + 1;
2884 I32 arybase = PL_curcop->cop_arybase;
2885 I32 lval = PL_op->op_flags & OPf_MOD;
2886 I32 is_something_there = lval;
2888 register I32 max = lastrelem - lastlelem;
2889 register SV **lelem;
2892 if (GIMME != G_ARRAY) {
2893 ix = SvIVx(*lastlelem);
2898 if (ix < 0 || ix >= max)
2899 *firstlelem = &PL_sv_undef;
2901 *firstlelem = firstrelem[ix];
2907 SP = firstlelem - 1;
2911 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2917 if (ix < 0 || ix >= max)
2918 *lelem = &PL_sv_undef;
2920 is_something_there = TRUE;
2921 if (!(*lelem = firstrelem[ix]))
2922 *lelem = &PL_sv_undef;
2925 if (is_something_there)
2928 SP = firstlelem - 1;
2934 djSP; dMARK; dORIGMARK;
2935 I32 items = SP - MARK;
2936 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2937 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2944 djSP; dMARK; dORIGMARK;
2945 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2949 SV *val = NEWSV(46, 0);
2951 sv_setsv(val, *++MARK);
2952 else if (ckWARN(WARN_MISC))
2953 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2954 (void)hv_store_ent(hv,key,val,0);
2963 djSP; dMARK; dORIGMARK;
2964 register AV *ary = (AV*)*++MARK;
2968 register I32 offset;
2969 register I32 length;
2976 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2977 *MARK-- = SvTIED_obj((SV*)ary, mg);
2981 call_method("SPLICE",GIMME_V);
2990 offset = i = SvIVx(*MARK);
2992 offset += AvFILLp(ary) + 1;
2994 offset -= PL_curcop->cop_arybase;
2996 DIE(aTHX_ PL_no_aelem, i);
2998 length = SvIVx(*MARK++);
3000 length += AvFILLp(ary) - offset + 1;
3006 length = AvMAX(ary) + 1; /* close enough to infinity */
3010 length = AvMAX(ary) + 1;
3012 if (offset > AvFILLp(ary) + 1)
3013 offset = AvFILLp(ary) + 1;
3014 after = AvFILLp(ary) + 1 - (offset + length);
3015 if (after < 0) { /* not that much array */
3016 length += after; /* offset+length now in array */
3022 /* At this point, MARK .. SP-1 is our new LIST */
3025 diff = newlen - length;
3026 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3029 if (diff < 0) { /* shrinking the area */
3031 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3032 Copy(MARK, tmparyval, newlen, SV*);
3035 MARK = ORIGMARK + 1;
3036 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3037 MEXTEND(MARK, length);
3038 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3040 EXTEND_MORTAL(length);
3041 for (i = length, dst = MARK; i; i--) {
3042 sv_2mortal(*dst); /* free them eventualy */
3049 *MARK = AvARRAY(ary)[offset+length-1];
3052 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3053 SvREFCNT_dec(*dst++); /* free them now */
3056 AvFILLp(ary) += diff;
3058 /* pull up or down? */
3060 if (offset < after) { /* easier to pull up */
3061 if (offset) { /* esp. if nothing to pull */
3062 src = &AvARRAY(ary)[offset-1];
3063 dst = src - diff; /* diff is negative */
3064 for (i = offset; i > 0; i--) /* can't trust Copy */
3068 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3072 if (after) { /* anything to pull down? */
3073 src = AvARRAY(ary) + offset + length;
3074 dst = src + diff; /* diff is negative */
3075 Move(src, dst, after, SV*);
3077 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3078 /* avoid later double free */
3082 dst[--i] = &PL_sv_undef;
3085 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3087 *dst = NEWSV(46, 0);
3088 sv_setsv(*dst++, *src++);
3090 Safefree(tmparyval);
3093 else { /* no, expanding (or same) */
3095 New(452, tmparyval, length, SV*); /* so remember deletion */
3096 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3099 if (diff > 0) { /* expanding */
3101 /* push up or down? */
3103 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3107 Move(src, dst, offset, SV*);
3109 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3111 AvFILLp(ary) += diff;
3114 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3115 av_extend(ary, AvFILLp(ary) + diff);
3116 AvFILLp(ary) += diff;
3119 dst = AvARRAY(ary) + AvFILLp(ary);
3121 for (i = after; i; i--) {
3128 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3129 *dst = NEWSV(46, 0);
3130 sv_setsv(*dst++, *src++);
3132 MARK = ORIGMARK + 1;
3133 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3135 Copy(tmparyval, MARK, length, SV*);
3137 EXTEND_MORTAL(length);
3138 for (i = length, dst = MARK; i; i--) {
3139 sv_2mortal(*dst); /* free them eventualy */
3143 Safefree(tmparyval);
3147 else if (length--) {
3148 *MARK = tmparyval[length];
3151 while (length-- > 0)
3152 SvREFCNT_dec(tmparyval[length]);
3154 Safefree(tmparyval);
3157 *MARK = &PL_sv_undef;
3165 djSP; dMARK; dORIGMARK; dTARGET;
3166 register AV *ary = (AV*)*++MARK;
3167 register SV *sv = &PL_sv_undef;
3170 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3171 *MARK-- = SvTIED_obj((SV*)ary, mg);
3175 call_method("PUSH",G_SCALAR|G_DISCARD);
3180 /* Why no pre-extend of ary here ? */
3181 for (++MARK; MARK <= SP; MARK++) {
3184 sv_setsv(sv, *MARK);
3189 PUSHi( AvFILL(ary) + 1 );
3197 SV *sv = av_pop(av);
3199 (void)sv_2mortal(sv);
3208 SV *sv = av_shift(av);
3213 (void)sv_2mortal(sv);
3220 djSP; dMARK; dORIGMARK; dTARGET;
3221 register AV *ary = (AV*)*++MARK;
3226 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3227 *MARK-- = SvTIED_obj((SV*)ary, mg);
3231 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3236 av_unshift(ary, SP - MARK);
3239 sv_setsv(sv, *++MARK);
3240 (void)av_store(ary, i++, sv);
3244 PUSHi( AvFILL(ary) + 1 );
3254 if (GIMME == G_ARRAY) {
3261 /* safe as long as stack cannot get extended in the above */
3266 register char *down;
3271 SvUTF8_off(TARG); /* decontaminate */
3273 do_join(TARG, &PL_sv_no, MARK, SP);
3275 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3276 up = SvPV_force(TARG, len);
3278 if (DO_UTF8(TARG)) { /* first reverse each character */
3279 U8* s = (U8*)SvPVX(TARG);
3280 U8* send = (U8*)(s + len);
3289 down = (char*)(s - 1);
3290 if (s > send || !((*down & 0xc0) == 0x80)) {
3291 if (ckWARN_d(WARN_UTF8))
3292 Perl_warner(aTHX_ WARN_UTF8,
3293 "Malformed UTF-8 character");
3305 down = SvPVX(TARG) + len - 1;
3311 (void)SvPOK_only_UTF8(TARG);
3320 S_mul128(pTHX_ SV *sv, U8 m)
3323 char *s = SvPV(sv, len);
3327 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3328 SV *tmpNew = newSVpvn("0000000000", 10);
3330 sv_catsv(tmpNew, sv);
3331 SvREFCNT_dec(sv); /* free old sv */
3336 while (!*t) /* trailing '\0'? */
3339 i = ((*t - '0') << 7) + m;
3340 *(t--) = '0' + (i % 10);
3346 /* Explosives and implosives. */
3348 #if 'I' == 73 && 'J' == 74
3349 /* On an ASCII/ISO kind of system */
3350 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3353 Some other sort of character set - use memchr() so we don't match
3356 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3363 I32 start_sp_offset = SP - PL_stack_base;
3364 I32 gimme = GIMME_V;
3368 register char *pat = SvPV(left, llen);
3369 register char *s = SvPV(right, rlen);
3370 char *strend = s + rlen;
3372 register char *patend = pat + llen;
3378 /* These must not be in registers: */
3395 register U32 culong;
3399 #ifdef PERL_NATINT_PACK
3400 int natint; /* native integer */
3401 int unatint; /* unsigned native integer */
3404 if (gimme != G_ARRAY) { /* arrange to do first one only */
3406 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3407 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3409 while (isDIGIT(*patend) || *patend == '*')
3415 while (pat < patend) {
3417 datumtype = *pat++ & 0xFF;
3418 #ifdef PERL_NATINT_PACK
3421 if (isSPACE(datumtype))
3423 if (datumtype == '#') {
3424 while (pat < patend && *pat != '\n')
3429 char *natstr = "sSiIlL";
3431 if (strchr(natstr, datumtype)) {
3432 #ifdef PERL_NATINT_PACK
3438 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3443 else if (*pat == '*') {
3444 len = strend - strbeg; /* long enough */
3448 else if (isDIGIT(*pat)) {
3450 while (isDIGIT(*pat)) {
3451 len = (len * 10) + (*pat++ - '0');
3453 DIE(aTHX_ "Repeat count in unpack overflows");
3457 len = (datumtype != '@');
3461 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3462 case ',': /* grandfather in commas but with a warning */
3463 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3464 Perl_warner(aTHX_ WARN_UNPACK,
3465 "Invalid type in unpack: '%c'", (int)datumtype);
3468 if (len == 1 && pat[-1] != '1')
3477 if (len > strend - strbeg)
3478 DIE(aTHX_ "@ outside of string");
3482 if (len > s - strbeg)
3483 DIE(aTHX_ "X outside of string");
3487 if (len > strend - s)
3488 DIE(aTHX_ "x outside of string");
3492 if (start_sp_offset >= SP - PL_stack_base)
3493 DIE(aTHX_ "/ must follow a numeric type");
3496 pat++; /* ignore '*' for compatibility with pack */
3498 DIE(aTHX_ "/ cannot take a count" );
3505 if (len > strend - s)
3508 goto uchar_checksum;
3509 sv = NEWSV(35, len);
3510 sv_setpvn(sv, s, len);
3512 if (datumtype == 'A' || datumtype == 'Z') {
3513 aptr = s; /* borrow register */
3514 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3519 else { /* 'A' strips both nulls and spaces */
3520 s = SvPVX(sv) + len - 1;
3521 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3525 SvCUR_set(sv, s - SvPVX(sv));
3526 s = aptr; /* unborrow register */
3528 XPUSHs(sv_2mortal(sv));
3532 if (star || len > (strend - s) * 8)
3533 len = (strend - s) * 8;
3536 Newz(601, PL_bitcount, 256, char);
3537 for (bits = 1; bits < 256; bits++) {
3538 if (bits & 1) PL_bitcount[bits]++;
3539 if (bits & 2) PL_bitcount[bits]++;
3540 if (bits & 4) PL_bitcount[bits]++;
3541 if (bits & 8) PL_bitcount[bits]++;
3542 if (bits & 16) PL_bitcount[bits]++;
3543 if (bits & 32) PL_bitcount[bits]++;
3544 if (bits & 64) PL_bitcount[bits]++;
3545 if (bits & 128) PL_bitcount[bits]++;
3549 culong += PL_bitcount[*(unsigned char*)s++];
3554 if (datumtype == 'b') {
3556 if (bits & 1) culong++;
3562 if (bits & 128) culong++;
3569 sv = NEWSV(35, len + 1);
3573 if (datumtype == 'b') {
3575 for (len = 0; len < aint; len++) {
3576 if (len & 7) /*SUPPRESS 595*/
3580 *str++ = '0' + (bits & 1);
3585 for (len = 0; len < aint; len++) {
3590 *str++ = '0' + ((bits & 128) != 0);
3594 XPUSHs(sv_2mortal(sv));
3598 if (star || len > (strend - s) * 2)
3599 len = (strend - s) * 2;
3600 sv = NEWSV(35, len + 1);
3604 if (datumtype == 'h') {
3606 for (len = 0; len < aint; len++) {
3611 *str++ = PL_hexdigit[bits & 15];
3616 for (len = 0; len < aint; len++) {
3621 *str++ = PL_hexdigit[(bits >> 4) & 15];
3625 XPUSHs(sv_2mortal(sv));
3628 if (len > strend - s)
3633 if (aint >= 128) /* fake up signed chars */
3643 if (aint >= 128) /* fake up signed chars */
3646 sv_setiv(sv, (IV)aint);
3647 PUSHs(sv_2mortal(sv));
3652 if (len > strend - s)
3667 sv_setiv(sv, (IV)auint);
3668 PUSHs(sv_2mortal(sv));
3673 if (len > strend - s)
3676 while (len-- > 0 && s < strend) {
3678 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3682 cdouble += (NV)auint;
3690 while (len-- > 0 && s < strend) {
3692 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3696 sv_setuv(sv, (UV)auint);
3697 PUSHs(sv_2mortal(sv));
3702 #if SHORTSIZE == SIZE16
3703 along = (strend - s) / SIZE16;
3705 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3710 #if SHORTSIZE != SIZE16
3714 COPYNN(s, &ashort, sizeof(short));
3725 #if SHORTSIZE > SIZE16
3737 #if SHORTSIZE != SIZE16
3741 COPYNN(s, &ashort, sizeof(short));
3744 sv_setiv(sv, (IV)ashort);
3745 PUSHs(sv_2mortal(sv));
3753 #if SHORTSIZE > SIZE16
3759 sv_setiv(sv, (IV)ashort);
3760 PUSHs(sv_2mortal(sv));
3768 #if SHORTSIZE == SIZE16
3769 along = (strend - s) / SIZE16;
3771 unatint = natint && datumtype == 'S';
3772 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3777 #if SHORTSIZE != SIZE16
3779 unsigned short aushort;
3781 COPYNN(s, &aushort, sizeof(unsigned short));
3782 s += sizeof(unsigned short);
3790 COPY16(s, &aushort);
3793 if (datumtype == 'n')
3794 aushort = PerlSock_ntohs(aushort);
3797 if (datumtype == 'v')
3798 aushort = vtohs(aushort);
3807 #if SHORTSIZE != SIZE16
3809 unsigned short aushort;
3811 COPYNN(s, &aushort, sizeof(unsigned short));
3812 s += sizeof(unsigned short);
3814 sv_setiv(sv, (UV)aushort);
3815 PUSHs(sv_2mortal(sv));
3822 COPY16(s, &aushort);
3826 if (datumtype == 'n')
3827 aushort = PerlSock_ntohs(aushort);
3830 if (datumtype == 'v')
3831 aushort = vtohs(aushort);
3833 sv_setiv(sv, (UV)aushort);
3834 PUSHs(sv_2mortal(sv));
3840 along = (strend - s) / sizeof(int);
3845 Copy(s, &aint, 1, int);
3848 cdouble += (NV)aint;
3857 Copy(s, &aint, 1, int);
3861 /* Without the dummy below unpack("i", pack("i",-1))
3862 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3863 * cc with optimization turned on.
3865 * The bug was detected in
3866 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3867 * with optimization (-O4) turned on.
3868 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3869 * does not have this problem even with -O4.
3871 * This bug was reported as DECC_BUGS 1431
3872 * and tracked internally as GEM_BUGS 7775.
3874 * The bug is fixed in
3875 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3876 * UNIX V4.0F support: DEC C V5.9-006 or later
3877 * UNIX V4.0E support: DEC C V5.8-011 or later
3880 * See also few lines later for the same bug.
3883 sv_setiv(sv, (IV)aint) :
3885 sv_setiv(sv, (IV)aint);
3886 PUSHs(sv_2mortal(sv));
3891 along = (strend - s) / sizeof(unsigned int);
3896 Copy(s, &auint, 1, unsigned int);
3897 s += sizeof(unsigned int);
3899 cdouble += (NV)auint;
3908 Copy(s, &auint, 1, unsigned int);
3909 s += sizeof(unsigned int);
3912 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3913 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3914 * See details few lines earlier. */
3916 sv_setuv(sv, (UV)auint) :
3918 sv_setuv(sv, (UV)auint);
3919 PUSHs(sv_2mortal(sv));
3924 #if LONGSIZE == SIZE32
3925 along = (strend - s) / SIZE32;
3927 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3932 #if LONGSIZE != SIZE32
3935 COPYNN(s, &along, sizeof(long));
3938 cdouble += (NV)along;
3947 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3951 #if LONGSIZE > SIZE32
3952 if (along > 2147483647)
3953 along -= 4294967296;
3957 cdouble += (NV)along;
3966 #if LONGSIZE != SIZE32
3969 COPYNN(s, &along, sizeof(long));
3972 sv_setiv(sv, (IV)along);
3973 PUSHs(sv_2mortal(sv));
3980 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3984 #if LONGSIZE > SIZE32
3985 if (along > 2147483647)
3986 along -= 4294967296;
3990 sv_setiv(sv, (IV)along);
3991 PUSHs(sv_2mortal(sv));
3999 #if LONGSIZE == SIZE32
4000 along = (strend - s) / SIZE32;
4002 unatint = natint && datumtype == 'L';
4003 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4008 #if LONGSIZE != SIZE32
4010 unsigned long aulong;
4012 COPYNN(s, &aulong, sizeof(unsigned long));
4013 s += sizeof(unsigned long);
4015 cdouble += (NV)aulong;
4027 if (datumtype == 'N')
4028 aulong = PerlSock_ntohl(aulong);
4031 if (datumtype == 'V')
4032 aulong = vtohl(aulong);
4035 cdouble += (NV)aulong;
4044 #if LONGSIZE != SIZE32
4046 unsigned long aulong;
4048 COPYNN(s, &aulong, sizeof(unsigned long));
4049 s += sizeof(unsigned long);
4051 sv_setuv(sv, (UV)aulong);
4052 PUSHs(sv_2mortal(sv));
4062 if (datumtype == 'N')
4063 aulong = PerlSock_ntohl(aulong);
4066 if (datumtype == 'V')
4067 aulong = vtohl(aulong);
4070 sv_setuv(sv, (UV)aulong);
4071 PUSHs(sv_2mortal(sv));
4077 along = (strend - s) / sizeof(char*);
4083 if (sizeof(char*) > strend - s)
4086 Copy(s, &aptr, 1, char*);
4092 PUSHs(sv_2mortal(sv));
4102 while ((len > 0) && (s < strend)) {
4103 auv = (auv << 7) | (*s & 0x7f);
4104 if (!(*s++ & 0x80)) {
4108 PUSHs(sv_2mortal(sv));
4112 else if (++bytes >= sizeof(UV)) { /* promote to string */
4116 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4117 while (s < strend) {
4118 sv = mul128(sv, *s & 0x7f);
4119 if (!(*s++ & 0x80)) {
4128 PUSHs(sv_2mortal(sv));
4133 if ((s >= strend) && bytes)
4134 DIE(aTHX_ "Unterminated compressed integer");
4139 if (sizeof(char*) > strend - s)
4142 Copy(s, &aptr, 1, char*);
4147 sv_setpvn(sv, aptr, len);
4148 PUSHs(sv_2mortal(sv));
4152 along = (strend - s) / sizeof(Quad_t);
4158 if (s + sizeof(Quad_t) > strend)
4161 Copy(s, &aquad, 1, Quad_t);
4162 s += sizeof(Quad_t);
4165 if (aquad >= IV_MIN && aquad <= IV_MAX)
4166 sv_setiv(sv, (IV)aquad);
4168 sv_setnv(sv, (NV)aquad);
4169 PUSHs(sv_2mortal(sv));
4173 along = (strend - s) / sizeof(Quad_t);
4179 if (s + sizeof(Uquad_t) > strend)
4182 Copy(s, &auquad, 1, Uquad_t);
4183 s += sizeof(Uquad_t);
4186 if (auquad <= UV_MAX)
4187 sv_setuv(sv, (UV)auquad);
4189 sv_setnv(sv, (NV)auquad);
4190 PUSHs(sv_2mortal(sv));
4194 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4197 along = (strend - s) / sizeof(float);
4202 Copy(s, &afloat, 1, float);
4211 Copy(s, &afloat, 1, float);
4214 sv_setnv(sv, (NV)afloat);
4215 PUSHs(sv_2mortal(sv));
4221 along = (strend - s) / sizeof(double);
4226 Copy(s, &adouble, 1, double);
4227 s += sizeof(double);
4235 Copy(s, &adouble, 1, double);
4236 s += sizeof(double);
4238 sv_setnv(sv, (NV)adouble);
4239 PUSHs(sv_2mortal(sv));
4245 * Initialise the decode mapping. By using a table driven
4246 * algorithm, the code will be character-set independent
4247 * (and just as fast as doing character arithmetic)
4249 if (PL_uudmap['M'] == 0) {
4252 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4253 PL_uudmap[(U8)PL_uuemap[i]] = i;
4255 * Because ' ' and '`' map to the same value,
4256 * we need to decode them both the same.
4261 along = (strend - s) * 3 / 4;
4262 sv = NEWSV(42, along);
4265 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4270 len = PL_uudmap[*(U8*)s++] & 077;
4272 if (s < strend && ISUUCHAR(*s))
4273 a = PL_uudmap[*(U8*)s++] & 077;
4276 if (s < strend && ISUUCHAR(*s))
4277 b = PL_uudmap[*(U8*)s++] & 077;
4280 if (s < strend && ISUUCHAR(*s))
4281 c = PL_uudmap[*(U8*)s++] & 077;
4284 if (s < strend && ISUUCHAR(*s))
4285 d = PL_uudmap[*(U8*)s++] & 077;
4288 hunk[0] = (a << 2) | (b >> 4);
4289 hunk[1] = (b << 4) | (c >> 2);
4290 hunk[2] = (c << 6) | d;
4291 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4296 else if (s[1] == '\n') /* possible checksum byte */
4299 XPUSHs(sv_2mortal(sv));
4304 if (strchr("fFdD", datumtype) ||
4305 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4309 while (checksum >= 16) {
4313 while (checksum >= 4) {
4319 along = (1 << checksum) - 1;
4320 while (cdouble < 0.0)
4322 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4323 sv_setnv(sv, cdouble);
4326 if (checksum < 32) {
4327 aulong = (1 << checksum) - 1;
4330 sv_setuv(sv, (UV)culong);
4332 XPUSHs(sv_2mortal(sv));
4336 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4337 PUSHs(&PL_sv_undef);
4342 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4346 *hunk = PL_uuemap[len];
4347 sv_catpvn(sv, hunk, 1);
4350 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4351 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4352 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4353 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4354 sv_catpvn(sv, hunk, 4);
4359 char r = (len > 1 ? s[1] : '\0');
4360 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4361 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4362 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4363 hunk[3] = PL_uuemap[0];
4364 sv_catpvn(sv, hunk, 4);
4366 sv_catpvn(sv, "\n", 1);
4370 S_is_an_int(pTHX_ char *s, STRLEN l)
4373 SV *result = newSVpvn(s, l);
4374 char *result_c = SvPV(result, n_a); /* convenience */
4375 char *out = result_c;
4385 SvREFCNT_dec(result);
4408 SvREFCNT_dec(result);
4414 SvCUR_set(result, out - result_c);
4418 /* pnum must be '\0' terminated */
4420 S_div128(pTHX_ SV *pnum, bool *done)
4423 char *s = SvPV(pnum, len);
4432 i = m * 10 + (*t - '0');
4434 r = (i >> 7); /* r < 10 */
4441 SvCUR_set(pnum, (STRLEN) (t - s));
4448 djSP; dMARK; dORIGMARK; dTARGET;
4449 register SV *cat = TARG;
4452 register char *pat = SvPVx(*++MARK, fromlen);
4454 register char *patend = pat + fromlen;
4459 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4460 static char *space10 = " ";
4462 /* These must not be in registers: */
4477 #ifdef PERL_NATINT_PACK
4478 int natint; /* native integer */
4483 sv_setpvn(cat, "", 0);
4485 while (pat < patend) {
4486 SV *lengthcode = Nullsv;
4487 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4488 datumtype = *pat++ & 0xFF;
4489 #ifdef PERL_NATINT_PACK
4492 if (isSPACE(datumtype)) {
4496 if (datumtype == 'U' && pat == patcopy+1)
4498 if (datumtype == '#') {
4499 while (pat < patend && *pat != '\n')
4504 char *natstr = "sSiIlL";
4506 if (strchr(natstr, datumtype)) {
4507 #ifdef PERL_NATINT_PACK
4513 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4516 len = strchr("@Xxu", datumtype) ? 0 : items;
4519 else if (isDIGIT(*pat)) {
4521 while (isDIGIT(*pat)) {
4522 len = (len * 10) + (*pat++ - '0');
4524 DIE(aTHX_ "Repeat count in pack overflows");
4531 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4532 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4533 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4534 ? *MARK : &PL_sv_no)
4535 + (*pat == 'Z' ? 1 : 0)));
4539 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4540 case ',': /* grandfather in commas but with a warning */
4541 if (commas++ == 0 && ckWARN(WARN_PACK))
4542 Perl_warner(aTHX_ WARN_PACK,
4543 "Invalid type in pack: '%c'", (int)datumtype);
4546 DIE(aTHX_ "%% may only be used in unpack");
4557 if (SvCUR(cat) < len)
4558 DIE(aTHX_ "X outside of string");
4565 sv_catpvn(cat, null10, 10);
4568 sv_catpvn(cat, null10, len);
4574 aptr = SvPV(fromstr, fromlen);
4575 if (pat[-1] == '*') {
4577 if (datumtype == 'Z')
4580 if (fromlen >= len) {
4581 sv_catpvn(cat, aptr, len);
4582 if (datumtype == 'Z')
4583 *(SvEND(cat)-1) = '\0';
4586 sv_catpvn(cat, aptr, fromlen);
4588 if (datumtype == 'A') {
4590 sv_catpvn(cat, space10, 10);
4593 sv_catpvn(cat, space10, len);
4597 sv_catpvn(cat, null10, 10);
4600 sv_catpvn(cat, null10, len);
4612 str = SvPV(fromstr, fromlen);
4616 SvCUR(cat) += (len+7)/8;
4617 SvGROW(cat, SvCUR(cat) + 1);
4618 aptr = SvPVX(cat) + aint;
4623 if (datumtype == 'B') {
4624 for (len = 0; len++ < aint;) {
4625 items |= *str++ & 1;
4629 *aptr++ = items & 0xff;
4635 for (len = 0; len++ < aint;) {
4641 *aptr++ = items & 0xff;
4647 if (datumtype == 'B')
4648 items <<= 7 - (aint & 7);
4650 items >>= 7 - (aint & 7);
4651 *aptr++ = items & 0xff;
4653 str = SvPVX(cat) + SvCUR(cat);
4668 str = SvPV(fromstr, fromlen);
4672 SvCUR(cat) += (len+1)/2;
4673 SvGROW(cat, SvCUR(cat) + 1);
4674 aptr = SvPVX(cat) + aint;
4679 if (datumtype == 'H') {
4680 for (len = 0; len++ < aint;) {
4682 items |= ((*str++ & 15) + 9) & 15;
4684 items |= *str++ & 15;
4688 *aptr++ = items & 0xff;
4694 for (len = 0; len++ < aint;) {
4696 items |= (((*str++ & 15) + 9) & 15) << 4;
4698 items |= (*str++ & 15) << 4;
4702 *aptr++ = items & 0xff;
4708 *aptr++ = items & 0xff;
4709 str = SvPVX(cat) + SvCUR(cat);
4720 aint = SvIV(fromstr);
4722 sv_catpvn(cat, &achar, sizeof(char));
4728 auint = SvUV(fromstr);
4729 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
4730 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4735 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4740 afloat = (float)SvNV(fromstr);
4741 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4748 adouble = (double)SvNV(fromstr);
4749 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4755 ashort = (I16)SvIV(fromstr);
4757 ashort = PerlSock_htons(ashort);
4759 CAT16(cat, &ashort);
4765 ashort = (I16)SvIV(fromstr);
4767 ashort = htovs(ashort);
4769 CAT16(cat, &ashort);
4773 #if SHORTSIZE != SIZE16
4775 unsigned short aushort;
4779 aushort = SvUV(fromstr);
4780 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4790 aushort = (U16)SvUV(fromstr);
4791 CAT16(cat, &aushort);
4797 #if SHORTSIZE != SIZE16
4803 ashort = SvIV(fromstr);
4804 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4812 ashort = (I16)SvIV(fromstr);
4813 CAT16(cat, &ashort);
4820 auint = SvUV(fromstr);
4821 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4827 adouble = Perl_floor(SvNV(fromstr));
4830 DIE(aTHX_ "Cannot compress negative numbers");
4833 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4834 adouble <= 0xffffffff
4836 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4837 adouble <= UV_MAX_cxux
4844 char buf[1 + sizeof(UV)];
4845 char *in = buf + sizeof(buf);
4846 UV auv = U_V(adouble);
4849 *--in = (auv & 0x7f) | 0x80;
4852 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4853 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4855 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4856 char *from, *result, *in;
4861 /* Copy string and check for compliance */
4862 from = SvPV(fromstr, len);
4863 if ((norm = is_an_int(from, len)) == NULL)
4864 DIE(aTHX_ "can compress only unsigned integer");
4866 New('w', result, len, char);
4870 *--in = div128(norm, &done) | 0x80;
4871 result[len - 1] &= 0x7F; /* clear continue bit */
4872 sv_catpvn(cat, in, (result + len) - in);
4874 SvREFCNT_dec(norm); /* free norm */
4876 else if (SvNOKp(fromstr)) {
4877 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4878 char *in = buf + sizeof(buf);
4881 double next = floor(adouble / 128);
4882 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4883 if (in <= buf) /* this cannot happen ;-) */
4884 DIE(aTHX_ "Cannot compress integer");
4887 } while (adouble > 0);
4888 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4889 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4892 DIE(aTHX_ "Cannot compress non integer");
4898 aint = SvIV(fromstr);
4899 sv_catpvn(cat, (char*)&aint, sizeof(int));
4905 aulong = SvUV(fromstr);
4907 aulong = PerlSock_htonl(aulong);
4909 CAT32(cat, &aulong);
4915 aulong = SvUV(fromstr);
4917 aulong = htovl(aulong);
4919 CAT32(cat, &aulong);
4923 #if LONGSIZE != SIZE32
4925 unsigned long aulong;
4929 aulong = SvUV(fromstr);
4930 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4938 aulong = SvUV(fromstr);
4939 CAT32(cat, &aulong);
4944 #if LONGSIZE != SIZE32
4950 along = SvIV(fromstr);
4951 sv_catpvn(cat, (char *)&along, sizeof(long));
4959 along = SvIV(fromstr);
4968 auquad = (Uquad_t)SvUV(fromstr);
4969 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4975 aquad = (Quad_t)SvIV(fromstr);
4976 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4981 len = 1; /* assume SV is correct length */
4986 if (fromstr == &PL_sv_undef)
4990 /* XXX better yet, could spirit away the string to
4991 * a safe spot and hang on to it until the result
4992 * of pack() (and all copies of the result) are
4995 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4996 || (SvPADTMP(fromstr)
4997 && !SvREADONLY(fromstr))))
4999 Perl_warner(aTHX_ WARN_PACK,
5000 "Attempt to pack pointer to temporary value");
5002 if (SvPOK(fromstr) || SvNIOK(fromstr))
5003 aptr = SvPV(fromstr,n_a);
5005 aptr = SvPV_force(fromstr,n_a);
5007 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5012 aptr = SvPV(fromstr, fromlen);
5013 SvGROW(cat, fromlen * 4 / 3);
5018 while (fromlen > 0) {
5025 doencodes(cat, aptr, todo);
5044 register IV limit = POPi; /* note, negative is forever */
5046 bool doutf8 = DO_UTF8(sv);
5048 register char *s = SvPV(sv, len);
5049 char *strend = s + len;
5051 register REGEXP *rx;
5055 I32 maxiters = (strend - s) + 10;
5058 I32 origlimit = limit;
5061 AV *oldstack = PL_curstack;
5062 I32 gimme = GIMME_V;
5063 I32 oldsave = PL_savestack_ix;
5064 I32 make_mortal = 1;
5065 MAGIC *mg = (MAGIC *) NULL;
5068 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5073 DIE(aTHX_ "panic: do_split");
5074 rx = pm->op_pmregexp;
5076 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5077 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5079 if (pm->op_pmreplroot) {
5081 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5083 ary = GvAVn((GV*)pm->op_pmreplroot);
5086 else if (gimme != G_ARRAY)
5088 ary = (AV*)PL_curpad[0];
5090 ary = GvAVn(PL_defgv);
5091 #endif /* USE_THREADS */
5094 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5100 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5102 XPUSHs(SvTIED_obj((SV*)ary, mg));
5108 for (i = AvFILLp(ary); i >= 0; i--)
5109 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5111 /* temporarily switch stacks */
5112 SWITCHSTACK(PL_curstack, ary);
5116 base = SP - PL_stack_base;
5118 if (pm->op_pmflags & PMf_SKIPWHITE) {
5119 if (pm->op_pmflags & PMf_LOCALE) {
5120 while (isSPACE_LC(*s))
5128 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5129 SAVEINT(PL_multiline);
5130 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5134 limit = maxiters + 2;
5135 if (pm->op_pmflags & PMf_WHITE) {
5138 while (m < strend &&
5139 !((pm->op_pmflags & PMf_LOCALE)
5140 ? isSPACE_LC(*m) : isSPACE(*m)))
5145 dstr = NEWSV(30, m-s);
5146 sv_setpvn(dstr, s, m-s);
5150 (void)SvUTF8_on(dstr);
5154 while (s < strend &&
5155 ((pm->op_pmflags & PMf_LOCALE)
5156 ? isSPACE_LC(*s) : isSPACE(*s)))
5160 else if (strEQ("^", rx->precomp)) {
5163 for (m = s; m < strend && *m != '\n'; m++) ;
5167 dstr = NEWSV(30, m-s);
5168 sv_setpvn(dstr, s, m-s);
5172 (void)SvUTF8_on(dstr);
5177 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5178 && (rx->reganch & ROPT_CHECK_ALL)
5179 && !(rx->reganch & ROPT_ANCH)) {
5180 int tail = (rx->reganch & RE_INTUIT_TAIL);
5181 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5184 if (len == 1 && !tail) {
5186 char c = *SvPV(csv, n_a);
5189 for (m = s; m < strend && *m != c; m++) ;
5192 dstr = NEWSV(30, 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);
5206 while (s < strend && --limit &&
5207 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5208 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5211 dstr = NEWSV(31, m-s);
5212 sv_setpvn(dstr, s, m-s);
5216 (void)SvUTF8_on(dstr);
5218 /* The rx->minlen is in characters but we want to step
5219 * s ahead by bytes. */
5220 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5225 maxiters += (strend - s) * rx->nparens;
5226 while (s < strend && --limit
5227 /* && (!rx->check_substr
5228 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5230 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5231 1 /* minend */, sv, NULL, 0))
5233 TAINT_IF(RX_MATCH_TAINTED(rx));
5234 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5239 strend = s + (strend - m);
5241 m = rx->startp[0] + orig;
5242 dstr = NEWSV(32, m-s);
5243 sv_setpvn(dstr, s, m-s);
5247 (void)SvUTF8_on(dstr);
5250 for (i = 1; i <= rx->nparens; i++) {
5251 s = rx->startp[i] + orig;
5252 m = rx->endp[i] + orig;
5254 dstr = NEWSV(33, m-s);
5255 sv_setpvn(dstr, s, m-s);
5258 dstr = NEWSV(33, 0);
5262 (void)SvUTF8_on(dstr);
5266 s = rx->endp[0] + orig;
5270 LEAVE_SCOPE(oldsave);
5271 iters = (SP - PL_stack_base) - base;
5272 if (iters > maxiters)
5273 DIE(aTHX_ "Split loop");
5275 /* keep field after final delim? */
5276 if (s < strend || (iters && origlimit)) {
5277 STRLEN l = strend - s;
5278 dstr = NEWSV(34, l);
5279 sv_setpvn(dstr, s, l);
5283 (void)SvUTF8_on(dstr);
5287 else if (!origlimit) {
5288 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5294 SWITCHSTACK(ary, oldstack);
5295 if (SvSMAGICAL(ary)) {
5300 if (gimme == G_ARRAY) {
5302 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5310 call_method("PUSH",G_SCALAR|G_DISCARD);
5313 if (gimme == G_ARRAY) {
5314 /* EXTEND should not be needed - we just popped them */
5316 for (i=0; i < iters; i++) {
5317 SV **svp = av_fetch(ary, i, FALSE);
5318 PUSHs((svp) ? *svp : &PL_sv_undef);
5325 if (gimme == G_ARRAY)
5328 if (iters || !pm->op_pmreplroot) {
5338 Perl_unlock_condpair(pTHX_ void *svv)
5340 MAGIC *mg = mg_find((SV*)svv, 'm');
5343 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5344 MUTEX_LOCK(MgMUTEXP(mg));
5345 if (MgOWNER(mg) != thr)
5346 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5348 COND_SIGNAL(MgOWNERCONDP(mg));
5349 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5350 PTR2UV(thr), PTR2UV(svv));)
5351 MUTEX_UNLOCK(MgMUTEXP(mg));
5353 #endif /* USE_THREADS */
5362 #endif /* USE_THREADS */
5363 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5364 || SvTYPE(retsv) == SVt_PVCV) {
5365 retsv = refto(retsv);
5376 if (PL_op->op_private & OPpLVAL_INTRO)
5377 PUSHs(*save_threadsv(PL_op->op_targ));
5379 PUSHs(THREADSV(PL_op->op_targ));
5382 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5383 #endif /* USE_THREADS */