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) {
2836 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
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) {
2851 save_helem(hv, keysv, svp);
2854 char *key = SvPV(keysv, keylen);
2855 save_delete(hv, key, keylen);
2859 *MARK = svp ? *svp : &PL_sv_undef;
2862 if (GIMME != G_ARRAY) {
2870 /* List operators. */
2875 if (GIMME != G_ARRAY) {
2877 *MARK = *SP; /* unwanted list, return last item */
2879 *MARK = &PL_sv_undef;
2888 SV **lastrelem = PL_stack_sp;
2889 SV **lastlelem = PL_stack_base + POPMARK;
2890 SV **firstlelem = PL_stack_base + POPMARK + 1;
2891 register SV **firstrelem = lastlelem + 1;
2892 I32 arybase = PL_curcop->cop_arybase;
2893 I32 lval = PL_op->op_flags & OPf_MOD;
2894 I32 is_something_there = lval;
2896 register I32 max = lastrelem - lastlelem;
2897 register SV **lelem;
2900 if (GIMME != G_ARRAY) {
2901 ix = SvIVx(*lastlelem);
2906 if (ix < 0 || ix >= max)
2907 *firstlelem = &PL_sv_undef;
2909 *firstlelem = firstrelem[ix];
2915 SP = firstlelem - 1;
2919 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2925 if (ix < 0 || ix >= max)
2926 *lelem = &PL_sv_undef;
2928 is_something_there = TRUE;
2929 if (!(*lelem = firstrelem[ix]))
2930 *lelem = &PL_sv_undef;
2933 if (is_something_there)
2936 SP = firstlelem - 1;
2942 djSP; dMARK; dORIGMARK;
2943 I32 items = SP - MARK;
2944 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2945 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2952 djSP; dMARK; dORIGMARK;
2953 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2957 SV *val = NEWSV(46, 0);
2959 sv_setsv(val, *++MARK);
2960 else if (ckWARN(WARN_MISC))
2961 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2962 (void)hv_store_ent(hv,key,val,0);
2971 djSP; dMARK; dORIGMARK;
2972 register AV *ary = (AV*)*++MARK;
2976 register I32 offset;
2977 register I32 length;
2984 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2985 *MARK-- = SvTIED_obj((SV*)ary, mg);
2989 call_method("SPLICE",GIMME_V);
2998 offset = i = SvIVx(*MARK);
3000 offset += AvFILLp(ary) + 1;
3002 offset -= PL_curcop->cop_arybase;
3004 DIE(aTHX_ PL_no_aelem, i);
3006 length = SvIVx(*MARK++);
3008 length += AvFILLp(ary) - offset + 1;
3014 length = AvMAX(ary) + 1; /* close enough to infinity */
3018 length = AvMAX(ary) + 1;
3020 if (offset > AvFILLp(ary) + 1)
3021 offset = AvFILLp(ary) + 1;
3022 after = AvFILLp(ary) + 1 - (offset + length);
3023 if (after < 0) { /* not that much array */
3024 length += after; /* offset+length now in array */
3030 /* At this point, MARK .. SP-1 is our new LIST */
3033 diff = newlen - length;
3034 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3037 if (diff < 0) { /* shrinking the area */
3039 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3040 Copy(MARK, tmparyval, newlen, SV*);
3043 MARK = ORIGMARK + 1;
3044 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3045 MEXTEND(MARK, length);
3046 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3048 EXTEND_MORTAL(length);
3049 for (i = length, dst = MARK; i; i--) {
3050 sv_2mortal(*dst); /* free them eventualy */
3057 *MARK = AvARRAY(ary)[offset+length-1];
3060 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3061 SvREFCNT_dec(*dst++); /* free them now */
3064 AvFILLp(ary) += diff;
3066 /* pull up or down? */
3068 if (offset < after) { /* easier to pull up */
3069 if (offset) { /* esp. if nothing to pull */
3070 src = &AvARRAY(ary)[offset-1];
3071 dst = src - diff; /* diff is negative */
3072 for (i = offset; i > 0; i--) /* can't trust Copy */
3076 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3080 if (after) { /* anything to pull down? */
3081 src = AvARRAY(ary) + offset + length;
3082 dst = src + diff; /* diff is negative */
3083 Move(src, dst, after, SV*);
3085 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3086 /* avoid later double free */
3090 dst[--i] = &PL_sv_undef;
3093 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3095 *dst = NEWSV(46, 0);
3096 sv_setsv(*dst++, *src++);
3098 Safefree(tmparyval);
3101 else { /* no, expanding (or same) */
3103 New(452, tmparyval, length, SV*); /* so remember deletion */
3104 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3107 if (diff > 0) { /* expanding */
3109 /* push up or down? */
3111 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3115 Move(src, dst, offset, SV*);
3117 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3119 AvFILLp(ary) += diff;
3122 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3123 av_extend(ary, AvFILLp(ary) + diff);
3124 AvFILLp(ary) += diff;
3127 dst = AvARRAY(ary) + AvFILLp(ary);
3129 for (i = after; i; i--) {
3136 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3137 *dst = NEWSV(46, 0);
3138 sv_setsv(*dst++, *src++);
3140 MARK = ORIGMARK + 1;
3141 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3143 Copy(tmparyval, MARK, length, SV*);
3145 EXTEND_MORTAL(length);
3146 for (i = length, dst = MARK; i; i--) {
3147 sv_2mortal(*dst); /* free them eventualy */
3151 Safefree(tmparyval);
3155 else if (length--) {
3156 *MARK = tmparyval[length];
3159 while (length-- > 0)
3160 SvREFCNT_dec(tmparyval[length]);
3162 Safefree(tmparyval);
3165 *MARK = &PL_sv_undef;
3173 djSP; dMARK; dORIGMARK; dTARGET;
3174 register AV *ary = (AV*)*++MARK;
3175 register SV *sv = &PL_sv_undef;
3178 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3179 *MARK-- = SvTIED_obj((SV*)ary, mg);
3183 call_method("PUSH",G_SCALAR|G_DISCARD);
3188 /* Why no pre-extend of ary here ? */
3189 for (++MARK; MARK <= SP; MARK++) {
3192 sv_setsv(sv, *MARK);
3197 PUSHi( AvFILL(ary) + 1 );
3205 SV *sv = av_pop(av);
3207 (void)sv_2mortal(sv);
3216 SV *sv = av_shift(av);
3221 (void)sv_2mortal(sv);
3228 djSP; dMARK; dORIGMARK; dTARGET;
3229 register AV *ary = (AV*)*++MARK;
3234 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3235 *MARK-- = SvTIED_obj((SV*)ary, mg);
3239 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3244 av_unshift(ary, SP - MARK);
3247 sv_setsv(sv, *++MARK);
3248 (void)av_store(ary, i++, sv);
3252 PUSHi( AvFILL(ary) + 1 );
3262 if (GIMME == G_ARRAY) {
3269 /* safe as long as stack cannot get extended in the above */
3274 register char *down;
3279 SvUTF8_off(TARG); /* decontaminate */
3281 do_join(TARG, &PL_sv_no, MARK, SP);
3283 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3284 up = SvPV_force(TARG, len);
3286 if (DO_UTF8(TARG)) { /* first reverse each character */
3287 U8* s = (U8*)SvPVX(TARG);
3288 U8* send = (U8*)(s + len);
3297 down = (char*)(s - 1);
3298 if (s > send || !((*down & 0xc0) == 0x80)) {
3299 if (ckWARN_d(WARN_UTF8))
3300 Perl_warner(aTHX_ WARN_UTF8,
3301 "Malformed UTF-8 character");
3313 down = SvPVX(TARG) + len - 1;
3319 (void)SvPOK_only_UTF8(TARG);
3328 S_mul128(pTHX_ SV *sv, U8 m)
3331 char *s = SvPV(sv, len);
3335 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3336 SV *tmpNew = newSVpvn("0000000000", 10);
3338 sv_catsv(tmpNew, sv);
3339 SvREFCNT_dec(sv); /* free old sv */
3344 while (!*t) /* trailing '\0'? */
3347 i = ((*t - '0') << 7) + m;
3348 *(t--) = '0' + (i % 10);
3354 /* Explosives and implosives. */
3356 #if 'I' == 73 && 'J' == 74
3357 /* On an ASCII/ISO kind of system */
3358 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3361 Some other sort of character set - use memchr() so we don't match
3364 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3371 I32 start_sp_offset = SP - PL_stack_base;
3372 I32 gimme = GIMME_V;
3376 register char *pat = SvPV(left, llen);
3377 register char *s = SvPV(right, rlen);
3378 char *strend = s + rlen;
3380 register char *patend = pat + llen;
3386 /* These must not be in registers: */
3403 register U32 culong;
3407 #ifdef PERL_NATINT_PACK
3408 int natint; /* native integer */
3409 int unatint; /* unsigned native integer */
3412 if (gimme != G_ARRAY) { /* arrange to do first one only */
3414 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3415 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3417 while (isDIGIT(*patend) || *patend == '*')
3423 while (pat < patend) {
3425 datumtype = *pat++ & 0xFF;
3426 #ifdef PERL_NATINT_PACK
3429 if (isSPACE(datumtype))
3431 if (datumtype == '#') {
3432 while (pat < patend && *pat != '\n')
3437 char *natstr = "sSiIlL";
3439 if (strchr(natstr, datumtype)) {
3440 #ifdef PERL_NATINT_PACK
3446 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3451 else if (*pat == '*') {
3452 len = strend - strbeg; /* long enough */
3456 else if (isDIGIT(*pat)) {
3458 while (isDIGIT(*pat)) {
3459 len = (len * 10) + (*pat++ - '0');
3461 DIE(aTHX_ "Repeat count in unpack overflows");
3465 len = (datumtype != '@');
3469 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3470 case ',': /* grandfather in commas but with a warning */
3471 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3472 Perl_warner(aTHX_ WARN_UNPACK,
3473 "Invalid type in unpack: '%c'", (int)datumtype);
3476 if (len == 1 && pat[-1] != '1')
3485 if (len > strend - strbeg)
3486 DIE(aTHX_ "@ outside of string");
3490 if (len > s - strbeg)
3491 DIE(aTHX_ "X outside of string");
3495 if (len > strend - s)
3496 DIE(aTHX_ "x outside of string");
3500 if (start_sp_offset >= SP - PL_stack_base)
3501 DIE(aTHX_ "/ must follow a numeric type");
3504 pat++; /* ignore '*' for compatibility with pack */
3506 DIE(aTHX_ "/ cannot take a count" );
3513 if (len > strend - s)
3516 goto uchar_checksum;
3517 sv = NEWSV(35, len);
3518 sv_setpvn(sv, s, len);
3520 if (datumtype == 'A' || datumtype == 'Z') {
3521 aptr = s; /* borrow register */
3522 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3527 else { /* 'A' strips both nulls and spaces */
3528 s = SvPVX(sv) + len - 1;
3529 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3533 SvCUR_set(sv, s - SvPVX(sv));
3534 s = aptr; /* unborrow register */
3536 XPUSHs(sv_2mortal(sv));
3540 if (star || len > (strend - s) * 8)
3541 len = (strend - s) * 8;
3544 Newz(601, PL_bitcount, 256, char);
3545 for (bits = 1; bits < 256; bits++) {
3546 if (bits & 1) PL_bitcount[bits]++;
3547 if (bits & 2) PL_bitcount[bits]++;
3548 if (bits & 4) PL_bitcount[bits]++;
3549 if (bits & 8) PL_bitcount[bits]++;
3550 if (bits & 16) PL_bitcount[bits]++;
3551 if (bits & 32) PL_bitcount[bits]++;
3552 if (bits & 64) PL_bitcount[bits]++;
3553 if (bits & 128) PL_bitcount[bits]++;
3557 culong += PL_bitcount[*(unsigned char*)s++];
3562 if (datumtype == 'b') {
3564 if (bits & 1) culong++;
3570 if (bits & 128) culong++;
3577 sv = NEWSV(35, len + 1);
3581 if (datumtype == 'b') {
3583 for (len = 0; len < aint; len++) {
3584 if (len & 7) /*SUPPRESS 595*/
3588 *str++ = '0' + (bits & 1);
3593 for (len = 0; len < aint; len++) {
3598 *str++ = '0' + ((bits & 128) != 0);
3602 XPUSHs(sv_2mortal(sv));
3606 if (star || len > (strend - s) * 2)
3607 len = (strend - s) * 2;
3608 sv = NEWSV(35, len + 1);
3612 if (datumtype == 'h') {
3614 for (len = 0; len < aint; len++) {
3619 *str++ = PL_hexdigit[bits & 15];
3624 for (len = 0; len < aint; len++) {
3629 *str++ = PL_hexdigit[(bits >> 4) & 15];
3633 XPUSHs(sv_2mortal(sv));
3636 if (len > strend - s)
3641 if (aint >= 128) /* fake up signed chars */
3651 if (aint >= 128) /* fake up signed chars */
3654 sv_setiv(sv, (IV)aint);
3655 PUSHs(sv_2mortal(sv));
3660 if (len > strend - s)
3675 sv_setiv(sv, (IV)auint);
3676 PUSHs(sv_2mortal(sv));
3681 if (len > strend - s)
3684 while (len-- > 0 && s < strend) {
3686 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3690 cdouble += (NV)auint;
3698 while (len-- > 0 && s < strend) {
3700 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3704 sv_setuv(sv, (UV)auint);
3705 PUSHs(sv_2mortal(sv));
3710 #if SHORTSIZE == SIZE16
3711 along = (strend - s) / SIZE16;
3713 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3718 #if SHORTSIZE != SIZE16
3722 COPYNN(s, &ashort, sizeof(short));
3733 #if SHORTSIZE > SIZE16
3745 #if SHORTSIZE != SIZE16
3749 COPYNN(s, &ashort, sizeof(short));
3752 sv_setiv(sv, (IV)ashort);
3753 PUSHs(sv_2mortal(sv));
3761 #if SHORTSIZE > SIZE16
3767 sv_setiv(sv, (IV)ashort);
3768 PUSHs(sv_2mortal(sv));
3776 #if SHORTSIZE == SIZE16
3777 along = (strend - s) / SIZE16;
3779 unatint = natint && datumtype == 'S';
3780 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3785 #if SHORTSIZE != SIZE16
3787 unsigned short aushort;
3789 COPYNN(s, &aushort, sizeof(unsigned short));
3790 s += sizeof(unsigned short);
3798 COPY16(s, &aushort);
3801 if (datumtype == 'n')
3802 aushort = PerlSock_ntohs(aushort);
3805 if (datumtype == 'v')
3806 aushort = vtohs(aushort);
3815 #if SHORTSIZE != SIZE16
3817 unsigned short aushort;
3819 COPYNN(s, &aushort, sizeof(unsigned short));
3820 s += sizeof(unsigned short);
3822 sv_setiv(sv, (UV)aushort);
3823 PUSHs(sv_2mortal(sv));
3830 COPY16(s, &aushort);
3834 if (datumtype == 'n')
3835 aushort = PerlSock_ntohs(aushort);
3838 if (datumtype == 'v')
3839 aushort = vtohs(aushort);
3841 sv_setiv(sv, (UV)aushort);
3842 PUSHs(sv_2mortal(sv));
3848 along = (strend - s) / sizeof(int);
3853 Copy(s, &aint, 1, int);
3856 cdouble += (NV)aint;
3865 Copy(s, &aint, 1, int);
3869 /* Without the dummy below unpack("i", pack("i",-1))
3870 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3871 * cc with optimization turned on.
3873 * The bug was detected in
3874 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3875 * with optimization (-O4) turned on.
3876 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3877 * does not have this problem even with -O4.
3879 * This bug was reported as DECC_BUGS 1431
3880 * and tracked internally as GEM_BUGS 7775.
3882 * The bug is fixed in
3883 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3884 * UNIX V4.0F support: DEC C V5.9-006 or later
3885 * UNIX V4.0E support: DEC C V5.8-011 or later
3888 * See also few lines later for the same bug.
3891 sv_setiv(sv, (IV)aint) :
3893 sv_setiv(sv, (IV)aint);
3894 PUSHs(sv_2mortal(sv));
3899 along = (strend - s) / sizeof(unsigned int);
3904 Copy(s, &auint, 1, unsigned int);
3905 s += sizeof(unsigned int);
3907 cdouble += (NV)auint;
3916 Copy(s, &auint, 1, unsigned int);
3917 s += sizeof(unsigned int);
3920 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3921 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3922 * See details few lines earlier. */
3924 sv_setuv(sv, (UV)auint) :
3926 sv_setuv(sv, (UV)auint);
3927 PUSHs(sv_2mortal(sv));
3932 #if LONGSIZE == SIZE32
3933 along = (strend - s) / SIZE32;
3935 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3940 #if LONGSIZE != SIZE32
3943 COPYNN(s, &along, sizeof(long));
3946 cdouble += (NV)along;
3955 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3959 #if LONGSIZE > SIZE32
3960 if (along > 2147483647)
3961 along -= 4294967296;
3965 cdouble += (NV)along;
3974 #if LONGSIZE != SIZE32
3977 COPYNN(s, &along, sizeof(long));
3980 sv_setiv(sv, (IV)along);
3981 PUSHs(sv_2mortal(sv));
3988 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3992 #if LONGSIZE > SIZE32
3993 if (along > 2147483647)
3994 along -= 4294967296;
3998 sv_setiv(sv, (IV)along);
3999 PUSHs(sv_2mortal(sv));
4007 #if LONGSIZE == SIZE32
4008 along = (strend - s) / SIZE32;
4010 unatint = natint && datumtype == 'L';
4011 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4016 #if LONGSIZE != SIZE32
4018 unsigned long aulong;
4020 COPYNN(s, &aulong, sizeof(unsigned long));
4021 s += sizeof(unsigned long);
4023 cdouble += (NV)aulong;
4035 if (datumtype == 'N')
4036 aulong = PerlSock_ntohl(aulong);
4039 if (datumtype == 'V')
4040 aulong = vtohl(aulong);
4043 cdouble += (NV)aulong;
4052 #if LONGSIZE != SIZE32
4054 unsigned long aulong;
4056 COPYNN(s, &aulong, sizeof(unsigned long));
4057 s += sizeof(unsigned long);
4059 sv_setuv(sv, (UV)aulong);
4060 PUSHs(sv_2mortal(sv));
4070 if (datumtype == 'N')
4071 aulong = PerlSock_ntohl(aulong);
4074 if (datumtype == 'V')
4075 aulong = vtohl(aulong);
4078 sv_setuv(sv, (UV)aulong);
4079 PUSHs(sv_2mortal(sv));
4085 along = (strend - s) / sizeof(char*);
4091 if (sizeof(char*) > strend - s)
4094 Copy(s, &aptr, 1, char*);
4100 PUSHs(sv_2mortal(sv));
4110 while ((len > 0) && (s < strend)) {
4111 auv = (auv << 7) | (*s & 0x7f);
4112 if (!(*s++ & 0x80)) {
4116 PUSHs(sv_2mortal(sv));
4120 else if (++bytes >= sizeof(UV)) { /* promote to string */
4124 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4125 while (s < strend) {
4126 sv = mul128(sv, *s & 0x7f);
4127 if (!(*s++ & 0x80)) {
4136 PUSHs(sv_2mortal(sv));
4141 if ((s >= strend) && bytes)
4142 DIE(aTHX_ "Unterminated compressed integer");
4147 if (sizeof(char*) > strend - s)
4150 Copy(s, &aptr, 1, char*);
4155 sv_setpvn(sv, aptr, len);
4156 PUSHs(sv_2mortal(sv));
4160 along = (strend - s) / sizeof(Quad_t);
4166 if (s + sizeof(Quad_t) > strend)
4169 Copy(s, &aquad, 1, Quad_t);
4170 s += sizeof(Quad_t);
4173 if (aquad >= IV_MIN && aquad <= IV_MAX)
4174 sv_setiv(sv, (IV)aquad);
4176 sv_setnv(sv, (NV)aquad);
4177 PUSHs(sv_2mortal(sv));
4181 along = (strend - s) / sizeof(Quad_t);
4187 if (s + sizeof(Uquad_t) > strend)
4190 Copy(s, &auquad, 1, Uquad_t);
4191 s += sizeof(Uquad_t);
4194 if (auquad <= UV_MAX)
4195 sv_setuv(sv, (UV)auquad);
4197 sv_setnv(sv, (NV)auquad);
4198 PUSHs(sv_2mortal(sv));
4202 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4205 along = (strend - s) / sizeof(float);
4210 Copy(s, &afloat, 1, float);
4219 Copy(s, &afloat, 1, float);
4222 sv_setnv(sv, (NV)afloat);
4223 PUSHs(sv_2mortal(sv));
4229 along = (strend - s) / sizeof(double);
4234 Copy(s, &adouble, 1, double);
4235 s += sizeof(double);
4243 Copy(s, &adouble, 1, double);
4244 s += sizeof(double);
4246 sv_setnv(sv, (NV)adouble);
4247 PUSHs(sv_2mortal(sv));
4253 * Initialise the decode mapping. By using a table driven
4254 * algorithm, the code will be character-set independent
4255 * (and just as fast as doing character arithmetic)
4257 if (PL_uudmap['M'] == 0) {
4260 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4261 PL_uudmap[(U8)PL_uuemap[i]] = i;
4263 * Because ' ' and '`' map to the same value,
4264 * we need to decode them both the same.
4269 along = (strend - s) * 3 / 4;
4270 sv = NEWSV(42, along);
4273 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4278 len = PL_uudmap[*(U8*)s++] & 077;
4280 if (s < strend && ISUUCHAR(*s))
4281 a = PL_uudmap[*(U8*)s++] & 077;
4284 if (s < strend && ISUUCHAR(*s))
4285 b = PL_uudmap[*(U8*)s++] & 077;
4288 if (s < strend && ISUUCHAR(*s))
4289 c = PL_uudmap[*(U8*)s++] & 077;
4292 if (s < strend && ISUUCHAR(*s))
4293 d = PL_uudmap[*(U8*)s++] & 077;
4296 hunk[0] = (a << 2) | (b >> 4);
4297 hunk[1] = (b << 4) | (c >> 2);
4298 hunk[2] = (c << 6) | d;
4299 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4304 else if (s[1] == '\n') /* possible checksum byte */
4307 XPUSHs(sv_2mortal(sv));
4312 if (strchr("fFdD", datumtype) ||
4313 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4317 while (checksum >= 16) {
4321 while (checksum >= 4) {
4327 along = (1 << checksum) - 1;
4328 while (cdouble < 0.0)
4330 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4331 sv_setnv(sv, cdouble);
4334 if (checksum < 32) {
4335 aulong = (1 << checksum) - 1;
4338 sv_setuv(sv, (UV)culong);
4340 XPUSHs(sv_2mortal(sv));
4344 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4345 PUSHs(&PL_sv_undef);
4350 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4354 *hunk = PL_uuemap[len];
4355 sv_catpvn(sv, hunk, 1);
4358 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4359 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4360 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4361 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4362 sv_catpvn(sv, hunk, 4);
4367 char r = (len > 1 ? s[1] : '\0');
4368 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4369 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4370 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4371 hunk[3] = PL_uuemap[0];
4372 sv_catpvn(sv, hunk, 4);
4374 sv_catpvn(sv, "\n", 1);
4378 S_is_an_int(pTHX_ char *s, STRLEN l)
4381 SV *result = newSVpvn(s, l);
4382 char *result_c = SvPV(result, n_a); /* convenience */
4383 char *out = result_c;
4393 SvREFCNT_dec(result);
4416 SvREFCNT_dec(result);
4422 SvCUR_set(result, out - result_c);
4426 /* pnum must be '\0' terminated */
4428 S_div128(pTHX_ SV *pnum, bool *done)
4431 char *s = SvPV(pnum, len);
4440 i = m * 10 + (*t - '0');
4442 r = (i >> 7); /* r < 10 */
4449 SvCUR_set(pnum, (STRLEN) (t - s));
4456 djSP; dMARK; dORIGMARK; dTARGET;
4457 register SV *cat = TARG;
4460 register char *pat = SvPVx(*++MARK, fromlen);
4462 register char *patend = pat + fromlen;
4467 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4468 static char *space10 = " ";
4470 /* These must not be in registers: */
4485 #ifdef PERL_NATINT_PACK
4486 int natint; /* native integer */
4491 sv_setpvn(cat, "", 0);
4493 while (pat < patend) {
4494 SV *lengthcode = Nullsv;
4495 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4496 datumtype = *pat++ & 0xFF;
4497 #ifdef PERL_NATINT_PACK
4500 if (isSPACE(datumtype)) {
4504 if (datumtype == 'U' && pat == patcopy+1)
4506 if (datumtype == '#') {
4507 while (pat < patend && *pat != '\n')
4512 char *natstr = "sSiIlL";
4514 if (strchr(natstr, datumtype)) {
4515 #ifdef PERL_NATINT_PACK
4521 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4524 len = strchr("@Xxu", datumtype) ? 0 : items;
4527 else if (isDIGIT(*pat)) {
4529 while (isDIGIT(*pat)) {
4530 len = (len * 10) + (*pat++ - '0');
4532 DIE(aTHX_ "Repeat count in pack overflows");
4539 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4540 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4541 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4542 ? *MARK : &PL_sv_no)
4543 + (*pat == 'Z' ? 1 : 0)));
4547 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4548 case ',': /* grandfather in commas but with a warning */
4549 if (commas++ == 0 && ckWARN(WARN_PACK))
4550 Perl_warner(aTHX_ WARN_PACK,
4551 "Invalid type in pack: '%c'", (int)datumtype);
4554 DIE(aTHX_ "%% may only be used in unpack");
4565 if (SvCUR(cat) < len)
4566 DIE(aTHX_ "X outside of string");
4573 sv_catpvn(cat, null10, 10);
4576 sv_catpvn(cat, null10, len);
4582 aptr = SvPV(fromstr, fromlen);
4583 if (pat[-1] == '*') {
4585 if (datumtype == 'Z')
4588 if (fromlen >= len) {
4589 sv_catpvn(cat, aptr, len);
4590 if (datumtype == 'Z')
4591 *(SvEND(cat)-1) = '\0';
4594 sv_catpvn(cat, aptr, fromlen);
4596 if (datumtype == 'A') {
4598 sv_catpvn(cat, space10, 10);
4601 sv_catpvn(cat, space10, len);
4605 sv_catpvn(cat, null10, 10);
4608 sv_catpvn(cat, null10, len);
4620 str = SvPV(fromstr, fromlen);
4624 SvCUR(cat) += (len+7)/8;
4625 SvGROW(cat, SvCUR(cat) + 1);
4626 aptr = SvPVX(cat) + aint;
4631 if (datumtype == 'B') {
4632 for (len = 0; len++ < aint;) {
4633 items |= *str++ & 1;
4637 *aptr++ = items & 0xff;
4643 for (len = 0; len++ < aint;) {
4649 *aptr++ = items & 0xff;
4655 if (datumtype == 'B')
4656 items <<= 7 - (aint & 7);
4658 items >>= 7 - (aint & 7);
4659 *aptr++ = items & 0xff;
4661 str = SvPVX(cat) + SvCUR(cat);
4676 str = SvPV(fromstr, fromlen);
4680 SvCUR(cat) += (len+1)/2;
4681 SvGROW(cat, SvCUR(cat) + 1);
4682 aptr = SvPVX(cat) + aint;
4687 if (datumtype == 'H') {
4688 for (len = 0; len++ < aint;) {
4690 items |= ((*str++ & 15) + 9) & 15;
4692 items |= *str++ & 15;
4696 *aptr++ = items & 0xff;
4702 for (len = 0; len++ < aint;) {
4704 items |= (((*str++ & 15) + 9) & 15) << 4;
4706 items |= (*str++ & 15) << 4;
4710 *aptr++ = items & 0xff;
4716 *aptr++ = items & 0xff;
4717 str = SvPVX(cat) + SvCUR(cat);
4728 aint = SvIV(fromstr);
4730 sv_catpvn(cat, &achar, sizeof(char));
4736 auint = SvUV(fromstr);
4737 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
4738 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4743 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4748 afloat = (float)SvNV(fromstr);
4749 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4756 adouble = (double)SvNV(fromstr);
4757 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4763 ashort = (I16)SvIV(fromstr);
4765 ashort = PerlSock_htons(ashort);
4767 CAT16(cat, &ashort);
4773 ashort = (I16)SvIV(fromstr);
4775 ashort = htovs(ashort);
4777 CAT16(cat, &ashort);
4781 #if SHORTSIZE != SIZE16
4783 unsigned short aushort;
4787 aushort = SvUV(fromstr);
4788 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4798 aushort = (U16)SvUV(fromstr);
4799 CAT16(cat, &aushort);
4805 #if SHORTSIZE != SIZE16
4811 ashort = SvIV(fromstr);
4812 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4820 ashort = (I16)SvIV(fromstr);
4821 CAT16(cat, &ashort);
4828 auint = SvUV(fromstr);
4829 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4835 adouble = Perl_floor(SvNV(fromstr));
4838 DIE(aTHX_ "Cannot compress negative numbers");
4841 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4842 adouble <= 0xffffffff
4844 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4845 adouble <= UV_MAX_cxux
4852 char buf[1 + sizeof(UV)];
4853 char *in = buf + sizeof(buf);
4854 UV auv = U_V(adouble);
4857 *--in = (auv & 0x7f) | 0x80;
4860 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4861 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4863 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4864 char *from, *result, *in;
4869 /* Copy string and check for compliance */
4870 from = SvPV(fromstr, len);
4871 if ((norm = is_an_int(from, len)) == NULL)
4872 DIE(aTHX_ "can compress only unsigned integer");
4874 New('w', result, len, char);
4878 *--in = div128(norm, &done) | 0x80;
4879 result[len - 1] &= 0x7F; /* clear continue bit */
4880 sv_catpvn(cat, in, (result + len) - in);
4882 SvREFCNT_dec(norm); /* free norm */
4884 else if (SvNOKp(fromstr)) {
4885 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4886 char *in = buf + sizeof(buf);
4889 double next = floor(adouble / 128);
4890 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4891 if (in <= buf) /* this cannot happen ;-) */
4892 DIE(aTHX_ "Cannot compress integer");
4895 } while (adouble > 0);
4896 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4897 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4900 DIE(aTHX_ "Cannot compress non integer");
4906 aint = SvIV(fromstr);
4907 sv_catpvn(cat, (char*)&aint, sizeof(int));
4913 aulong = SvUV(fromstr);
4915 aulong = PerlSock_htonl(aulong);
4917 CAT32(cat, &aulong);
4923 aulong = SvUV(fromstr);
4925 aulong = htovl(aulong);
4927 CAT32(cat, &aulong);
4931 #if LONGSIZE != SIZE32
4933 unsigned long aulong;
4937 aulong = SvUV(fromstr);
4938 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4946 aulong = SvUV(fromstr);
4947 CAT32(cat, &aulong);
4952 #if LONGSIZE != SIZE32
4958 along = SvIV(fromstr);
4959 sv_catpvn(cat, (char *)&along, sizeof(long));
4967 along = SvIV(fromstr);
4976 auquad = (Uquad_t)SvUV(fromstr);
4977 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4983 aquad = (Quad_t)SvIV(fromstr);
4984 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4989 len = 1; /* assume SV is correct length */
4994 if (fromstr == &PL_sv_undef)
4998 /* XXX better yet, could spirit away the string to
4999 * a safe spot and hang on to it until the result
5000 * of pack() (and all copies of the result) are
5003 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
5004 || (SvPADTMP(fromstr)
5005 && !SvREADONLY(fromstr))))
5007 Perl_warner(aTHX_ WARN_PACK,
5008 "Attempt to pack pointer to temporary value");
5010 if (SvPOK(fromstr) || SvNIOK(fromstr))
5011 aptr = SvPV(fromstr,n_a);
5013 aptr = SvPV_force(fromstr,n_a);
5015 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5020 aptr = SvPV(fromstr, fromlen);
5021 SvGROW(cat, fromlen * 4 / 3);
5026 while (fromlen > 0) {
5033 doencodes(cat, aptr, todo);
5052 register IV limit = POPi; /* note, negative is forever */
5054 bool doutf8 = DO_UTF8(sv);
5056 register char *s = SvPV(sv, len);
5057 char *strend = s + len;
5059 register REGEXP *rx;
5063 I32 maxiters = (strend - s) + 10;
5066 I32 origlimit = limit;
5069 AV *oldstack = PL_curstack;
5070 I32 gimme = GIMME_V;
5071 I32 oldsave = PL_savestack_ix;
5072 I32 make_mortal = 1;
5073 MAGIC *mg = (MAGIC *) NULL;
5076 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5081 DIE(aTHX_ "panic: do_split");
5082 rx = pm->op_pmregexp;
5084 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5085 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5087 if (pm->op_pmreplroot) {
5089 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5091 ary = GvAVn((GV*)pm->op_pmreplroot);
5094 else if (gimme != G_ARRAY)
5096 ary = (AV*)PL_curpad[0];
5098 ary = GvAVn(PL_defgv);
5099 #endif /* USE_THREADS */
5102 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5108 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5110 XPUSHs(SvTIED_obj((SV*)ary, mg));
5116 for (i = AvFILLp(ary); i >= 0; i--)
5117 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5119 /* temporarily switch stacks */
5120 SWITCHSTACK(PL_curstack, ary);
5124 base = SP - PL_stack_base;
5126 if (pm->op_pmflags & PMf_SKIPWHITE) {
5127 if (pm->op_pmflags & PMf_LOCALE) {
5128 while (isSPACE_LC(*s))
5136 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5137 SAVEINT(PL_multiline);
5138 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5142 limit = maxiters + 2;
5143 if (pm->op_pmflags & PMf_WHITE) {
5146 while (m < strend &&
5147 !((pm->op_pmflags & PMf_LOCALE)
5148 ? isSPACE_LC(*m) : isSPACE(*m)))
5153 dstr = NEWSV(30, m-s);
5154 sv_setpvn(dstr, s, m-s);
5158 (void)SvUTF8_on(dstr);
5162 while (s < strend &&
5163 ((pm->op_pmflags & PMf_LOCALE)
5164 ? isSPACE_LC(*s) : isSPACE(*s)))
5168 else if (strEQ("^", rx->precomp)) {
5171 for (m = s; m < strend && *m != '\n'; m++) ;
5175 dstr = NEWSV(30, m-s);
5176 sv_setpvn(dstr, s, m-s);
5180 (void)SvUTF8_on(dstr);
5185 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5186 && (rx->reganch & ROPT_CHECK_ALL)
5187 && !(rx->reganch & ROPT_ANCH)) {
5188 int tail = (rx->reganch & RE_INTUIT_TAIL);
5189 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5192 if (len == 1 && !tail) {
5194 char c = *SvPV(csv, n_a);
5197 for (m = s; m < strend && *m != c; m++) ;
5200 dstr = NEWSV(30, m-s);
5201 sv_setpvn(dstr, s, m-s);
5205 (void)SvUTF8_on(dstr);
5207 /* The rx->minlen is in characters but we want to step
5208 * s ahead by bytes. */
5209 s = m + (doutf8 ? SvCUR(csv) : len);
5214 while (s < strend && --limit &&
5215 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5216 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5219 dstr = NEWSV(31, m-s);
5220 sv_setpvn(dstr, s, m-s);
5224 (void)SvUTF8_on(dstr);
5226 /* The rx->minlen is in characters but we want to step
5227 * s ahead by bytes. */
5228 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5233 maxiters += (strend - s) * rx->nparens;
5234 while (s < strend && --limit
5235 /* && (!rx->check_substr
5236 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5238 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5239 1 /* minend */, sv, NULL, 0))
5241 TAINT_IF(RX_MATCH_TAINTED(rx));
5242 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5247 strend = s + (strend - m);
5249 m = rx->startp[0] + orig;
5250 dstr = NEWSV(32, m-s);
5251 sv_setpvn(dstr, s, m-s);
5255 (void)SvUTF8_on(dstr);
5258 for (i = 1; i <= rx->nparens; i++) {
5259 s = rx->startp[i] + orig;
5260 m = rx->endp[i] + orig;
5262 dstr = NEWSV(33, m-s);
5263 sv_setpvn(dstr, s, m-s);
5266 dstr = NEWSV(33, 0);
5270 (void)SvUTF8_on(dstr);
5274 s = rx->endp[0] + orig;
5278 LEAVE_SCOPE(oldsave);
5279 iters = (SP - PL_stack_base) - base;
5280 if (iters > maxiters)
5281 DIE(aTHX_ "Split loop");
5283 /* keep field after final delim? */
5284 if (s < strend || (iters && origlimit)) {
5285 STRLEN l = strend - s;
5286 dstr = NEWSV(34, l);
5287 sv_setpvn(dstr, s, l);
5291 (void)SvUTF8_on(dstr);
5295 else if (!origlimit) {
5296 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5302 SWITCHSTACK(ary, oldstack);
5303 if (SvSMAGICAL(ary)) {
5308 if (gimme == G_ARRAY) {
5310 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5318 call_method("PUSH",G_SCALAR|G_DISCARD);
5321 if (gimme == G_ARRAY) {
5322 /* EXTEND should not be needed - we just popped them */
5324 for (i=0; i < iters; i++) {
5325 SV **svp = av_fetch(ary, i, FALSE);
5326 PUSHs((svp) ? *svp : &PL_sv_undef);
5333 if (gimme == G_ARRAY)
5336 if (iters || !pm->op_pmreplroot) {
5346 Perl_unlock_condpair(pTHX_ void *svv)
5348 MAGIC *mg = mg_find((SV*)svv, 'm');
5351 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5352 MUTEX_LOCK(MgMUTEXP(mg));
5353 if (MgOWNER(mg) != thr)
5354 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5356 COND_SIGNAL(MgOWNERCONDP(mg));
5357 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5358 PTR2UV(thr), PTR2UV(svv));)
5359 MUTEX_UNLOCK(MgMUTEXP(mg));
5361 #endif /* USE_THREADS */
5370 #endif /* USE_THREADS */
5371 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5372 || SvTYPE(retsv) == SVt_PVCV) {
5373 retsv = refto(retsv);
5384 if (PL_op->op_private & OPpLVAL_INTRO)
5385 PUSHs(*save_threadsv(PL_op->op_targ));
5387 PUSHs(THREADSV(PL_op->op_targ));
5390 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5391 #endif /* USE_THREADS */