3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if LONGSIZE > 4 && defined(_CRAY)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
89 /* XXX I can't imagine anyone who doesn't have this actually _needs_
90 it, since pid_t is an integral type.
93 #ifdef NEED_GETPID_PROTO
94 extern Pid_t getpid (void);
100 if (GIMME_V == G_SCALAR)
101 XPUSHs(&PL_sv_undef);
115 if (PL_op->op_private & OPpLVAL_INTRO)
116 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
118 if (PL_op->op_flags & OPf_REF) {
122 if (GIMME == G_ARRAY) {
123 I32 maxarg = AvFILL((AV*)TARG) + 1;
125 if (SvMAGICAL(TARG)) {
127 for (i=0; i < maxarg; i++) {
128 SV **svp = av_fetch((AV*)TARG, i, FALSE);
129 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
133 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
138 SV* sv = sv_newmortal();
139 I32 maxarg = AvFILL((AV*)TARG) + 1;
140 sv_setiv(sv, maxarg);
152 if (PL_op->op_private & OPpLVAL_INTRO)
153 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
154 if (PL_op->op_flags & OPf_REF)
157 if (gimme == G_ARRAY) {
160 else if (gimme == G_SCALAR) {
161 SV* sv = sv_newmortal();
162 if (HvFILL((HV*)TARG))
163 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
164 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
174 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
185 tryAMAGICunDEREF(to_gv);
188 if (SvTYPE(sv) == SVt_PVIO) {
189 GV *gv = (GV*) sv_newmortal();
190 gv_init(gv, 0, "", 0, 0);
191 GvIOp(gv) = (IO *)sv;
192 (void)SvREFCNT_inc(sv);
195 else if (SvTYPE(sv) != SVt_PVGV)
196 DIE(aTHX_ "Not a GLOB reference");
199 if (SvTYPE(sv) != SVt_PVGV) {
203 if (SvGMAGICAL(sv)) {
208 if (!SvOK(sv) && sv != &PL_sv_undef) {
209 /* If this is a 'my' scalar and flag is set then vivify
212 if (PL_op->op_private & OPpDEREF) {
215 if (cUNOP->op_targ) {
217 SV *namesv = PL_curpad[cUNOP->op_targ];
218 name = SvPV(namesv, len);
219 gv = (GV*)NEWSV(0,0);
220 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
223 name = CopSTASHPV(PL_curcop);
226 sv_upgrade(sv, SVt_RV);
232 if (PL_op->op_flags & OPf_REF ||
233 PL_op->op_private & HINT_STRICT_REFS)
234 DIE(aTHX_ PL_no_usym, "a symbol");
235 if (ckWARN(WARN_UNINITIALIZED))
240 if ((PL_op->op_flags & OPf_SPECIAL) &&
241 !(PL_op->op_flags & OPf_MOD))
243 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
245 && (!is_gv_magical(sym,len,0)
246 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
252 if (PL_op->op_private & HINT_STRICT_REFS)
253 DIE(aTHX_ PL_no_symref, sym, "a symbol");
254 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
258 if (PL_op->op_private & OPpLVAL_INTRO)
259 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
270 tryAMAGICunDEREF(to_sv);
273 switch (SvTYPE(sv)) {
277 DIE(aTHX_ "Not a SCALAR reference");
285 if (SvTYPE(gv) != SVt_PVGV) {
286 if (SvGMAGICAL(sv)) {
292 if (PL_op->op_flags & OPf_REF ||
293 PL_op->op_private & HINT_STRICT_REFS)
294 DIE(aTHX_ PL_no_usym, "a SCALAR");
295 if (ckWARN(WARN_UNINITIALIZED))
300 if ((PL_op->op_flags & OPf_SPECIAL) &&
301 !(PL_op->op_flags & OPf_MOD))
303 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
305 && (!is_gv_magical(sym,len,0)
306 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
312 if (PL_op->op_private & HINT_STRICT_REFS)
313 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
314 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
319 if (PL_op->op_flags & OPf_MOD) {
320 if (PL_op->op_private & OPpLVAL_INTRO)
321 sv = save_scalar((GV*)TOPs);
322 else if (PL_op->op_private & OPpDEREF)
323 vivify_ref(sv, PL_op->op_private & OPpDEREF);
333 SV *sv = AvARYLEN(av);
335 AvARYLEN(av) = sv = NEWSV(0,0);
336 sv_upgrade(sv, SVt_IV);
337 sv_magic(sv, (SV*)av, '#', Nullch, 0);
345 djSP; dTARGET; dPOPss;
347 if (PL_op->op_flags & OPf_MOD) {
348 if (SvTYPE(TARG) < SVt_PVLV) {
349 sv_upgrade(TARG, SVt_PVLV);
350 sv_magic(TARG, Nullsv, '.', Nullch, 0);
354 if (LvTARG(TARG) != sv) {
356 SvREFCNT_dec(LvTARG(TARG));
357 LvTARG(TARG) = SvREFCNT_inc(sv);
359 PUSHs(TARG); /* no SvSETMAGIC */
365 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
366 mg = mg_find(sv, 'g');
367 if (mg && mg->mg_len >= 0) {
371 PUSHi(i + PL_curcop->cop_arybase);
385 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
386 /* (But not in defined().) */
387 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
390 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
391 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
392 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
395 cv = (CV*)&PL_sv_undef;
409 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
410 char *s = SvPVX(TOPs);
411 if (strnEQ(s, "CORE::", 6)) {
414 code = keyword(s + 6, SvCUR(TOPs) - 6);
415 if (code < 0) { /* Overridable. */
416 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
417 int i = 0, n = 0, seen_question = 0;
419 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
421 while (i < MAXO) { /* The slow way. */
422 if (strEQ(s + 6, PL_op_name[i])
423 || strEQ(s + 6, PL_op_desc[i]))
429 goto nonesuch; /* Should not happen... */
431 oa = PL_opargs[i] >> OASHIFT;
433 if (oa & OA_OPTIONAL) {
437 else if (n && str[0] == ';' && seen_question)
438 goto set; /* XXXX system, exec */
439 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
440 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
443 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
444 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
448 ret = sv_2mortal(newSVpvn(str, n - 1));
450 else if (code) /* Non-Overridable */
452 else { /* None such */
454 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
458 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
460 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
469 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
471 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
487 if (GIMME != G_ARRAY) {
491 *MARK = &PL_sv_undef;
492 *MARK = refto(*MARK);
496 EXTEND_MORTAL(SP - MARK);
498 *MARK = refto(*MARK);
503 S_refto(pTHX_ SV *sv)
507 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
510 if (!(sv = LvTARG(sv)))
513 (void)SvREFCNT_inc(sv);
515 else if (SvTYPE(sv) == SVt_PVAV) {
516 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
519 (void)SvREFCNT_inc(sv);
521 else if (SvPADTMP(sv))
525 (void)SvREFCNT_inc(sv);
528 sv_upgrade(rv, SVt_RV);
542 if (sv && SvGMAGICAL(sv))
545 if (!sv || !SvROK(sv))
549 pv = sv_reftype(sv,TRUE);
550 PUSHp(pv, strlen(pv));
560 stash = CopSTASH(PL_curcop);
566 if (ssv && SvGMAGICAL(ssv))
569 Perl_croak(aTHX_ "Attempt to bless into a reference");
571 if (ckWARN(WARN_MISC) && len == 0)
572 Perl_warner(aTHX_ WARN_MISC,
573 "Explicit blessing to '' (assuming package main)");
574 stash = gv_stashpvn(ptr, len, TRUE);
577 (void)sv_bless(TOPs, stash);
591 elem = SvPV(sv, n_a);
595 switch (elem ? *elem : '\0')
598 if (strEQ(elem, "ARRAY"))
599 tmpRef = (SV*)GvAV(gv);
602 if (strEQ(elem, "CODE"))
603 tmpRef = (SV*)GvCVu(gv);
606 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
607 tmpRef = (SV*)GvIOp(gv);
609 if (strEQ(elem, "FORMAT"))
610 tmpRef = (SV*)GvFORM(gv);
613 if (strEQ(elem, "GLOB"))
617 if (strEQ(elem, "HASH"))
618 tmpRef = (SV*)GvHV(gv);
621 if (strEQ(elem, "IO"))
622 tmpRef = (SV*)GvIOp(gv);
625 if (strEQ(elem, "NAME"))
626 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
629 if (strEQ(elem, "PACKAGE"))
630 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
633 if (strEQ(elem, "SCALAR"))
647 /* Pattern matching */
652 register unsigned char *s;
655 register I32 *sfirst;
659 if (sv == PL_lastscream) {
665 SvSCREAM_off(PL_lastscream);
666 SvREFCNT_dec(PL_lastscream);
668 PL_lastscream = SvREFCNT_inc(sv);
671 s = (unsigned char*)(SvPV(sv, len));
675 if (pos > PL_maxscream) {
676 if (PL_maxscream < 0) {
677 PL_maxscream = pos + 80;
678 New(301, PL_screamfirst, 256, I32);
679 New(302, PL_screamnext, PL_maxscream, I32);
682 PL_maxscream = pos + pos / 4;
683 Renew(PL_screamnext, PL_maxscream, I32);
687 sfirst = PL_screamfirst;
688 snext = PL_screamnext;
690 if (!sfirst || !snext)
691 DIE(aTHX_ "do_study: out of memory");
693 for (ch = 256; ch; --ch)
700 snext[pos] = sfirst[ch] - pos;
707 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
716 if (PL_op->op_flags & OPf_STACKED)
722 TARG = sv_newmortal();
727 /* Lvalue operators. */
739 djSP; dMARK; dTARGET;
749 SETi(do_chomp(TOPs));
755 djSP; dMARK; dTARGET;
756 register I32 count = 0;
759 count += do_chomp(POPs);
770 if (!sv || !SvANY(sv))
772 switch (SvTYPE(sv)) {
774 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
778 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
782 if (CvROOT(sv) || CvXSUB(sv))
799 if (!PL_op->op_private) {
808 if (SvTHINKFIRST(sv))
811 switch (SvTYPE(sv)) {
821 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
822 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
823 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
827 /* let user-undef'd sub keep its identity */
828 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
835 SvSetMagicSV(sv, &PL_sv_undef);
839 Newz(602, gp, 1, GP);
840 GvGP(sv) = gp_ref(gp);
841 GvSV(sv) = NEWSV(72,0);
842 GvLINE(sv) = CopLINE(PL_curcop);
848 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
851 SvPV_set(sv, Nullch);
864 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
865 DIE(aTHX_ PL_no_modify);
866 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
867 SvIVX(TOPs) != IV_MIN)
870 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
881 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
882 DIE(aTHX_ PL_no_modify);
883 sv_setsv(TARG, TOPs);
884 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
885 SvIVX(TOPs) != IV_MAX)
888 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
902 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
903 DIE(aTHX_ PL_no_modify);
904 sv_setsv(TARG, TOPs);
905 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
906 SvIVX(TOPs) != IV_MIN)
909 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
918 /* Ordinary operators. */
922 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
925 SETn( Perl_pow( left, right) );
932 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
935 SETn( left * right );
942 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
947 DIE(aTHX_ "Illegal division by zero");
949 /* insure that 20./5. == 4. */
952 if ((NV)I_V(left) == left &&
953 (NV)I_V(right) == right &&
954 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
958 value = left / right;
962 value = left / right;
971 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
981 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
983 right = (right_neg = (i < 0)) ? -i : i;
988 right_neg = dright < 0;
993 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
995 left = (left_neg = (i < 0)) ? -i : i;
1003 left_neg = dleft < 0;
1012 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1014 # define CAST_D2UV(d) U_V(d)
1016 # define CAST_D2UV(d) ((UV)(d))
1018 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1019 * or, in other words, precision of UV more than of NV.
1020 * But in fact the approach below turned out to be an
1021 * optimization - floor() may be slow */
1022 if (dright <= UV_MAX && dleft <= UV_MAX) {
1023 right = CAST_D2UV(dright);
1024 left = CAST_D2UV(dleft);
1029 /* Backward-compatibility clause: */
1030 dright = Perl_floor(dright + 0.5);
1031 dleft = Perl_floor(dleft + 0.5);
1034 DIE(aTHX_ "Illegal modulus zero");
1036 dans = Perl_fmod(dleft, dright);
1037 if ((left_neg != right_neg) && dans)
1038 dans = dright - dans;
1041 sv_setnv(TARG, dans);
1048 DIE(aTHX_ "Illegal modulus zero");
1051 if ((left_neg != right_neg) && ans)
1054 /* XXX may warn: unary minus operator applied to unsigned type */
1055 /* could change -foo to be (~foo)+1 instead */
1056 if (ans <= ~((UV)IV_MAX)+1)
1057 sv_setiv(TARG, ~ans+1);
1059 sv_setnv(TARG, -(NV)ans);
1062 sv_setuv(TARG, ans);
1071 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1073 register I32 count = POPi;
1074 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1076 I32 items = SP - MARK;
1079 max = items * count;
1088 repeatcpy((char*)(MARK + items), (char*)MARK,
1089 items * sizeof(SV*), count - 1);
1092 else if (count <= 0)
1095 else { /* Note: mark already snarfed by pp_list */
1098 bool isutf = DO_UTF8(tmpstr);
1100 SvSetSV(TARG, tmpstr);
1101 SvPV_force(TARG, len);
1106 SvGROW(TARG, (count * len) + 1);
1107 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1108 SvCUR(TARG) *= count;
1110 *SvEND(TARG) = '\0';
1113 (void)SvPOK_only_UTF8(TARG);
1115 (void)SvPOK_only(TARG);
1124 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1127 SETn( left - right );
1134 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1137 if (PL_op->op_private & HINT_INTEGER) {
1151 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1154 if (PL_op->op_private & HINT_INTEGER) {
1168 djSP; tryAMAGICbinSET(lt,0);
1171 SETs(boolSV(TOPn < value));
1178 djSP; tryAMAGICbinSET(gt,0);
1181 SETs(boolSV(TOPn > value));
1188 djSP; tryAMAGICbinSET(le,0);
1191 SETs(boolSV(TOPn <= value));
1198 djSP; tryAMAGICbinSET(ge,0);
1201 SETs(boolSV(TOPn >= value));
1208 djSP; tryAMAGICbinSET(ne,0);
1211 SETs(boolSV(TOPn != value));
1218 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1224 if (Perl_isnan(left) || Perl_isnan(right)) {
1228 value = (left > right) - (left < right);
1232 else if (left < right)
1234 else if (left > right)
1248 djSP; tryAMAGICbinSET(slt,0);
1251 int cmp = ((PL_op->op_private & OPpLOCALE)
1252 ? sv_cmp_locale(left, right)
1253 : sv_cmp(left, right));
1254 SETs(boolSV(cmp < 0));
1261 djSP; tryAMAGICbinSET(sgt,0);
1264 int cmp = ((PL_op->op_private & OPpLOCALE)
1265 ? sv_cmp_locale(left, right)
1266 : sv_cmp(left, right));
1267 SETs(boolSV(cmp > 0));
1274 djSP; tryAMAGICbinSET(sle,0);
1277 int cmp = ((PL_op->op_private & OPpLOCALE)
1278 ? sv_cmp_locale(left, right)
1279 : sv_cmp(left, right));
1280 SETs(boolSV(cmp <= 0));
1287 djSP; tryAMAGICbinSET(sge,0);
1290 int cmp = ((PL_op->op_private & OPpLOCALE)
1291 ? sv_cmp_locale(left, right)
1292 : sv_cmp(left, right));
1293 SETs(boolSV(cmp >= 0));
1300 djSP; tryAMAGICbinSET(seq,0);
1303 SETs(boolSV(sv_eq(left, right)));
1310 djSP; tryAMAGICbinSET(sne,0);
1313 SETs(boolSV(!sv_eq(left, right)));
1320 djSP; dTARGET; tryAMAGICbin(scmp,0);
1323 int cmp = ((PL_op->op_private & OPpLOCALE)
1324 ? sv_cmp_locale(left, right)
1325 : sv_cmp(left, right));
1333 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1336 if (SvNIOKp(left) || SvNIOKp(right)) {
1337 if (PL_op->op_private & HINT_INTEGER) {
1338 IV i = SvIV(left) & SvIV(right);
1342 UV u = SvUV(left) & SvUV(right);
1347 do_vop(PL_op->op_type, TARG, left, right);
1356 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1359 if (SvNIOKp(left) || SvNIOKp(right)) {
1360 if (PL_op->op_private & HINT_INTEGER) {
1361 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1365 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1370 do_vop(PL_op->op_type, TARG, left, right);
1379 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1382 if (SvNIOKp(left) || SvNIOKp(right)) {
1383 if (PL_op->op_private & HINT_INTEGER) {
1384 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1388 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1393 do_vop(PL_op->op_type, TARG, left, right);
1402 djSP; dTARGET; tryAMAGICun(neg);
1407 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1409 if (SvIVX(sv) == IV_MIN) {
1410 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1413 else if (SvUVX(sv) <= IV_MAX) {
1418 else if (SvIVX(sv) != IV_MIN) {
1425 else if (SvPOKp(sv)) {
1427 char *s = SvPV(sv, len);
1428 if (isIDFIRST(*s)) {
1429 sv_setpvn(TARG, "-", 1);
1432 else if (*s == '+' || *s == '-') {
1434 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1436 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1437 sv_setpvn(TARG, "-", 1);
1441 sv_setnv(TARG, -SvNV(sv));
1452 djSP; tryAMAGICunSET(not);
1453 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1459 djSP; dTARGET; tryAMAGICun(compl);
1463 if (PL_op->op_private & HINT_INTEGER) {
1473 register char *tmps;
1474 register long *tmpl;
1479 tmps = SvPV_force(TARG, len);
1482 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1485 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1489 for ( ; anum > 0; anum--, tmps++)
1498 /* integer versions of some of the above */
1502 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1505 SETi( left * right );
1512 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1516 DIE(aTHX_ "Illegal division by zero");
1517 value = POPi / value;
1525 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1529 DIE(aTHX_ "Illegal modulus zero");
1530 SETi( left % right );
1537 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1540 SETi( left + right );
1547 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1550 SETi( left - right );
1557 djSP; tryAMAGICbinSET(lt,0);
1560 SETs(boolSV(left < right));
1567 djSP; tryAMAGICbinSET(gt,0);
1570 SETs(boolSV(left > right));
1577 djSP; tryAMAGICbinSET(le,0);
1580 SETs(boolSV(left <= right));
1587 djSP; tryAMAGICbinSET(ge,0);
1590 SETs(boolSV(left >= right));
1597 djSP; tryAMAGICbinSET(eq,0);
1600 SETs(boolSV(left == right));
1607 djSP; tryAMAGICbinSET(ne,0);
1610 SETs(boolSV(left != right));
1617 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1624 else if (left < right)
1635 djSP; dTARGET; tryAMAGICun(neg);
1640 /* High falutin' math. */
1644 djSP; dTARGET; tryAMAGICbin(atan2,0);
1647 SETn(Perl_atan2(left, right));
1654 djSP; dTARGET; tryAMAGICun(sin);
1658 value = Perl_sin(value);
1666 djSP; dTARGET; tryAMAGICun(cos);
1670 value = Perl_cos(value);
1676 /* Support Configure command-line overrides for rand() functions.
1677 After 5.005, perhaps we should replace this by Configure support
1678 for drand48(), random(), or rand(). For 5.005, though, maintain
1679 compatibility by calling rand() but allow the user to override it.
1680 See INSTALL for details. --Andy Dougherty 15 July 1998
1682 /* Now it's after 5.005, and Configure supports drand48() and random(),
1683 in addition to rand(). So the overrides should not be needed any more.
1684 --Jarkko Hietaniemi 27 September 1998
1687 #ifndef HAS_DRAND48_PROTO
1688 extern double drand48 (void);
1701 if (!PL_srand_called) {
1702 (void)seedDrand01((Rand_seed_t)seed());
1703 PL_srand_called = TRUE;
1718 (void)seedDrand01((Rand_seed_t)anum);
1719 PL_srand_called = TRUE;
1728 * This is really just a quick hack which grabs various garbage
1729 * values. It really should be a real hash algorithm which
1730 * spreads the effect of every input bit onto every output bit,
1731 * if someone who knows about such things would bother to write it.
1732 * Might be a good idea to add that function to CORE as well.
1733 * No numbers below come from careful analysis or anything here,
1734 * except they are primes and SEED_C1 > 1E6 to get a full-width
1735 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1736 * probably be bigger too.
1739 # define SEED_C1 1000003
1740 #define SEED_C4 73819
1742 # define SEED_C1 25747
1743 #define SEED_C4 20639
1747 #define SEED_C5 26107
1750 #ifndef PERL_NO_DEV_RANDOM
1755 # include <starlet.h>
1756 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1757 * in 100-ns units, typically incremented ever 10 ms. */
1758 unsigned int when[2];
1760 # ifdef HAS_GETTIMEOFDAY
1761 struct timeval when;
1767 /* This test is an escape hatch, this symbol isn't set by Configure. */
1768 #ifndef PERL_NO_DEV_RANDOM
1769 #ifndef PERL_RANDOM_DEVICE
1770 /* /dev/random isn't used by default because reads from it will block
1771 * if there isn't enough entropy available. You can compile with
1772 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1773 * is enough real entropy to fill the seed. */
1774 # define PERL_RANDOM_DEVICE "/dev/urandom"
1776 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1778 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1787 _ckvmssts(sys$gettim(when));
1788 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1790 # ifdef HAS_GETTIMEOFDAY
1791 gettimeofday(&when,(struct timezone *) 0);
1792 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1795 u = (U32)SEED_C1 * when;
1798 u += SEED_C3 * (U32)PerlProc_getpid();
1799 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1800 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1801 u += SEED_C5 * (U32)PTR2UV(&when);
1808 djSP; dTARGET; tryAMAGICun(exp);
1812 value = Perl_exp(value);
1820 djSP; dTARGET; tryAMAGICun(log);
1825 RESTORE_NUMERIC_STANDARD();
1826 DIE(aTHX_ "Can't take log of %g", value);
1828 value = Perl_log(value);
1836 djSP; dTARGET; tryAMAGICun(sqrt);
1841 RESTORE_NUMERIC_STANDARD();
1842 DIE(aTHX_ "Can't take sqrt of %g", value);
1844 value = Perl_sqrt(value);
1857 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1863 (void)Perl_modf(value, &value);
1865 (void)Perl_modf(-value, &value);
1880 djSP; dTARGET; tryAMAGICun(abs);
1885 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1886 (iv = SvIVX(TOPs)) != IV_MIN) {
1908 argtype = 1; /* allow underscores */
1909 XPUSHn(scan_hex(tmps, 99, &argtype));
1922 while (*tmps && isSPACE(*tmps))
1926 argtype = 1; /* allow underscores */
1928 value = scan_hex(++tmps, 99, &argtype);
1929 else if (*tmps == 'b')
1930 value = scan_bin(++tmps, 99, &argtype);
1932 value = scan_oct(tmps, 99, &argtype);
1945 SETi(sv_len_utf8(sv));
1961 I32 lvalue = PL_op->op_flags & OPf_MOD;
1963 I32 arybase = PL_curcop->cop_arybase;
1967 SvTAINTED_off(TARG); /* decontaminate */
1968 SvUTF8_off(TARG); /* decontaminate */
1972 repl = SvPV(sv, repl_len);
1979 tmps = SvPV(sv, curlen);
1981 utfcurlen = sv_len_utf8(sv);
1982 if (utfcurlen == curlen)
1990 if (pos >= arybase) {
2008 else if (len >= 0) {
2010 if (rem > (I32)curlen)
2025 Perl_croak(aTHX_ "substr outside of string");
2026 if (ckWARN(WARN_SUBSTR))
2027 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2032 sv_pos_u2b(sv, &pos, &rem);
2034 sv_setpvn(TARG, tmps, rem);
2038 sv_insert(sv, pos, rem, repl, repl_len);
2039 else if (lvalue) { /* it's an lvalue! */
2040 if (!SvGMAGICAL(sv)) {
2044 if (ckWARN(WARN_SUBSTR))
2045 Perl_warner(aTHX_ WARN_SUBSTR,
2046 "Attempt to use reference as lvalue in substr");
2048 if (SvOK(sv)) /* is it defined ? */
2049 (void)SvPOK_only_UTF8(sv);
2051 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2054 if (SvTYPE(TARG) < SVt_PVLV) {
2055 sv_upgrade(TARG, SVt_PVLV);
2056 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2060 if (LvTARG(TARG) != sv) {
2062 SvREFCNT_dec(LvTARG(TARG));
2063 LvTARG(TARG) = SvREFCNT_inc(sv);
2065 LvTARGOFF(TARG) = pos;
2066 LvTARGLEN(TARG) = rem;
2070 PUSHs(TARG); /* avoid SvSETMAGIC here */
2077 register I32 size = POPi;
2078 register I32 offset = POPi;
2079 register SV *src = POPs;
2080 I32 lvalue = PL_op->op_flags & OPf_MOD;
2082 SvTAINTED_off(TARG); /* decontaminate */
2083 if (lvalue) { /* it's an lvalue! */
2084 if (SvTYPE(TARG) < SVt_PVLV) {
2085 sv_upgrade(TARG, SVt_PVLV);
2086 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2089 if (LvTARG(TARG) != src) {
2091 SvREFCNT_dec(LvTARG(TARG));
2092 LvTARG(TARG) = SvREFCNT_inc(src);
2094 LvTARGOFF(TARG) = offset;
2095 LvTARGLEN(TARG) = size;
2098 sv_setuv(TARG, do_vecget(src, offset, size));
2113 I32 arybase = PL_curcop->cop_arybase;
2118 offset = POPi - arybase;
2121 tmps = SvPV(big, biglen);
2122 if (offset > 0 && DO_UTF8(big))
2123 sv_pos_u2b(big, &offset, 0);
2126 else if (offset > biglen)
2128 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2129 (unsigned char*)tmps + biglen, little, 0)))
2132 retval = tmps2 - tmps;
2133 if (retval > 0 && DO_UTF8(big))
2134 sv_pos_b2u(big, &retval);
2135 PUSHi(retval + arybase);
2150 I32 arybase = PL_curcop->cop_arybase;
2156 tmps2 = SvPV(little, llen);
2157 tmps = SvPV(big, blen);
2161 if (offset > 0 && DO_UTF8(big))
2162 sv_pos_u2b(big, &offset, 0);
2163 offset = offset - arybase + llen;
2167 else if (offset > blen)
2169 if (!(tmps2 = rninstr(tmps, tmps + offset,
2170 tmps2, tmps2 + llen)))
2173 retval = tmps2 - tmps;
2174 if (retval > 0 && DO_UTF8(big))
2175 sv_pos_b2u(big, &retval);
2176 PUSHi(retval + arybase);
2182 djSP; dMARK; dORIGMARK; dTARGET;
2183 do_sprintf(TARG, SP-MARK, MARK+1);
2184 TAINT_IF(SvTAINTED(TARG));
2196 U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
2199 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2200 value = utf8_to_uv(tmps, &retlen);
2202 value = (UV)(*tmps & 255);
2213 (void)SvUPGRADE(TARG,SVt_PV);
2215 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2216 SvGROW(TARG, UTF8_MAXLEN+1);
2218 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2219 SvCUR_set(TARG, tmps - SvPVX(TARG));
2221 (void)SvPOK_only(TARG);
2232 (void)SvPOK_only(TARG);
2239 djSP; dTARGET; dPOPTOPssrl;
2242 char *tmps = SvPV(left, n_a);
2244 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2246 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2250 "The crypt() function is unimplemented due to excessive paranoia.");
2263 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2265 U8 tmpbuf[UTF8_MAXLEN];
2267 UV uv = utf8_to_uv(s, &ulen);
2269 if (PL_op->op_private & OPpLOCALE) {
2272 uv = toTITLE_LC_uni(uv);
2275 uv = toTITLE_utf8(s);
2277 tend = uv_to_utf8(tmpbuf, uv);
2279 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2281 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2282 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2287 s = (U8*)SvPV_force(sv, slen);
2288 Copy(tmpbuf, s, ulen, U8);
2292 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2294 SvUTF8_off(TARG); /* decontaminate */
2299 s = (U8*)SvPV_force(sv, slen);
2301 if (PL_op->op_private & OPpLOCALE) {
2304 *s = toUPPER_LC(*s);
2322 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2324 U8 tmpbuf[UTF8_MAXLEN];
2326 UV uv = utf8_to_uv(s, &ulen);
2328 if (PL_op->op_private & OPpLOCALE) {
2331 uv = toLOWER_LC_uni(uv);
2334 uv = toLOWER_utf8(s);
2336 tend = uv_to_utf8(tmpbuf, uv);
2338 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2340 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2341 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2346 s = (U8*)SvPV_force(sv, slen);
2347 Copy(tmpbuf, s, ulen, U8);
2351 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2353 SvUTF8_off(TARG); /* decontaminate */
2358 s = (U8*)SvPV_force(sv, slen);
2360 if (PL_op->op_private & OPpLOCALE) {
2363 *s = toLOWER_LC(*s);
2387 s = (U8*)SvPV(sv,len);
2389 SvUTF8_off(TARG); /* decontaminate */
2390 sv_setpvn(TARG, "", 0);
2394 (void)SvUPGRADE(TARG, SVt_PV);
2395 SvGROW(TARG, (len * 2) + 1);
2396 (void)SvPOK_only(TARG);
2397 d = (U8*)SvPVX(TARG);
2399 if (PL_op->op_private & OPpLOCALE) {
2403 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2409 d = uv_to_utf8(d, toUPPER_utf8( s ));
2415 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2420 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2422 SvUTF8_off(TARG); /* decontaminate */
2427 s = (U8*)SvPV_force(sv, len);
2429 register U8 *send = s + len;
2431 if (PL_op->op_private & OPpLOCALE) {
2434 for (; s < send; s++)
2435 *s = toUPPER_LC(*s);
2438 for (; s < send; s++)
2461 s = (U8*)SvPV(sv,len);
2463 SvUTF8_off(TARG); /* decontaminate */
2464 sv_setpvn(TARG, "", 0);
2468 (void)SvUPGRADE(TARG, SVt_PV);
2469 SvGROW(TARG, (len * 2) + 1);
2470 (void)SvPOK_only(TARG);
2471 d = (U8*)SvPVX(TARG);
2473 if (PL_op->op_private & OPpLOCALE) {
2477 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2483 d = uv_to_utf8(d, toLOWER_utf8(s));
2489 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2494 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2496 SvUTF8_off(TARG); /* decontaminate */
2502 s = (U8*)SvPV_force(sv, len);
2504 register U8 *send = s + len;
2506 if (PL_op->op_private & OPpLOCALE) {
2509 for (; s < send; s++)
2510 *s = toLOWER_LC(*s);
2513 for (; s < send; s++)
2528 register char *s = SvPV(sv,len);
2531 SvUTF8_off(TARG); /* decontaminate */
2533 (void)SvUPGRADE(TARG, SVt_PV);
2534 SvGROW(TARG, (len * 2) + 1);
2539 STRLEN ulen = UTF8SKIP(s);
2563 SvCUR_set(TARG, d - SvPVX(TARG));
2564 (void)SvPOK_only_UTF8(TARG);
2567 sv_setpvn(TARG, s, len);
2569 if (SvSMAGICAL(TARG))
2578 djSP; dMARK; dORIGMARK;
2580 register AV* av = (AV*)POPs;
2581 register I32 lval = PL_op->op_flags & OPf_MOD;
2582 I32 arybase = PL_curcop->cop_arybase;
2585 if (SvTYPE(av) == SVt_PVAV) {
2586 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2588 for (svp = MARK + 1; svp <= SP; svp++) {
2593 if (max > AvMAX(av))
2596 while (++MARK <= SP) {
2597 elem = SvIVx(*MARK);
2601 svp = av_fetch(av, elem, lval);
2603 if (!svp || *svp == &PL_sv_undef)
2604 DIE(aTHX_ PL_no_aelem, elem);
2605 if (PL_op->op_private & OPpLVAL_INTRO)
2606 save_aelem(av, elem, svp);
2608 *MARK = svp ? *svp : &PL_sv_undef;
2611 if (GIMME != G_ARRAY) {
2619 /* Associative arrays. */
2624 HV *hash = (HV*)POPs;
2626 I32 gimme = GIMME_V;
2627 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2630 /* might clobber stack_sp */
2631 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2636 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2637 if (gimme == G_ARRAY) {
2640 /* might clobber stack_sp */
2642 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2647 else if (gimme == G_SCALAR)
2666 I32 gimme = GIMME_V;
2667 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2671 if (PL_op->op_private & OPpSLICE) {
2675 hvtype = SvTYPE(hv);
2676 if (hvtype == SVt_PVHV) { /* hash element */
2677 while (++MARK <= SP) {
2678 sv = hv_delete_ent(hv, *MARK, discard, 0);
2679 *MARK = sv ? sv : &PL_sv_undef;
2682 else if (hvtype == SVt_PVAV) {
2683 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2684 while (++MARK <= SP) {
2685 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2686 *MARK = sv ? sv : &PL_sv_undef;
2689 else { /* pseudo-hash element */
2690 while (++MARK <= SP) {
2691 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2692 *MARK = sv ? sv : &PL_sv_undef;
2697 DIE(aTHX_ "Not a HASH reference");
2700 else if (gimme == G_SCALAR) {
2709 if (SvTYPE(hv) == SVt_PVHV)
2710 sv = hv_delete_ent(hv, keysv, discard, 0);
2711 else if (SvTYPE(hv) == SVt_PVAV) {
2712 if (PL_op->op_flags & OPf_SPECIAL)
2713 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2715 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2718 DIE(aTHX_ "Not a HASH reference");
2733 if (PL_op->op_private & OPpEXISTS_SUB) {
2737 cv = sv_2cv(sv, &hv, &gv, FALSE);
2740 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2746 if (SvTYPE(hv) == SVt_PVHV) {
2747 if (hv_exists_ent(hv, tmpsv, 0))
2750 else if (SvTYPE(hv) == SVt_PVAV) {
2751 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2752 if (av_exists((AV*)hv, SvIV(tmpsv)))
2755 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2759 DIE(aTHX_ "Not a HASH reference");
2766 djSP; dMARK; dORIGMARK;
2767 register HV *hv = (HV*)POPs;
2768 register I32 lval = PL_op->op_flags & OPf_MOD;
2769 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2771 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2772 DIE(aTHX_ "Can't localize pseudo-hash element");
2774 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2775 while (++MARK <= SP) {
2779 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2780 svp = he ? &HeVAL(he) : 0;
2783 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2786 if (!svp || *svp == &PL_sv_undef) {
2788 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2790 if (PL_op->op_private & OPpLVAL_INTRO)
2791 save_helem(hv, keysv, svp);
2793 *MARK = svp ? *svp : &PL_sv_undef;
2796 if (GIMME != G_ARRAY) {
2804 /* List operators. */
2809 if (GIMME != G_ARRAY) {
2811 *MARK = *SP; /* unwanted list, return last item */
2813 *MARK = &PL_sv_undef;
2822 SV **lastrelem = PL_stack_sp;
2823 SV **lastlelem = PL_stack_base + POPMARK;
2824 SV **firstlelem = PL_stack_base + POPMARK + 1;
2825 register SV **firstrelem = lastlelem + 1;
2826 I32 arybase = PL_curcop->cop_arybase;
2827 I32 lval = PL_op->op_flags & OPf_MOD;
2828 I32 is_something_there = lval;
2830 register I32 max = lastrelem - lastlelem;
2831 register SV **lelem;
2834 if (GIMME != G_ARRAY) {
2835 ix = SvIVx(*lastlelem);
2840 if (ix < 0 || ix >= max)
2841 *firstlelem = &PL_sv_undef;
2843 *firstlelem = firstrelem[ix];
2849 SP = firstlelem - 1;
2853 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2859 if (ix < 0 || ix >= max)
2860 *lelem = &PL_sv_undef;
2862 is_something_there = TRUE;
2863 if (!(*lelem = firstrelem[ix]))
2864 *lelem = &PL_sv_undef;
2867 if (is_something_there)
2870 SP = firstlelem - 1;
2876 djSP; dMARK; dORIGMARK;
2877 I32 items = SP - MARK;
2878 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2879 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2886 djSP; dMARK; dORIGMARK;
2887 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2891 SV *val = NEWSV(46, 0);
2893 sv_setsv(val, *++MARK);
2894 else if (ckWARN(WARN_MISC))
2895 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2896 (void)hv_store_ent(hv,key,val,0);
2905 djSP; dMARK; dORIGMARK;
2906 register AV *ary = (AV*)*++MARK;
2910 register I32 offset;
2911 register I32 length;
2918 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2919 *MARK-- = SvTIED_obj((SV*)ary, mg);
2923 call_method("SPLICE",GIMME_V);
2932 offset = i = SvIVx(*MARK);
2934 offset += AvFILLp(ary) + 1;
2936 offset -= PL_curcop->cop_arybase;
2938 DIE(aTHX_ PL_no_aelem, i);
2940 length = SvIVx(*MARK++);
2942 length += AvFILLp(ary) - offset + 1;
2948 length = AvMAX(ary) + 1; /* close enough to infinity */
2952 length = AvMAX(ary) + 1;
2954 if (offset > AvFILLp(ary) + 1)
2955 offset = AvFILLp(ary) + 1;
2956 after = AvFILLp(ary) + 1 - (offset + length);
2957 if (after < 0) { /* not that much array */
2958 length += after; /* offset+length now in array */
2964 /* At this point, MARK .. SP-1 is our new LIST */
2967 diff = newlen - length;
2968 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2971 if (diff < 0) { /* shrinking the area */
2973 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2974 Copy(MARK, tmparyval, newlen, SV*);
2977 MARK = ORIGMARK + 1;
2978 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2979 MEXTEND(MARK, length);
2980 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2982 EXTEND_MORTAL(length);
2983 for (i = length, dst = MARK; i; i--) {
2984 sv_2mortal(*dst); /* free them eventualy */
2991 *MARK = AvARRAY(ary)[offset+length-1];
2994 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2995 SvREFCNT_dec(*dst++); /* free them now */
2998 AvFILLp(ary) += diff;
3000 /* pull up or down? */
3002 if (offset < after) { /* easier to pull up */
3003 if (offset) { /* esp. if nothing to pull */
3004 src = &AvARRAY(ary)[offset-1];
3005 dst = src - diff; /* diff is negative */
3006 for (i = offset; i > 0; i--) /* can't trust Copy */
3010 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3014 if (after) { /* anything to pull down? */
3015 src = AvARRAY(ary) + offset + length;
3016 dst = src + diff; /* diff is negative */
3017 Move(src, dst, after, SV*);
3019 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3020 /* avoid later double free */
3024 dst[--i] = &PL_sv_undef;
3027 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3029 *dst = NEWSV(46, 0);
3030 sv_setsv(*dst++, *src++);
3032 Safefree(tmparyval);
3035 else { /* no, expanding (or same) */
3037 New(452, tmparyval, length, SV*); /* so remember deletion */
3038 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3041 if (diff > 0) { /* expanding */
3043 /* push up or down? */
3045 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3049 Move(src, dst, offset, SV*);
3051 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3053 AvFILLp(ary) += diff;
3056 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3057 av_extend(ary, AvFILLp(ary) + diff);
3058 AvFILLp(ary) += diff;
3061 dst = AvARRAY(ary) + AvFILLp(ary);
3063 for (i = after; i; i--) {
3070 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3071 *dst = NEWSV(46, 0);
3072 sv_setsv(*dst++, *src++);
3074 MARK = ORIGMARK + 1;
3075 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3077 Copy(tmparyval, MARK, length, SV*);
3079 EXTEND_MORTAL(length);
3080 for (i = length, dst = MARK; i; i--) {
3081 sv_2mortal(*dst); /* free them eventualy */
3085 Safefree(tmparyval);
3089 else if (length--) {
3090 *MARK = tmparyval[length];
3093 while (length-- > 0)
3094 SvREFCNT_dec(tmparyval[length]);
3096 Safefree(tmparyval);
3099 *MARK = &PL_sv_undef;
3107 djSP; dMARK; dORIGMARK; dTARGET;
3108 register AV *ary = (AV*)*++MARK;
3109 register SV *sv = &PL_sv_undef;
3112 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3113 *MARK-- = SvTIED_obj((SV*)ary, mg);
3117 call_method("PUSH",G_SCALAR|G_DISCARD);
3122 /* Why no pre-extend of ary here ? */
3123 for (++MARK; MARK <= SP; MARK++) {
3126 sv_setsv(sv, *MARK);
3131 PUSHi( AvFILL(ary) + 1 );
3139 SV *sv = av_pop(av);
3141 (void)sv_2mortal(sv);
3150 SV *sv = av_shift(av);
3155 (void)sv_2mortal(sv);
3162 djSP; dMARK; dORIGMARK; dTARGET;
3163 register AV *ary = (AV*)*++MARK;
3168 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3169 *MARK-- = SvTIED_obj((SV*)ary, mg);
3173 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3178 av_unshift(ary, SP - MARK);
3181 sv_setsv(sv, *++MARK);
3182 (void)av_store(ary, i++, sv);
3186 PUSHi( AvFILL(ary) + 1 );
3196 if (GIMME == G_ARRAY) {
3203 /* safe as long as stack cannot get extended in the above */
3208 register char *down;
3213 SvUTF8_off(TARG); /* decontaminate */
3215 do_join(TARG, &PL_sv_no, MARK, SP);
3217 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3218 up = SvPV_force(TARG, len);
3220 if (DO_UTF8(TARG)) { /* first reverse each character */
3221 U8* s = (U8*)SvPVX(TARG);
3222 U8* send = (U8*)(s + len);
3231 down = (char*)(s - 1);
3232 if (s > send || !((*down & 0xc0) == 0x80)) {
3233 if (ckWARN_d(WARN_UTF8))
3234 Perl_warner(aTHX_ WARN_UTF8,
3235 "Malformed UTF-8 character");
3247 down = SvPVX(TARG) + len - 1;
3253 (void)SvPOK_only_UTF8(TARG);
3262 S_mul128(pTHX_ SV *sv, U8 m)
3265 char *s = SvPV(sv, len);
3269 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3270 SV *tmpNew = newSVpvn("0000000000", 10);
3272 sv_catsv(tmpNew, sv);
3273 SvREFCNT_dec(sv); /* free old sv */
3278 while (!*t) /* trailing '\0'? */
3281 i = ((*t - '0') << 7) + m;
3282 *(t--) = '0' + (i % 10);
3288 /* Explosives and implosives. */
3290 #if 'I' == 73 && 'J' == 74
3291 /* On an ASCII/ISO kind of system */
3292 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3295 Some other sort of character set - use memchr() so we don't match
3298 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3305 I32 start_sp_offset = SP - PL_stack_base;
3306 I32 gimme = GIMME_V;
3310 register char *pat = SvPV(left, llen);
3311 register char *s = SvPV(right, rlen);
3312 char *strend = s + rlen;
3314 register char *patend = pat + llen;
3320 /* These must not be in registers: */
3337 register U32 culong;
3341 #ifdef PERL_NATINT_PACK
3342 int natint; /* native integer */
3343 int unatint; /* unsigned native integer */
3346 if (gimme != G_ARRAY) { /* arrange to do first one only */
3348 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3349 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3351 while (isDIGIT(*patend) || *patend == '*')
3357 while (pat < patend) {
3359 datumtype = *pat++ & 0xFF;
3360 #ifdef PERL_NATINT_PACK
3363 if (isSPACE(datumtype))
3365 if (datumtype == '#') {
3366 while (pat < patend && *pat != '\n')
3371 char *natstr = "sSiIlL";
3373 if (strchr(natstr, datumtype)) {
3374 #ifdef PERL_NATINT_PACK
3380 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3385 else if (*pat == '*') {
3386 len = strend - strbeg; /* long enough */
3390 else if (isDIGIT(*pat)) {
3392 while (isDIGIT(*pat)) {
3393 len = (len * 10) + (*pat++ - '0');
3395 DIE(aTHX_ "Repeat count in unpack overflows");
3399 len = (datumtype != '@');
3403 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3404 case ',': /* grandfather in commas but with a warning */
3405 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3406 Perl_warner(aTHX_ WARN_UNPACK,
3407 "Invalid type in unpack: '%c'", (int)datumtype);
3410 if (len == 1 && pat[-1] != '1')
3419 if (len > strend - strbeg)
3420 DIE(aTHX_ "@ outside of string");
3424 if (len > s - strbeg)
3425 DIE(aTHX_ "X outside of string");
3429 if (len > strend - s)
3430 DIE(aTHX_ "x outside of string");
3434 if (start_sp_offset >= SP - PL_stack_base)
3435 DIE(aTHX_ "/ must follow a numeric type");
3438 pat++; /* ignore '*' for compatibility with pack */
3440 DIE(aTHX_ "/ cannot take a count" );
3447 if (len > strend - s)
3450 goto uchar_checksum;
3451 sv = NEWSV(35, len);
3452 sv_setpvn(sv, s, len);
3454 if (datumtype == 'A' || datumtype == 'Z') {
3455 aptr = s; /* borrow register */
3456 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3461 else { /* 'A' strips both nulls and spaces */
3462 s = SvPVX(sv) + len - 1;
3463 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3467 SvCUR_set(sv, s - SvPVX(sv));
3468 s = aptr; /* unborrow register */
3470 XPUSHs(sv_2mortal(sv));
3474 if (star || len > (strend - s) * 8)
3475 len = (strend - s) * 8;
3478 Newz(601, PL_bitcount, 256, char);
3479 for (bits = 1; bits < 256; bits++) {
3480 if (bits & 1) PL_bitcount[bits]++;
3481 if (bits & 2) PL_bitcount[bits]++;
3482 if (bits & 4) PL_bitcount[bits]++;
3483 if (bits & 8) PL_bitcount[bits]++;
3484 if (bits & 16) PL_bitcount[bits]++;
3485 if (bits & 32) PL_bitcount[bits]++;
3486 if (bits & 64) PL_bitcount[bits]++;
3487 if (bits & 128) PL_bitcount[bits]++;
3491 culong += PL_bitcount[*(unsigned char*)s++];
3496 if (datumtype == 'b') {
3498 if (bits & 1) culong++;
3504 if (bits & 128) culong++;
3511 sv = NEWSV(35, len + 1);
3515 if (datumtype == 'b') {
3517 for (len = 0; len < aint; len++) {
3518 if (len & 7) /*SUPPRESS 595*/
3522 *str++ = '0' + (bits & 1);
3527 for (len = 0; len < aint; len++) {
3532 *str++ = '0' + ((bits & 128) != 0);
3536 XPUSHs(sv_2mortal(sv));
3540 if (star || len > (strend - s) * 2)
3541 len = (strend - s) * 2;
3542 sv = NEWSV(35, len + 1);
3546 if (datumtype == 'h') {
3548 for (len = 0; len < aint; len++) {
3553 *str++ = PL_hexdigit[bits & 15];
3558 for (len = 0; len < aint; len++) {
3563 *str++ = PL_hexdigit[(bits >> 4) & 15];
3567 XPUSHs(sv_2mortal(sv));
3570 if (len > strend - s)
3575 if (aint >= 128) /* fake up signed chars */
3585 if (aint >= 128) /* fake up signed chars */
3588 sv_setiv(sv, (IV)aint);
3589 PUSHs(sv_2mortal(sv));
3594 if (len > strend - s)
3609 sv_setiv(sv, (IV)auint);
3610 PUSHs(sv_2mortal(sv));
3615 if (len > strend - s)
3618 while (len-- > 0 && s < strend) {
3619 auint = utf8_to_uv((U8*)s, &along);
3622 cdouble += (NV)auint;
3630 while (len-- > 0 && s < strend) {
3631 auint = utf8_to_uv((U8*)s, &along);
3634 sv_setuv(sv, (UV)auint);
3635 PUSHs(sv_2mortal(sv));
3640 #if SHORTSIZE == SIZE16
3641 along = (strend - s) / SIZE16;
3643 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3648 #if SHORTSIZE != SIZE16
3652 COPYNN(s, &ashort, sizeof(short));
3663 #if SHORTSIZE > SIZE16
3675 #if SHORTSIZE != SIZE16
3679 COPYNN(s, &ashort, sizeof(short));
3682 sv_setiv(sv, (IV)ashort);
3683 PUSHs(sv_2mortal(sv));
3691 #if SHORTSIZE > SIZE16
3697 sv_setiv(sv, (IV)ashort);
3698 PUSHs(sv_2mortal(sv));
3706 #if SHORTSIZE == SIZE16
3707 along = (strend - s) / SIZE16;
3709 unatint = natint && datumtype == 'S';
3710 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3715 #if SHORTSIZE != SIZE16
3717 unsigned short aushort;
3719 COPYNN(s, &aushort, sizeof(unsigned short));
3720 s += sizeof(unsigned short);
3728 COPY16(s, &aushort);
3731 if (datumtype == 'n')
3732 aushort = PerlSock_ntohs(aushort);
3735 if (datumtype == 'v')
3736 aushort = vtohs(aushort);
3745 #if SHORTSIZE != SIZE16
3747 unsigned short aushort;
3749 COPYNN(s, &aushort, sizeof(unsigned short));
3750 s += sizeof(unsigned short);
3752 sv_setiv(sv, (UV)aushort);
3753 PUSHs(sv_2mortal(sv));
3760 COPY16(s, &aushort);
3764 if (datumtype == 'n')
3765 aushort = PerlSock_ntohs(aushort);
3768 if (datumtype == 'v')
3769 aushort = vtohs(aushort);
3771 sv_setiv(sv, (UV)aushort);
3772 PUSHs(sv_2mortal(sv));
3778 along = (strend - s) / sizeof(int);
3783 Copy(s, &aint, 1, int);
3786 cdouble += (NV)aint;
3795 Copy(s, &aint, 1, int);
3799 /* Without the dummy below unpack("i", pack("i",-1))
3800 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3801 * cc with optimization turned on.
3803 * The bug was detected in
3804 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3805 * with optimization (-O4) turned on.
3806 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3807 * does not have this problem even with -O4.
3809 * This bug was reported as DECC_BUGS 1431
3810 * and tracked internally as GEM_BUGS 7775.
3812 * The bug is fixed in
3813 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3814 * UNIX V4.0F support: DEC C V5.9-006 or later
3815 * UNIX V4.0E support: DEC C V5.8-011 or later
3818 * See also few lines later for the same bug.
3821 sv_setiv(sv, (IV)aint) :
3823 sv_setiv(sv, (IV)aint);
3824 PUSHs(sv_2mortal(sv));
3829 along = (strend - s) / sizeof(unsigned int);
3834 Copy(s, &auint, 1, unsigned int);
3835 s += sizeof(unsigned int);
3837 cdouble += (NV)auint;
3846 Copy(s, &auint, 1, unsigned int);
3847 s += sizeof(unsigned int);
3850 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3851 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3852 * See details few lines earlier. */
3854 sv_setuv(sv, (UV)auint) :
3856 sv_setuv(sv, (UV)auint);
3857 PUSHs(sv_2mortal(sv));
3862 #if LONGSIZE == SIZE32
3863 along = (strend - s) / SIZE32;
3865 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3870 #if LONGSIZE != SIZE32
3874 COPYNN(s, &along, sizeof(long));
3877 cdouble += (NV)along;
3887 #if LONGSIZE > SIZE32
3888 if (along > 2147483647)
3889 along -= 4294967296;
3893 cdouble += (NV)along;
3902 #if LONGSIZE != SIZE32
3906 COPYNN(s, &along, sizeof(long));
3909 sv_setiv(sv, (IV)along);
3910 PUSHs(sv_2mortal(sv));
3918 #if LONGSIZE > SIZE32
3919 if (along > 2147483647)
3920 along -= 4294967296;
3924 sv_setiv(sv, (IV)along);
3925 PUSHs(sv_2mortal(sv));
3933 #if LONGSIZE == SIZE32
3934 along = (strend - s) / SIZE32;
3936 unatint = natint && datumtype == 'L';
3937 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3942 #if LONGSIZE != SIZE32
3944 unsigned long aulong;
3946 COPYNN(s, &aulong, sizeof(unsigned long));
3947 s += sizeof(unsigned long);
3949 cdouble += (NV)aulong;
3961 if (datumtype == 'N')
3962 aulong = PerlSock_ntohl(aulong);
3965 if (datumtype == 'V')
3966 aulong = vtohl(aulong);
3969 cdouble += (NV)aulong;
3978 #if LONGSIZE != SIZE32
3980 unsigned long aulong;
3982 COPYNN(s, &aulong, sizeof(unsigned long));
3983 s += sizeof(unsigned long);
3985 sv_setuv(sv, (UV)aulong);
3986 PUSHs(sv_2mortal(sv));
3996 if (datumtype == 'N')
3997 aulong = PerlSock_ntohl(aulong);
4000 if (datumtype == 'V')
4001 aulong = vtohl(aulong);
4004 sv_setuv(sv, (UV)aulong);
4005 PUSHs(sv_2mortal(sv));
4011 along = (strend - s) / sizeof(char*);
4017 if (sizeof(char*) > strend - s)
4020 Copy(s, &aptr, 1, char*);
4026 PUSHs(sv_2mortal(sv));
4036 while ((len > 0) && (s < strend)) {
4037 auv = (auv << 7) | (*s & 0x7f);
4038 if (!(*s++ & 0x80)) {
4042 PUSHs(sv_2mortal(sv));
4046 else if (++bytes >= sizeof(UV)) { /* promote to string */
4050 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4051 while (s < strend) {
4052 sv = mul128(sv, *s & 0x7f);
4053 if (!(*s++ & 0x80)) {
4062 PUSHs(sv_2mortal(sv));
4067 if ((s >= strend) && bytes)
4068 DIE(aTHX_ "Unterminated compressed integer");
4073 if (sizeof(char*) > strend - s)
4076 Copy(s, &aptr, 1, char*);
4081 sv_setpvn(sv, aptr, len);
4082 PUSHs(sv_2mortal(sv));
4086 along = (strend - s) / sizeof(Quad_t);
4092 if (s + sizeof(Quad_t) > strend)
4095 Copy(s, &aquad, 1, Quad_t);
4096 s += sizeof(Quad_t);
4099 if (aquad >= IV_MIN && aquad <= IV_MAX)
4100 sv_setiv(sv, (IV)aquad);
4102 sv_setnv(sv, (NV)aquad);
4103 PUSHs(sv_2mortal(sv));
4107 along = (strend - s) / sizeof(Quad_t);
4113 if (s + sizeof(Uquad_t) > strend)
4116 Copy(s, &auquad, 1, Uquad_t);
4117 s += sizeof(Uquad_t);
4120 if (auquad <= UV_MAX)
4121 sv_setuv(sv, (UV)auquad);
4123 sv_setnv(sv, (NV)auquad);
4124 PUSHs(sv_2mortal(sv));
4128 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4131 along = (strend - s) / sizeof(float);
4136 Copy(s, &afloat, 1, float);
4145 Copy(s, &afloat, 1, float);
4148 sv_setnv(sv, (NV)afloat);
4149 PUSHs(sv_2mortal(sv));
4155 along = (strend - s) / sizeof(double);
4160 Copy(s, &adouble, 1, double);
4161 s += sizeof(double);
4169 Copy(s, &adouble, 1, double);
4170 s += sizeof(double);
4172 sv_setnv(sv, (NV)adouble);
4173 PUSHs(sv_2mortal(sv));
4179 * Initialise the decode mapping. By using a table driven
4180 * algorithm, the code will be character-set independent
4181 * (and just as fast as doing character arithmetic)
4183 if (PL_uudmap['M'] == 0) {
4186 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4187 PL_uudmap[(U8)PL_uuemap[i]] = i;
4189 * Because ' ' and '`' map to the same value,
4190 * we need to decode them both the same.
4195 along = (strend - s) * 3 / 4;
4196 sv = NEWSV(42, along);
4199 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4204 len = PL_uudmap[*(U8*)s++] & 077;
4206 if (s < strend && ISUUCHAR(*s))
4207 a = PL_uudmap[*(U8*)s++] & 077;
4210 if (s < strend && ISUUCHAR(*s))
4211 b = PL_uudmap[*(U8*)s++] & 077;
4214 if (s < strend && ISUUCHAR(*s))
4215 c = PL_uudmap[*(U8*)s++] & 077;
4218 if (s < strend && ISUUCHAR(*s))
4219 d = PL_uudmap[*(U8*)s++] & 077;
4222 hunk[0] = (a << 2) | (b >> 4);
4223 hunk[1] = (b << 4) | (c >> 2);
4224 hunk[2] = (c << 6) | d;
4225 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4230 else if (s[1] == '\n') /* possible checksum byte */
4233 XPUSHs(sv_2mortal(sv));
4238 if (strchr("fFdD", datumtype) ||
4239 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4243 while (checksum >= 16) {
4247 while (checksum >= 4) {
4253 along = (1 << checksum) - 1;
4254 while (cdouble < 0.0)
4256 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4257 sv_setnv(sv, cdouble);
4260 if (checksum < 32) {
4261 aulong = (1 << checksum) - 1;
4264 sv_setuv(sv, (UV)culong);
4266 XPUSHs(sv_2mortal(sv));
4270 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4271 PUSHs(&PL_sv_undef);
4276 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4280 *hunk = PL_uuemap[len];
4281 sv_catpvn(sv, hunk, 1);
4284 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4285 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4286 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4287 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4288 sv_catpvn(sv, hunk, 4);
4293 char r = (len > 1 ? s[1] : '\0');
4294 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4295 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4296 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4297 hunk[3] = PL_uuemap[0];
4298 sv_catpvn(sv, hunk, 4);
4300 sv_catpvn(sv, "\n", 1);
4304 S_is_an_int(pTHX_ char *s, STRLEN l)
4307 SV *result = newSVpvn(s, l);
4308 char *result_c = SvPV(result, n_a); /* convenience */
4309 char *out = result_c;
4319 SvREFCNT_dec(result);
4342 SvREFCNT_dec(result);
4348 SvCUR_set(result, out - result_c);
4352 /* pnum must be '\0' terminated */
4354 S_div128(pTHX_ SV *pnum, bool *done)
4357 char *s = SvPV(pnum, len);
4366 i = m * 10 + (*t - '0');
4368 r = (i >> 7); /* r < 10 */
4375 SvCUR_set(pnum, (STRLEN) (t - s));
4382 djSP; dMARK; dORIGMARK; dTARGET;
4383 register SV *cat = TARG;
4386 register char *pat = SvPVx(*++MARK, fromlen);
4388 register char *patend = pat + fromlen;
4393 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4394 static char *space10 = " ";
4396 /* These must not be in registers: */
4411 #ifdef PERL_NATINT_PACK
4412 int natint; /* native integer */
4417 sv_setpvn(cat, "", 0);
4419 while (pat < patend) {
4420 SV *lengthcode = Nullsv;
4421 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4422 datumtype = *pat++ & 0xFF;
4423 #ifdef PERL_NATINT_PACK
4426 if (isSPACE(datumtype)) {
4430 if (datumtype == 'U' && pat == patcopy+1)
4432 if (datumtype == '#') {
4433 while (pat < patend && *pat != '\n')
4438 char *natstr = "sSiIlL";
4440 if (strchr(natstr, datumtype)) {
4441 #ifdef PERL_NATINT_PACK
4447 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4450 len = strchr("@Xxu", datumtype) ? 0 : items;
4453 else if (isDIGIT(*pat)) {
4455 while (isDIGIT(*pat)) {
4456 len = (len * 10) + (*pat++ - '0');
4458 DIE(aTHX_ "Repeat count in pack overflows");
4465 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4466 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4467 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4468 ? *MARK : &PL_sv_no)
4469 + (*pat == 'Z' ? 1 : 0)));
4473 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4474 case ',': /* grandfather in commas but with a warning */
4475 if (commas++ == 0 && ckWARN(WARN_PACK))
4476 Perl_warner(aTHX_ WARN_PACK,
4477 "Invalid type in pack: '%c'", (int)datumtype);
4480 DIE(aTHX_ "%% may only be used in unpack");
4491 if (SvCUR(cat) < len)
4492 DIE(aTHX_ "X outside of string");
4499 sv_catpvn(cat, null10, 10);
4502 sv_catpvn(cat, null10, len);
4508 aptr = SvPV(fromstr, fromlen);
4509 if (pat[-1] == '*') {
4511 if (datumtype == 'Z')
4514 if (fromlen >= len) {
4515 sv_catpvn(cat, aptr, len);
4516 if (datumtype == 'Z')
4517 *(SvEND(cat)-1) = '\0';
4520 sv_catpvn(cat, aptr, fromlen);
4522 if (datumtype == 'A') {
4524 sv_catpvn(cat, space10, 10);
4527 sv_catpvn(cat, space10, len);
4531 sv_catpvn(cat, null10, 10);
4534 sv_catpvn(cat, null10, len);
4546 str = SvPV(fromstr, fromlen);
4550 SvCUR(cat) += (len+7)/8;
4551 SvGROW(cat, SvCUR(cat) + 1);
4552 aptr = SvPVX(cat) + aint;
4557 if (datumtype == 'B') {
4558 for (len = 0; len++ < aint;) {
4559 items |= *str++ & 1;
4563 *aptr++ = items & 0xff;
4569 for (len = 0; len++ < aint;) {
4575 *aptr++ = items & 0xff;
4581 if (datumtype == 'B')
4582 items <<= 7 - (aint & 7);
4584 items >>= 7 - (aint & 7);
4585 *aptr++ = items & 0xff;
4587 str = SvPVX(cat) + SvCUR(cat);
4602 str = SvPV(fromstr, fromlen);
4606 SvCUR(cat) += (len+1)/2;
4607 SvGROW(cat, SvCUR(cat) + 1);
4608 aptr = SvPVX(cat) + aint;
4613 if (datumtype == 'H') {
4614 for (len = 0; len++ < aint;) {
4616 items |= ((*str++ & 15) + 9) & 15;
4618 items |= *str++ & 15;
4622 *aptr++ = items & 0xff;
4628 for (len = 0; len++ < aint;) {
4630 items |= (((*str++ & 15) + 9) & 15) << 4;
4632 items |= (*str++ & 15) << 4;
4636 *aptr++ = items & 0xff;
4642 *aptr++ = items & 0xff;
4643 str = SvPVX(cat) + SvCUR(cat);
4654 aint = SvIV(fromstr);
4656 sv_catpvn(cat, &achar, sizeof(char));
4662 auint = SvUV(fromstr);
4663 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4664 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4669 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4674 afloat = (float)SvNV(fromstr);
4675 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4682 adouble = (double)SvNV(fromstr);
4683 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4689 ashort = (I16)SvIV(fromstr);
4691 ashort = PerlSock_htons(ashort);
4693 CAT16(cat, &ashort);
4699 ashort = (I16)SvIV(fromstr);
4701 ashort = htovs(ashort);
4703 CAT16(cat, &ashort);
4707 #if SHORTSIZE != SIZE16
4709 unsigned short aushort;
4713 aushort = SvUV(fromstr);
4714 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4724 aushort = (U16)SvUV(fromstr);
4725 CAT16(cat, &aushort);
4731 #if SHORTSIZE != SIZE16
4737 ashort = SvIV(fromstr);
4738 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4746 ashort = (I16)SvIV(fromstr);
4747 CAT16(cat, &ashort);
4754 auint = SvUV(fromstr);
4755 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4761 adouble = Perl_floor(SvNV(fromstr));
4764 DIE(aTHX_ "Cannot compress negative numbers");
4767 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4768 adouble <= 0xffffffff
4770 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4771 adouble <= UV_MAX_cxux
4778 char buf[1 + sizeof(UV)];
4779 char *in = buf + sizeof(buf);
4780 UV auv = U_V(adouble);
4783 *--in = (auv & 0x7f) | 0x80;
4786 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4787 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4789 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4790 char *from, *result, *in;
4795 /* Copy string and check for compliance */
4796 from = SvPV(fromstr, len);
4797 if ((norm = is_an_int(from, len)) == NULL)
4798 DIE(aTHX_ "can compress only unsigned integer");
4800 New('w', result, len, char);
4804 *--in = div128(norm, &done) | 0x80;
4805 result[len - 1] &= 0x7F; /* clear continue bit */
4806 sv_catpvn(cat, in, (result + len) - in);
4808 SvREFCNT_dec(norm); /* free norm */
4810 else if (SvNOKp(fromstr)) {
4811 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4812 char *in = buf + sizeof(buf);
4815 double next = floor(adouble / 128);
4816 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4817 if (--in < buf) /* this cannot happen ;-) */
4818 DIE(aTHX_ "Cannot compress integer");
4820 } while (adouble > 0);
4821 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4822 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4825 DIE(aTHX_ "Cannot compress non integer");
4831 aint = SvIV(fromstr);
4832 sv_catpvn(cat, (char*)&aint, sizeof(int));
4838 aulong = SvUV(fromstr);
4840 aulong = PerlSock_htonl(aulong);
4842 CAT32(cat, &aulong);
4848 aulong = SvUV(fromstr);
4850 aulong = htovl(aulong);
4852 CAT32(cat, &aulong);
4856 #if LONGSIZE != SIZE32
4858 unsigned long aulong;
4862 aulong = SvUV(fromstr);
4863 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4871 aulong = SvUV(fromstr);
4872 CAT32(cat, &aulong);
4877 #if LONGSIZE != SIZE32
4883 along = SvIV(fromstr);
4884 sv_catpvn(cat, (char *)&along, sizeof(long));
4892 along = SvIV(fromstr);
4901 auquad = (Uquad_t)SvUV(fromstr);
4902 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4908 aquad = (Quad_t)SvIV(fromstr);
4909 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4914 len = 1; /* assume SV is correct length */
4919 if (fromstr == &PL_sv_undef)
4923 /* XXX better yet, could spirit away the string to
4924 * a safe spot and hang on to it until the result
4925 * of pack() (and all copies of the result) are
4928 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4929 || (SvPADTMP(fromstr)
4930 && !SvREADONLY(fromstr))))
4932 Perl_warner(aTHX_ WARN_PACK,
4933 "Attempt to pack pointer to temporary value");
4935 if (SvPOK(fromstr) || SvNIOK(fromstr))
4936 aptr = SvPV(fromstr,n_a);
4938 aptr = SvPV_force(fromstr,n_a);
4940 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4945 aptr = SvPV(fromstr, fromlen);
4946 SvGROW(cat, fromlen * 4 / 3);
4951 while (fromlen > 0) {
4958 doencodes(cat, aptr, todo);
4977 register I32 limit = POPi; /* note, negative is forever */
4980 register char *s = SvPV(sv, len);
4981 char *strend = s + len;
4983 register REGEXP *rx;
4987 I32 maxiters = (strend - s) + 10;
4990 I32 origlimit = limit;
4993 AV *oldstack = PL_curstack;
4994 I32 gimme = GIMME_V;
4995 I32 oldsave = PL_savestack_ix;
4996 I32 make_mortal = 1;
4997 MAGIC *mg = (MAGIC *) NULL;
5000 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5005 DIE(aTHX_ "panic: do_split");
5006 rx = pm->op_pmregexp;
5008 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5009 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5011 if (pm->op_pmreplroot) {
5013 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5015 ary = GvAVn((GV*)pm->op_pmreplroot);
5018 else if (gimme != G_ARRAY)
5020 ary = (AV*)PL_curpad[0];
5022 ary = GvAVn(PL_defgv);
5023 #endif /* USE_THREADS */
5026 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5032 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5034 XPUSHs(SvTIED_obj((SV*)ary, mg));
5040 for (i = AvFILLp(ary); i >= 0; i--)
5041 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5043 /* temporarily switch stacks */
5044 SWITCHSTACK(PL_curstack, ary);
5048 base = SP - PL_stack_base;
5050 if (pm->op_pmflags & PMf_SKIPWHITE) {
5051 if (pm->op_pmflags & PMf_LOCALE) {
5052 while (isSPACE_LC(*s))
5060 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5061 SAVEINT(PL_multiline);
5062 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5066 limit = maxiters + 2;
5067 if (pm->op_pmflags & PMf_WHITE) {
5070 while (m < strend &&
5071 !((pm->op_pmflags & PMf_LOCALE)
5072 ? isSPACE_LC(*m) : isSPACE(*m)))
5077 dstr = NEWSV(30, m-s);
5078 sv_setpvn(dstr, s, m-s);
5084 while (s < strend &&
5085 ((pm->op_pmflags & PMf_LOCALE)
5086 ? isSPACE_LC(*s) : isSPACE(*s)))
5090 else if (strEQ("^", rx->precomp)) {
5093 for (m = s; m < strend && *m != '\n'; m++) ;
5097 dstr = NEWSV(30, m-s);
5098 sv_setpvn(dstr, s, m-s);
5105 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5106 && (rx->reganch & ROPT_CHECK_ALL)
5107 && !(rx->reganch & ROPT_ANCH)) {
5108 int tail = (rx->reganch & RE_INTUIT_TAIL);
5109 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5113 if (len == 1 && !tail) {
5117 for (m = s; m < strend && *m != c; m++) ;
5120 dstr = NEWSV(30, m-s);
5121 sv_setpvn(dstr, s, m-s);
5130 while (s < strend && --limit &&
5131 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5132 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5135 dstr = NEWSV(31, m-s);
5136 sv_setpvn(dstr, s, m-s);
5140 s = m + len; /* Fake \n at the end */
5145 maxiters += (strend - s) * rx->nparens;
5146 while (s < strend && --limit
5147 /* && (!rx->check_substr
5148 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5150 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5151 1 /* minend */, sv, NULL, 0))
5153 TAINT_IF(RX_MATCH_TAINTED(rx));
5154 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5159 strend = s + (strend - m);
5161 m = rx->startp[0] + orig;
5162 dstr = NEWSV(32, m-s);
5163 sv_setpvn(dstr, s, m-s);
5168 for (i = 1; i <= rx->nparens; i++) {
5169 s = rx->startp[i] + orig;
5170 m = rx->endp[i] + orig;
5172 dstr = NEWSV(33, m-s);
5173 sv_setpvn(dstr, s, m-s);
5176 dstr = NEWSV(33, 0);
5182 s = rx->endp[0] + orig;
5186 LEAVE_SCOPE(oldsave);
5187 iters = (SP - PL_stack_base) - base;
5188 if (iters > maxiters)
5189 DIE(aTHX_ "Split loop");
5191 /* keep field after final delim? */
5192 if (s < strend || (iters && origlimit)) {
5193 dstr = NEWSV(34, strend-s);
5194 sv_setpvn(dstr, s, strend-s);
5200 else if (!origlimit) {
5201 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5207 SWITCHSTACK(ary, oldstack);
5208 if (SvSMAGICAL(ary)) {
5213 if (gimme == G_ARRAY) {
5215 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5223 call_method("PUSH",G_SCALAR|G_DISCARD);
5226 if (gimme == G_ARRAY) {
5227 /* EXTEND should not be needed - we just popped them */
5229 for (i=0; i < iters; i++) {
5230 SV **svp = av_fetch(ary, i, FALSE);
5231 PUSHs((svp) ? *svp : &PL_sv_undef);
5238 if (gimme == G_ARRAY)
5241 if (iters || !pm->op_pmreplroot) {
5251 Perl_unlock_condpair(pTHX_ void *svv)
5254 MAGIC *mg = mg_find((SV*)svv, 'm');
5257 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5258 MUTEX_LOCK(MgMUTEXP(mg));
5259 if (MgOWNER(mg) != thr)
5260 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5262 COND_SIGNAL(MgOWNERCONDP(mg));
5263 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5264 PTR2UV(thr), PTR2UV(svv));)
5265 MUTEX_UNLOCK(MgMUTEXP(mg));
5267 #endif /* USE_THREADS */
5276 #endif /* USE_THREADS */
5277 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5278 || SvTYPE(retsv) == SVt_PVCV) {
5279 retsv = refto(retsv);
5290 if (PL_op->op_private & OPpLVAL_INTRO)
5291 PUSHs(*save_threadsv(PL_op->op_targ));
5293 PUSHs(THREADSV(PL_op->op_targ));
5296 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5297 #endif /* USE_THREADS */