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);
248 if (PL_op->op_private & HINT_STRICT_REFS)
249 DIE(aTHX_ PL_no_symref, sym, "a symbol");
250 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
254 if (PL_op->op_private & OPpLVAL_INTRO)
255 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
266 tryAMAGICunDEREF(to_sv);
269 switch (SvTYPE(sv)) {
273 DIE(aTHX_ "Not a SCALAR reference");
281 if (SvTYPE(gv) != SVt_PVGV) {
282 if (SvGMAGICAL(sv)) {
288 if (PL_op->op_flags & OPf_REF ||
289 PL_op->op_private & HINT_STRICT_REFS)
290 DIE(aTHX_ PL_no_usym, "a SCALAR");
291 if (ckWARN(WARN_UNINITIALIZED))
296 if ((PL_op->op_flags & OPf_SPECIAL) &&
297 !(PL_op->op_flags & OPf_MOD))
299 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
304 if (PL_op->op_private & HINT_STRICT_REFS)
305 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
306 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
311 if (PL_op->op_flags & OPf_MOD) {
312 if (PL_op->op_private & OPpLVAL_INTRO)
313 sv = save_scalar((GV*)TOPs);
314 else if (PL_op->op_private & OPpDEREF)
315 vivify_ref(sv, PL_op->op_private & OPpDEREF);
325 SV *sv = AvARYLEN(av);
327 AvARYLEN(av) = sv = NEWSV(0,0);
328 sv_upgrade(sv, SVt_IV);
329 sv_magic(sv, (SV*)av, '#', Nullch, 0);
337 djSP; dTARGET; dPOPss;
339 if (PL_op->op_flags & OPf_MOD) {
340 if (SvTYPE(TARG) < SVt_PVLV) {
341 sv_upgrade(TARG, SVt_PVLV);
342 sv_magic(TARG, Nullsv, '.', Nullch, 0);
346 if (LvTARG(TARG) != sv) {
348 SvREFCNT_dec(LvTARG(TARG));
349 LvTARG(TARG) = SvREFCNT_inc(sv);
351 PUSHs(TARG); /* no SvSETMAGIC */
357 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
358 mg = mg_find(sv, 'g');
359 if (mg && mg->mg_len >= 0) {
363 PUSHi(i + PL_curcop->cop_arybase);
377 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
378 /* (But not in defined().) */
379 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
382 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
383 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
384 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
387 cv = (CV*)&PL_sv_undef;
401 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
402 char *s = SvPVX(TOPs);
403 if (strnEQ(s, "CORE::", 6)) {
406 code = keyword(s + 6, SvCUR(TOPs) - 6);
407 if (code < 0) { /* Overridable. */
408 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
409 int i = 0, n = 0, seen_question = 0;
411 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
413 while (i < MAXO) { /* The slow way. */
414 if (strEQ(s + 6, PL_op_name[i])
415 || strEQ(s + 6, PL_op_desc[i]))
421 goto nonesuch; /* Should not happen... */
423 oa = PL_opargs[i] >> OASHIFT;
425 if (oa & OA_OPTIONAL) {
429 else if (n && str[0] == ';' && seen_question)
430 goto set; /* XXXX system, exec */
431 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
432 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
435 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
436 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
440 ret = sv_2mortal(newSVpvn(str, n - 1));
442 else if (code) /* Non-Overridable */
444 else { /* None such */
446 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
450 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
452 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
461 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
463 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
479 if (GIMME != G_ARRAY) {
483 *MARK = &PL_sv_undef;
484 *MARK = refto(*MARK);
488 EXTEND_MORTAL(SP - MARK);
490 *MARK = refto(*MARK);
495 S_refto(pTHX_ SV *sv)
499 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
502 if (!(sv = LvTARG(sv)))
505 (void)SvREFCNT_inc(sv);
507 else if (SvTYPE(sv) == SVt_PVAV) {
508 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
511 (void)SvREFCNT_inc(sv);
513 else if (SvPADTMP(sv))
517 (void)SvREFCNT_inc(sv);
520 sv_upgrade(rv, SVt_RV);
534 if (sv && SvGMAGICAL(sv))
537 if (!sv || !SvROK(sv))
541 pv = sv_reftype(sv,TRUE);
542 PUSHp(pv, strlen(pv));
552 stash = CopSTASH(PL_curcop);
556 char *ptr = SvPV(ssv,len);
557 if (ckWARN(WARN_MISC) && len == 0)
558 Perl_warner(aTHX_ WARN_MISC,
559 "Explicit blessing to '' (assuming package main)");
560 stash = gv_stashpvn(ptr, len, TRUE);
563 (void)sv_bless(TOPs, stash);
577 elem = SvPV(sv, n_a);
581 switch (elem ? *elem : '\0')
584 if (strEQ(elem, "ARRAY"))
585 tmpRef = (SV*)GvAV(gv);
588 if (strEQ(elem, "CODE"))
589 tmpRef = (SV*)GvCVu(gv);
592 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
593 tmpRef = (SV*)GvIOp(gv);
596 if (strEQ(elem, "GLOB"))
600 if (strEQ(elem, "HASH"))
601 tmpRef = (SV*)GvHV(gv);
604 if (strEQ(elem, "IO"))
605 tmpRef = (SV*)GvIOp(gv);
608 if (strEQ(elem, "NAME"))
609 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
612 if (strEQ(elem, "PACKAGE"))
613 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
616 if (strEQ(elem, "SCALAR"))
630 /* Pattern matching */
635 register unsigned char *s;
638 register I32 *sfirst;
642 if (sv == PL_lastscream) {
648 SvSCREAM_off(PL_lastscream);
649 SvREFCNT_dec(PL_lastscream);
651 PL_lastscream = SvREFCNT_inc(sv);
654 s = (unsigned char*)(SvPV(sv, len));
658 if (pos > PL_maxscream) {
659 if (PL_maxscream < 0) {
660 PL_maxscream = pos + 80;
661 New(301, PL_screamfirst, 256, I32);
662 New(302, PL_screamnext, PL_maxscream, I32);
665 PL_maxscream = pos + pos / 4;
666 Renew(PL_screamnext, PL_maxscream, I32);
670 sfirst = PL_screamfirst;
671 snext = PL_screamnext;
673 if (!sfirst || !snext)
674 DIE(aTHX_ "do_study: out of memory");
676 for (ch = 256; ch; --ch)
683 snext[pos] = sfirst[ch] - pos;
690 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
699 if (PL_op->op_flags & OPf_STACKED)
705 TARG = sv_newmortal();
710 /* Lvalue operators. */
722 djSP; dMARK; dTARGET;
732 SETi(do_chomp(TOPs));
738 djSP; dMARK; dTARGET;
739 register I32 count = 0;
742 count += do_chomp(POPs);
753 if (!sv || !SvANY(sv))
755 switch (SvTYPE(sv)) {
757 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
761 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
765 if (CvROOT(sv) || CvXSUB(sv))
782 if (!PL_op->op_private) {
791 if (SvTHINKFIRST(sv))
794 switch (SvTYPE(sv)) {
804 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
805 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
806 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
810 /* let user-undef'd sub keep its identity */
811 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
818 SvSetMagicSV(sv, &PL_sv_undef);
822 Newz(602, gp, 1, GP);
823 GvGP(sv) = gp_ref(gp);
824 GvSV(sv) = NEWSV(72,0);
825 GvLINE(sv) = CopLINE(PL_curcop);
831 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
834 SvPV_set(sv, Nullch);
847 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
848 DIE(aTHX_ PL_no_modify);
849 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
850 SvIVX(TOPs) != IV_MIN)
853 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
864 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
865 DIE(aTHX_ PL_no_modify);
866 sv_setsv(TARG, TOPs);
867 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
868 SvIVX(TOPs) != IV_MAX)
871 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
885 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
886 DIE(aTHX_ PL_no_modify);
887 sv_setsv(TARG, TOPs);
888 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
889 SvIVX(TOPs) != IV_MIN)
892 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
901 /* Ordinary operators. */
905 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
908 SETn( Perl_pow( left, right) );
915 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
918 SETn( left * right );
925 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
930 DIE(aTHX_ "Illegal division by zero");
932 /* insure that 20./5. == 4. */
935 if ((NV)I_V(left) == left &&
936 (NV)I_V(right) == right &&
937 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
941 value = left / right;
945 value = left / right;
954 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
964 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
966 right = (right_neg = (i < 0)) ? -i : i;
971 right_neg = dright < 0;
976 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
978 left = (left_neg = (i < 0)) ? -i : i;
986 left_neg = dleft < 0;
995 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
997 # define CAST_D2UV(d) U_V(d)
999 # define CAST_D2UV(d) ((UV)(d))
1001 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1002 * or, in other words, precision of UV more than of NV.
1003 * But in fact the approach below turned out to be an
1004 * optimization - floor() may be slow */
1005 if (dright <= UV_MAX && dleft <= UV_MAX) {
1006 right = CAST_D2UV(dright);
1007 left = CAST_D2UV(dleft);
1012 /* Backward-compatibility clause: */
1013 dright = Perl_floor(dright + 0.5);
1014 dleft = Perl_floor(dleft + 0.5);
1017 DIE(aTHX_ "Illegal modulus zero");
1019 dans = Perl_fmod(dleft, dright);
1020 if ((left_neg != right_neg) && dans)
1021 dans = dright - dans;
1024 sv_setnv(TARG, dans);
1031 DIE(aTHX_ "Illegal modulus zero");
1034 if ((left_neg != right_neg) && ans)
1037 /* XXX may warn: unary minus operator applied to unsigned type */
1038 /* could change -foo to be (~foo)+1 instead */
1039 if (ans <= ~((UV)IV_MAX)+1)
1040 sv_setiv(TARG, ~ans+1);
1042 sv_setnv(TARG, -(NV)ans);
1045 sv_setuv(TARG, ans);
1054 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1056 register I32 count = POPi;
1057 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1059 I32 items = SP - MARK;
1062 max = items * count;
1071 repeatcpy((char*)(MARK + items), (char*)MARK,
1072 items * sizeof(SV*), count - 1);
1075 else if (count <= 0)
1078 else { /* Note: mark already snarfed by pp_list */
1083 SvSetSV(TARG, tmpstr);
1084 SvPV_force(TARG, len);
1089 SvGROW(TARG, (count * len) + 1);
1090 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1091 SvCUR(TARG) *= count;
1093 *SvEND(TARG) = '\0';
1095 (void)SvPOK_only(TARG);
1104 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1107 SETn( left - right );
1114 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1117 if (PL_op->op_private & HINT_INTEGER) {
1131 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1134 if (PL_op->op_private & HINT_INTEGER) {
1148 djSP; tryAMAGICbinSET(lt,0);
1151 SETs(boolSV(TOPn < value));
1158 djSP; tryAMAGICbinSET(gt,0);
1161 SETs(boolSV(TOPn > value));
1168 djSP; tryAMAGICbinSET(le,0);
1171 SETs(boolSV(TOPn <= value));
1178 djSP; tryAMAGICbinSET(ge,0);
1181 SETs(boolSV(TOPn >= value));
1188 djSP; tryAMAGICbinSET(ne,0);
1191 SETs(boolSV(TOPn != value));
1198 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1204 if (Perl_isnan(left) || Perl_isnan(right)) {
1208 value = (left > right) - (left < right);
1212 else if (left < right)
1214 else if (left > right)
1228 djSP; tryAMAGICbinSET(slt,0);
1231 int cmp = ((PL_op->op_private & OPpLOCALE)
1232 ? sv_cmp_locale(left, right)
1233 : sv_cmp(left, right));
1234 SETs(boolSV(cmp < 0));
1241 djSP; tryAMAGICbinSET(sgt,0);
1244 int cmp = ((PL_op->op_private & OPpLOCALE)
1245 ? sv_cmp_locale(left, right)
1246 : sv_cmp(left, right));
1247 SETs(boolSV(cmp > 0));
1254 djSP; tryAMAGICbinSET(sle,0);
1257 int cmp = ((PL_op->op_private & OPpLOCALE)
1258 ? sv_cmp_locale(left, right)
1259 : sv_cmp(left, right));
1260 SETs(boolSV(cmp <= 0));
1267 djSP; tryAMAGICbinSET(sge,0);
1270 int cmp = ((PL_op->op_private & OPpLOCALE)
1271 ? sv_cmp_locale(left, right)
1272 : sv_cmp(left, right));
1273 SETs(boolSV(cmp >= 0));
1280 djSP; tryAMAGICbinSET(seq,0);
1283 SETs(boolSV(sv_eq(left, right)));
1290 djSP; tryAMAGICbinSET(sne,0);
1293 SETs(boolSV(!sv_eq(left, right)));
1300 djSP; dTARGET; tryAMAGICbin(scmp,0);
1303 int cmp = ((PL_op->op_private & OPpLOCALE)
1304 ? sv_cmp_locale(left, right)
1305 : sv_cmp(left, right));
1313 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1316 if (SvNIOKp(left) || SvNIOKp(right)) {
1317 if (PL_op->op_private & HINT_INTEGER) {
1318 IV i = SvIV(left) & SvIV(right);
1322 UV u = SvUV(left) & SvUV(right);
1327 do_vop(PL_op->op_type, TARG, left, right);
1336 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1339 if (SvNIOKp(left) || SvNIOKp(right)) {
1340 if (PL_op->op_private & HINT_INTEGER) {
1341 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1345 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1350 do_vop(PL_op->op_type, TARG, left, right);
1359 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1362 if (SvNIOKp(left) || SvNIOKp(right)) {
1363 if (PL_op->op_private & HINT_INTEGER) {
1364 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1368 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1373 do_vop(PL_op->op_type, TARG, left, right);
1382 djSP; dTARGET; tryAMAGICun(neg);
1387 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1389 if (SvIVX(sv) == IV_MIN) {
1390 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1393 else if (SvUVX(sv) <= IV_MAX) {
1398 else if (SvIVX(sv) != IV_MIN) {
1405 else if (SvPOKp(sv)) {
1407 char *s = SvPV(sv, len);
1408 if (isIDFIRST(*s)) {
1409 sv_setpvn(TARG, "-", 1);
1412 else if (*s == '+' || *s == '-') {
1414 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1416 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1417 sv_setpvn(TARG, "-", 1);
1421 sv_setnv(TARG, -SvNV(sv));
1432 djSP; tryAMAGICunSET(not);
1433 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1439 djSP; dTARGET; tryAMAGICun(compl);
1443 if (PL_op->op_private & HINT_INTEGER) {
1453 register char *tmps;
1454 register long *tmpl;
1459 tmps = SvPV_force(TARG, len);
1462 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1465 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1469 for ( ; anum > 0; anum--, tmps++)
1478 /* integer versions of some of the above */
1482 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1485 SETi( left * right );
1492 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1496 DIE(aTHX_ "Illegal division by zero");
1497 value = POPi / value;
1505 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1509 DIE(aTHX_ "Illegal modulus zero");
1510 SETi( left % right );
1517 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1520 SETi( left + right );
1527 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1530 SETi( left - right );
1537 djSP; tryAMAGICbinSET(lt,0);
1540 SETs(boolSV(left < right));
1547 djSP; tryAMAGICbinSET(gt,0);
1550 SETs(boolSV(left > right));
1557 djSP; tryAMAGICbinSET(le,0);
1560 SETs(boolSV(left <= right));
1567 djSP; tryAMAGICbinSET(ge,0);
1570 SETs(boolSV(left >= right));
1577 djSP; tryAMAGICbinSET(eq,0);
1580 SETs(boolSV(left == right));
1587 djSP; tryAMAGICbinSET(ne,0);
1590 SETs(boolSV(left != right));
1597 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1604 else if (left < right)
1615 djSP; dTARGET; tryAMAGICun(neg);
1620 /* High falutin' math. */
1624 djSP; dTARGET; tryAMAGICbin(atan2,0);
1627 SETn(Perl_atan2(left, right));
1634 djSP; dTARGET; tryAMAGICun(sin);
1638 value = Perl_sin(value);
1646 djSP; dTARGET; tryAMAGICun(cos);
1650 value = Perl_cos(value);
1656 /* Support Configure command-line overrides for rand() functions.
1657 After 5.005, perhaps we should replace this by Configure support
1658 for drand48(), random(), or rand(). For 5.005, though, maintain
1659 compatibility by calling rand() but allow the user to override it.
1660 See INSTALL for details. --Andy Dougherty 15 July 1998
1662 /* Now it's after 5.005, and Configure supports drand48() and random(),
1663 in addition to rand(). So the overrides should not be needed any more.
1664 --Jarkko Hietaniemi 27 September 1998
1667 #ifndef HAS_DRAND48_PROTO
1668 extern double drand48 (void);
1681 if (!PL_srand_called) {
1682 (void)seedDrand01((Rand_seed_t)seed());
1683 PL_srand_called = TRUE;
1698 (void)seedDrand01((Rand_seed_t)anum);
1699 PL_srand_called = TRUE;
1708 * This is really just a quick hack which grabs various garbage
1709 * values. It really should be a real hash algorithm which
1710 * spreads the effect of every input bit onto every output bit,
1711 * if someone who knows about such things would bother to write it.
1712 * Might be a good idea to add that function to CORE as well.
1713 * No numbers below come from careful analysis or anything here,
1714 * except they are primes and SEED_C1 > 1E6 to get a full-width
1715 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1716 * probably be bigger too.
1719 # define SEED_C1 1000003
1720 #define SEED_C4 73819
1722 # define SEED_C1 25747
1723 #define SEED_C4 20639
1727 #define SEED_C5 26107
1730 #ifndef PERL_NO_DEV_RANDOM
1735 # include <starlet.h>
1736 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1737 * in 100-ns units, typically incremented ever 10 ms. */
1738 unsigned int when[2];
1740 # ifdef HAS_GETTIMEOFDAY
1741 struct timeval when;
1747 /* This test is an escape hatch, this symbol isn't set by Configure. */
1748 #ifndef PERL_NO_DEV_RANDOM
1749 #ifndef PERL_RANDOM_DEVICE
1750 /* /dev/random isn't used by default because reads from it will block
1751 * if there isn't enough entropy available. You can compile with
1752 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1753 * is enough real entropy to fill the seed. */
1754 # define PERL_RANDOM_DEVICE "/dev/urandom"
1756 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1758 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1767 _ckvmssts(sys$gettim(when));
1768 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1770 # ifdef HAS_GETTIMEOFDAY
1771 gettimeofday(&when,(struct timezone *) 0);
1772 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1775 u = (U32)SEED_C1 * when;
1778 u += SEED_C3 * (U32)PerlProc_getpid();
1779 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1780 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1781 u += SEED_C5 * (U32)PTR2UV(&when);
1788 djSP; dTARGET; tryAMAGICun(exp);
1792 value = Perl_exp(value);
1800 djSP; dTARGET; tryAMAGICun(log);
1805 RESTORE_NUMERIC_STANDARD();
1806 DIE(aTHX_ "Can't take log of %g", value);
1808 value = Perl_log(value);
1816 djSP; dTARGET; tryAMAGICun(sqrt);
1821 RESTORE_NUMERIC_STANDARD();
1822 DIE(aTHX_ "Can't take sqrt of %g", value);
1824 value = Perl_sqrt(value);
1837 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1843 (void)Perl_modf(value, &value);
1845 (void)Perl_modf(-value, &value);
1860 djSP; dTARGET; tryAMAGICun(abs);
1865 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1866 (iv = SvIVX(TOPs)) != IV_MIN) {
1888 XPUSHn(scan_hex(tmps, 99, &argtype));
1901 while (*tmps && isSPACE(*tmps))
1906 value = scan_hex(++tmps, 99, &argtype);
1907 else if (*tmps == 'b')
1908 value = scan_bin(++tmps, 99, &argtype);
1910 value = scan_oct(tmps, 99, &argtype);
1923 SETi(sv_len_utf8(sv));
1939 I32 lvalue = PL_op->op_flags & OPf_MOD;
1941 I32 arybase = PL_curcop->cop_arybase;
1945 SvTAINTED_off(TARG); /* decontaminate */
1946 SvUTF8_off(TARG); /* decontaminate */
1950 repl = SvPV(sv, repl_len);
1957 tmps = SvPV(sv, curlen);
1959 utfcurlen = sv_len_utf8(sv);
1960 if (utfcurlen == curlen)
1968 if (pos >= arybase) {
1986 else if (len >= 0) {
1988 if (rem > (I32)curlen)
2003 Perl_croak(aTHX_ "substr outside of string");
2004 if (ckWARN(WARN_SUBSTR))
2005 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2010 sv_pos_u2b(sv, &pos, &rem);
2014 sv_setpvn(TARG, tmps, rem);
2016 sv_insert(sv, pos, rem, repl, repl_len);
2017 else if (lvalue) { /* it's an lvalue! */
2018 if (!SvGMAGICAL(sv)) {
2022 if (ckWARN(WARN_SUBSTR))
2023 Perl_warner(aTHX_ WARN_SUBSTR,
2024 "Attempt to use reference as lvalue in substr");
2026 if (SvOK(sv)) /* is it defined ? */
2027 (void)SvPOK_only(sv);
2029 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2032 if (SvTYPE(TARG) < SVt_PVLV) {
2033 sv_upgrade(TARG, SVt_PVLV);
2034 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2038 if (LvTARG(TARG) != sv) {
2040 SvREFCNT_dec(LvTARG(TARG));
2041 LvTARG(TARG) = SvREFCNT_inc(sv);
2043 LvTARGOFF(TARG) = pos;
2044 LvTARGLEN(TARG) = rem;
2048 PUSHs(TARG); /* avoid SvSETMAGIC here */
2055 register I32 size = POPi;
2056 register I32 offset = POPi;
2057 register SV *src = POPs;
2058 I32 lvalue = PL_op->op_flags & OPf_MOD;
2060 SvTAINTED_off(TARG); /* decontaminate */
2061 if (lvalue) { /* it's an lvalue! */
2062 if (SvTYPE(TARG) < SVt_PVLV) {
2063 sv_upgrade(TARG, SVt_PVLV);
2064 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2067 if (LvTARG(TARG) != src) {
2069 SvREFCNT_dec(LvTARG(TARG));
2070 LvTARG(TARG) = SvREFCNT_inc(src);
2072 LvTARGOFF(TARG) = offset;
2073 LvTARGLEN(TARG) = size;
2076 sv_setuv(TARG, do_vecget(src, offset, size));
2091 I32 arybase = PL_curcop->cop_arybase;
2096 offset = POPi - arybase;
2099 tmps = SvPV(big, biglen);
2100 if (offset > 0 && DO_UTF8(big))
2101 sv_pos_u2b(big, &offset, 0);
2104 else if (offset > biglen)
2106 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2107 (unsigned char*)tmps + biglen, little, 0)))
2110 retval = tmps2 - tmps;
2111 if (retval > 0 && DO_UTF8(big))
2112 sv_pos_b2u(big, &retval);
2113 PUSHi(retval + arybase);
2128 I32 arybase = PL_curcop->cop_arybase;
2134 tmps2 = SvPV(little, llen);
2135 tmps = SvPV(big, blen);
2139 if (offset > 0 && DO_UTF8(big))
2140 sv_pos_u2b(big, &offset, 0);
2141 offset = offset - arybase + llen;
2145 else if (offset > blen)
2147 if (!(tmps2 = rninstr(tmps, tmps + offset,
2148 tmps2, tmps2 + llen)))
2151 retval = tmps2 - tmps;
2152 if (retval > 0 && DO_UTF8(big))
2153 sv_pos_b2u(big, &retval);
2154 PUSHi(retval + arybase);
2160 djSP; dMARK; dORIGMARK; dTARGET;
2161 do_sprintf(TARG, SP-MARK, MARK+1);
2162 TAINT_IF(SvTAINTED(TARG));
2174 U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
2177 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2178 value = utf8_to_uv(tmps, &retlen);
2180 value = (UV)(*tmps & 255);
2191 (void)SvUPGRADE(TARG,SVt_PV);
2193 if (value > 255 && !IN_BYTE) {
2194 SvGROW(TARG, UTF8_MAXLEN+1);
2196 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2197 SvCUR_set(TARG, tmps - SvPVX(TARG));
2199 (void)SvPOK_only(TARG);
2210 SvUTF8_off(TARG); /* decontaminate */
2211 (void)SvPOK_only(TARG);
2218 djSP; dTARGET; dPOPTOPssrl;
2221 char *tmps = SvPV(left, n_a);
2223 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2225 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2229 "The crypt() function is unimplemented due to excessive paranoia.");
2242 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2244 U8 tmpbuf[UTF8_MAXLEN];
2246 UV uv = utf8_to_uv(s, &ulen);
2248 if (PL_op->op_private & OPpLOCALE) {
2251 uv = toTITLE_LC_uni(uv);
2254 uv = toTITLE_utf8(s);
2256 tend = uv_to_utf8(tmpbuf, uv);
2258 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2260 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2261 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2266 s = (U8*)SvPV_force(sv, slen);
2267 Copy(tmpbuf, s, ulen, U8);
2271 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2273 SvUTF8_off(TARG); /* decontaminate */
2278 s = (U8*)SvPV_force(sv, slen);
2280 if (PL_op->op_private & OPpLOCALE) {
2283 *s = toUPPER_LC(*s);
2301 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2303 U8 tmpbuf[UTF8_MAXLEN];
2305 UV uv = utf8_to_uv(s, &ulen);
2307 if (PL_op->op_private & OPpLOCALE) {
2310 uv = toLOWER_LC_uni(uv);
2313 uv = toLOWER_utf8(s);
2315 tend = uv_to_utf8(tmpbuf, uv);
2317 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2319 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2320 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2325 s = (U8*)SvPV_force(sv, slen);
2326 Copy(tmpbuf, s, ulen, U8);
2330 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2332 SvUTF8_off(TARG); /* decontaminate */
2337 s = (U8*)SvPV_force(sv, slen);
2339 if (PL_op->op_private & OPpLOCALE) {
2342 *s = toLOWER_LC(*s);
2366 s = (U8*)SvPV(sv,len);
2368 SvUTF8_off(TARG); /* decontaminate */
2369 sv_setpvn(TARG, "", 0);
2373 (void)SvUPGRADE(TARG, SVt_PV);
2374 SvGROW(TARG, (len * 2) + 1);
2375 (void)SvPOK_only(TARG);
2376 d = (U8*)SvPVX(TARG);
2378 if (PL_op->op_private & OPpLOCALE) {
2382 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2388 d = uv_to_utf8(d, toUPPER_utf8( s ));
2394 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2399 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2401 SvUTF8_off(TARG); /* decontaminate */
2406 s = (U8*)SvPV_force(sv, len);
2408 register U8 *send = s + len;
2410 if (PL_op->op_private & OPpLOCALE) {
2413 for (; s < send; s++)
2414 *s = toUPPER_LC(*s);
2417 for (; s < send; s++)
2440 s = (U8*)SvPV(sv,len);
2442 SvUTF8_off(TARG); /* decontaminate */
2443 sv_setpvn(TARG, "", 0);
2447 (void)SvUPGRADE(TARG, SVt_PV);
2448 SvGROW(TARG, (len * 2) + 1);
2449 (void)SvPOK_only(TARG);
2450 d = (U8*)SvPVX(TARG);
2452 if (PL_op->op_private & OPpLOCALE) {
2456 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2462 d = uv_to_utf8(d, toLOWER_utf8(s));
2468 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2473 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2475 SvUTF8_off(TARG); /* decontaminate */
2481 s = (U8*)SvPV_force(sv, len);
2483 register U8 *send = s + len;
2485 if (PL_op->op_private & OPpLOCALE) {
2488 for (; s < send; s++)
2489 *s = toLOWER_LC(*s);
2492 for (; s < send; s++)
2507 register char *s = SvPV(sv,len);
2510 SvUTF8_off(TARG); /* decontaminate */
2512 (void)SvUPGRADE(TARG, SVt_PV);
2513 SvGROW(TARG, (len * 2) + 1);
2518 STRLEN ulen = UTF8SKIP(s);
2542 SvCUR_set(TARG, d - SvPVX(TARG));
2543 (void)SvPOK_only(TARG);
2546 sv_setpvn(TARG, s, len);
2548 if (SvSMAGICAL(TARG))
2557 djSP; dMARK; dORIGMARK;
2559 register AV* av = (AV*)POPs;
2560 register I32 lval = PL_op->op_flags & OPf_MOD;
2561 I32 arybase = PL_curcop->cop_arybase;
2564 if (SvTYPE(av) == SVt_PVAV) {
2565 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2567 for (svp = MARK + 1; svp <= SP; svp++) {
2572 if (max > AvMAX(av))
2575 while (++MARK <= SP) {
2576 elem = SvIVx(*MARK);
2580 svp = av_fetch(av, elem, lval);
2582 if (!svp || *svp == &PL_sv_undef)
2583 DIE(aTHX_ PL_no_aelem, elem);
2584 if (PL_op->op_private & OPpLVAL_INTRO)
2585 save_aelem(av, elem, svp);
2587 *MARK = svp ? *svp : &PL_sv_undef;
2590 if (GIMME != G_ARRAY) {
2598 /* Associative arrays. */
2603 HV *hash = (HV*)POPs;
2605 I32 gimme = GIMME_V;
2606 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2609 /* might clobber stack_sp */
2610 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2615 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2616 if (gimme == G_ARRAY) {
2619 /* might clobber stack_sp */
2621 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2626 else if (gimme == G_SCALAR)
2645 I32 gimme = GIMME_V;
2646 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2650 if (PL_op->op_private & OPpSLICE) {
2654 hvtype = SvTYPE(hv);
2655 if (hvtype == SVt_PVHV) { /* hash element */
2656 while (++MARK <= SP) {
2657 sv = hv_delete_ent(hv, *MARK, discard, 0);
2658 *MARK = sv ? sv : &PL_sv_undef;
2661 else if (hvtype == SVt_PVAV) {
2662 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2663 while (++MARK <= SP) {
2664 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2665 *MARK = sv ? sv : &PL_sv_undef;
2668 else { /* pseudo-hash element */
2669 while (++MARK <= SP) {
2670 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2671 *MARK = sv ? sv : &PL_sv_undef;
2676 DIE(aTHX_ "Not a HASH reference");
2679 else if (gimme == G_SCALAR) {
2688 if (SvTYPE(hv) == SVt_PVHV)
2689 sv = hv_delete_ent(hv, keysv, discard, 0);
2690 else if (SvTYPE(hv) == SVt_PVAV) {
2691 if (PL_op->op_flags & OPf_SPECIAL)
2692 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2694 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2697 DIE(aTHX_ "Not a HASH reference");
2712 if (PL_op->op_private & OPpEXISTS_SUB) {
2716 cv = sv_2cv(sv, &hv, &gv, FALSE);
2719 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2725 if (SvTYPE(hv) == SVt_PVHV) {
2726 if (hv_exists_ent(hv, tmpsv, 0))
2729 else if (SvTYPE(hv) == SVt_PVAV) {
2730 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2731 if (av_exists((AV*)hv, SvIV(tmpsv)))
2734 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2738 DIE(aTHX_ "Not a HASH reference");
2745 djSP; dMARK; dORIGMARK;
2746 register HV *hv = (HV*)POPs;
2747 register I32 lval = PL_op->op_flags & OPf_MOD;
2748 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2750 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2751 DIE(aTHX_ "Can't localize pseudo-hash element");
2753 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2754 while (++MARK <= SP) {
2758 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2759 svp = he ? &HeVAL(he) : 0;
2762 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2765 if (!svp || *svp == &PL_sv_undef) {
2767 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2769 if (PL_op->op_private & OPpLVAL_INTRO)
2770 save_helem(hv, keysv, svp);
2772 *MARK = svp ? *svp : &PL_sv_undef;
2775 if (GIMME != G_ARRAY) {
2783 /* List operators. */
2788 if (GIMME != G_ARRAY) {
2790 *MARK = *SP; /* unwanted list, return last item */
2792 *MARK = &PL_sv_undef;
2801 SV **lastrelem = PL_stack_sp;
2802 SV **lastlelem = PL_stack_base + POPMARK;
2803 SV **firstlelem = PL_stack_base + POPMARK + 1;
2804 register SV **firstrelem = lastlelem + 1;
2805 I32 arybase = PL_curcop->cop_arybase;
2806 I32 lval = PL_op->op_flags & OPf_MOD;
2807 I32 is_something_there = lval;
2809 register I32 max = lastrelem - lastlelem;
2810 register SV **lelem;
2813 if (GIMME != G_ARRAY) {
2814 ix = SvIVx(*lastlelem);
2819 if (ix < 0 || ix >= max)
2820 *firstlelem = &PL_sv_undef;
2822 *firstlelem = firstrelem[ix];
2828 SP = firstlelem - 1;
2832 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2838 if (ix < 0 || ix >= max)
2839 *lelem = &PL_sv_undef;
2841 is_something_there = TRUE;
2842 if (!(*lelem = firstrelem[ix]))
2843 *lelem = &PL_sv_undef;
2846 if (is_something_there)
2849 SP = firstlelem - 1;
2855 djSP; dMARK; dORIGMARK;
2856 I32 items = SP - MARK;
2857 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2858 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2865 djSP; dMARK; dORIGMARK;
2866 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2870 SV *val = NEWSV(46, 0);
2872 sv_setsv(val, *++MARK);
2873 else if (ckWARN(WARN_MISC))
2874 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2875 (void)hv_store_ent(hv,key,val,0);
2884 djSP; dMARK; dORIGMARK;
2885 register AV *ary = (AV*)*++MARK;
2889 register I32 offset;
2890 register I32 length;
2897 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2898 *MARK-- = SvTIED_obj((SV*)ary, mg);
2902 call_method("SPLICE",GIMME_V);
2911 offset = i = SvIVx(*MARK);
2913 offset += AvFILLp(ary) + 1;
2915 offset -= PL_curcop->cop_arybase;
2917 DIE(aTHX_ PL_no_aelem, i);
2919 length = SvIVx(*MARK++);
2921 length += AvFILLp(ary) - offset + 1;
2927 length = AvMAX(ary) + 1; /* close enough to infinity */
2931 length = AvMAX(ary) + 1;
2933 if (offset > AvFILLp(ary) + 1)
2934 offset = AvFILLp(ary) + 1;
2935 after = AvFILLp(ary) + 1 - (offset + length);
2936 if (after < 0) { /* not that much array */
2937 length += after; /* offset+length now in array */
2943 /* At this point, MARK .. SP-1 is our new LIST */
2946 diff = newlen - length;
2947 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2950 if (diff < 0) { /* shrinking the area */
2952 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2953 Copy(MARK, tmparyval, newlen, SV*);
2956 MARK = ORIGMARK + 1;
2957 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2958 MEXTEND(MARK, length);
2959 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2961 EXTEND_MORTAL(length);
2962 for (i = length, dst = MARK; i; i--) {
2963 sv_2mortal(*dst); /* free them eventualy */
2970 *MARK = AvARRAY(ary)[offset+length-1];
2973 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2974 SvREFCNT_dec(*dst++); /* free them now */
2977 AvFILLp(ary) += diff;
2979 /* pull up or down? */
2981 if (offset < after) { /* easier to pull up */
2982 if (offset) { /* esp. if nothing to pull */
2983 src = &AvARRAY(ary)[offset-1];
2984 dst = src - diff; /* diff is negative */
2985 for (i = offset; i > 0; i--) /* can't trust Copy */
2989 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2993 if (after) { /* anything to pull down? */
2994 src = AvARRAY(ary) + offset + length;
2995 dst = src + diff; /* diff is negative */
2996 Move(src, dst, after, SV*);
2998 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2999 /* avoid later double free */
3003 dst[--i] = &PL_sv_undef;
3006 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3008 *dst = NEWSV(46, 0);
3009 sv_setsv(*dst++, *src++);
3011 Safefree(tmparyval);
3014 else { /* no, expanding (or same) */
3016 New(452, tmparyval, length, SV*); /* so remember deletion */
3017 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3020 if (diff > 0) { /* expanding */
3022 /* push up or down? */
3024 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3028 Move(src, dst, offset, SV*);
3030 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3032 AvFILLp(ary) += diff;
3035 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3036 av_extend(ary, AvFILLp(ary) + diff);
3037 AvFILLp(ary) += diff;
3040 dst = AvARRAY(ary) + AvFILLp(ary);
3042 for (i = after; i; i--) {
3049 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3050 *dst = NEWSV(46, 0);
3051 sv_setsv(*dst++, *src++);
3053 MARK = ORIGMARK + 1;
3054 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3056 Copy(tmparyval, MARK, length, SV*);
3058 EXTEND_MORTAL(length);
3059 for (i = length, dst = MARK; i; i--) {
3060 sv_2mortal(*dst); /* free them eventualy */
3064 Safefree(tmparyval);
3068 else if (length--) {
3069 *MARK = tmparyval[length];
3072 while (length-- > 0)
3073 SvREFCNT_dec(tmparyval[length]);
3075 Safefree(tmparyval);
3078 *MARK = &PL_sv_undef;
3086 djSP; dMARK; dORIGMARK; dTARGET;
3087 register AV *ary = (AV*)*++MARK;
3088 register SV *sv = &PL_sv_undef;
3091 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3092 *MARK-- = SvTIED_obj((SV*)ary, mg);
3096 call_method("PUSH",G_SCALAR|G_DISCARD);
3101 /* Why no pre-extend of ary here ? */
3102 for (++MARK; MARK <= SP; MARK++) {
3105 sv_setsv(sv, *MARK);
3110 PUSHi( AvFILL(ary) + 1 );
3118 SV *sv = av_pop(av);
3120 (void)sv_2mortal(sv);
3129 SV *sv = av_shift(av);
3134 (void)sv_2mortal(sv);
3141 djSP; dMARK; dORIGMARK; dTARGET;
3142 register AV *ary = (AV*)*++MARK;
3147 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3148 *MARK-- = SvTIED_obj((SV*)ary, mg);
3152 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3157 av_unshift(ary, SP - MARK);
3160 sv_setsv(sv, *++MARK);
3161 (void)av_store(ary, i++, sv);
3165 PUSHi( AvFILL(ary) + 1 );
3175 if (GIMME == G_ARRAY) {
3182 /* safe as long as stack cannot get extended in the above */
3187 register char *down;
3192 SvUTF8_off(TARG); /* decontaminate */
3194 do_join(TARG, &PL_sv_no, MARK, SP);
3196 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3197 up = SvPV_force(TARG, len);
3199 if (DO_UTF8(TARG)) { /* first reverse each character */
3200 U8* s = (U8*)SvPVX(TARG);
3201 U8* send = (U8*)(s + len);
3210 down = (char*)(s - 1);
3211 if (s > send || !((*down & 0xc0) == 0x80)) {
3212 if (ckWARN_d(WARN_UTF8))
3213 Perl_warner(aTHX_ WARN_UTF8,
3214 "Malformed UTF-8 character");
3226 down = SvPVX(TARG) + len - 1;
3232 (void)SvPOK_only(TARG);
3241 S_mul128(pTHX_ SV *sv, U8 m)
3244 char *s = SvPV(sv, len);
3248 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3249 SV *tmpNew = newSVpvn("0000000000", 10);
3251 sv_catsv(tmpNew, sv);
3252 SvREFCNT_dec(sv); /* free old sv */
3257 while (!*t) /* trailing '\0'? */
3260 i = ((*t - '0') << 7) + m;
3261 *(t--) = '0' + (i % 10);
3267 /* Explosives and implosives. */
3269 #if 'I' == 73 && 'J' == 74
3270 /* On an ASCII/ISO kind of system */
3271 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3274 Some other sort of character set - use memchr() so we don't match
3277 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3284 I32 start_sp_offset = SP - PL_stack_base;
3285 I32 gimme = GIMME_V;
3289 register char *pat = SvPV(left, llen);
3290 register char *s = SvPV(right, rlen);
3291 char *strend = s + rlen;
3293 register char *patend = pat + llen;
3299 /* These must not be in registers: */
3316 register U32 culong;
3320 #ifdef PERL_NATINT_PACK
3321 int natint; /* native integer */
3322 int unatint; /* unsigned native integer */
3325 if (gimme != G_ARRAY) { /* arrange to do first one only */
3327 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3328 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3330 while (isDIGIT(*patend) || *patend == '*')
3336 while (pat < patend) {
3338 datumtype = *pat++ & 0xFF;
3339 #ifdef PERL_NATINT_PACK
3342 if (isSPACE(datumtype))
3344 if (datumtype == '#') {
3345 while (pat < patend && *pat != '\n')
3350 char *natstr = "sSiIlL";
3352 if (strchr(natstr, datumtype)) {
3353 #ifdef PERL_NATINT_PACK
3359 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3364 else if (*pat == '*') {
3365 len = strend - strbeg; /* long enough */
3369 else if (isDIGIT(*pat)) {
3371 while (isDIGIT(*pat)) {
3372 len = (len * 10) + (*pat++ - '0');
3374 DIE(aTHX_ "Repeat count in unpack overflows");
3378 len = (datumtype != '@');
3382 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3383 case ',': /* grandfather in commas but with a warning */
3384 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3385 Perl_warner(aTHX_ WARN_UNPACK,
3386 "Invalid type in unpack: '%c'", (int)datumtype);
3389 if (len == 1 && pat[-1] != '1')
3398 if (len > strend - strbeg)
3399 DIE(aTHX_ "@ outside of string");
3403 if (len > s - strbeg)
3404 DIE(aTHX_ "X outside of string");
3408 if (len > strend - s)
3409 DIE(aTHX_ "x outside of string");
3413 if (start_sp_offset >= SP - PL_stack_base)
3414 DIE(aTHX_ "/ must follow a numeric type");
3417 pat++; /* ignore '*' for compatibility with pack */
3419 DIE(aTHX_ "/ cannot take a count" );
3426 if (len > strend - s)
3429 goto uchar_checksum;
3430 sv = NEWSV(35, len);
3431 sv_setpvn(sv, s, len);
3433 if (datumtype == 'A' || datumtype == 'Z') {
3434 aptr = s; /* borrow register */
3435 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3440 else { /* 'A' strips both nulls and spaces */
3441 s = SvPVX(sv) + len - 1;
3442 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3446 SvCUR_set(sv, s - SvPVX(sv));
3447 s = aptr; /* unborrow register */
3449 XPUSHs(sv_2mortal(sv));
3453 if (star || len > (strend - s) * 8)
3454 len = (strend - s) * 8;
3457 Newz(601, PL_bitcount, 256, char);
3458 for (bits = 1; bits < 256; bits++) {
3459 if (bits & 1) PL_bitcount[bits]++;
3460 if (bits & 2) PL_bitcount[bits]++;
3461 if (bits & 4) PL_bitcount[bits]++;
3462 if (bits & 8) PL_bitcount[bits]++;
3463 if (bits & 16) PL_bitcount[bits]++;
3464 if (bits & 32) PL_bitcount[bits]++;
3465 if (bits & 64) PL_bitcount[bits]++;
3466 if (bits & 128) PL_bitcount[bits]++;
3470 culong += PL_bitcount[*(unsigned char*)s++];
3475 if (datumtype == 'b') {
3477 if (bits & 1) culong++;
3483 if (bits & 128) culong++;
3490 sv = NEWSV(35, len + 1);
3494 if (datumtype == 'b') {
3496 for (len = 0; len < aint; len++) {
3497 if (len & 7) /*SUPPRESS 595*/
3501 *str++ = '0' + (bits & 1);
3506 for (len = 0; len < aint; len++) {
3511 *str++ = '0' + ((bits & 128) != 0);
3515 XPUSHs(sv_2mortal(sv));
3519 if (star || len > (strend - s) * 2)
3520 len = (strend - s) * 2;
3521 sv = NEWSV(35, len + 1);
3525 if (datumtype == 'h') {
3527 for (len = 0; len < aint; len++) {
3532 *str++ = PL_hexdigit[bits & 15];
3537 for (len = 0; len < aint; len++) {
3542 *str++ = PL_hexdigit[(bits >> 4) & 15];
3546 XPUSHs(sv_2mortal(sv));
3549 if (len > strend - s)
3554 if (aint >= 128) /* fake up signed chars */
3564 if (aint >= 128) /* fake up signed chars */
3567 sv_setiv(sv, (IV)aint);
3568 PUSHs(sv_2mortal(sv));
3573 if (len > strend - s)
3588 sv_setiv(sv, (IV)auint);
3589 PUSHs(sv_2mortal(sv));
3594 if (len > strend - s)
3597 while (len-- > 0 && s < strend) {
3598 auint = utf8_to_uv((U8*)s, &along);
3601 cdouble += (NV)auint;
3609 while (len-- > 0 && s < strend) {
3610 auint = utf8_to_uv((U8*)s, &along);
3613 sv_setuv(sv, (UV)auint);
3614 PUSHs(sv_2mortal(sv));
3619 #if SHORTSIZE == SIZE16
3620 along = (strend - s) / SIZE16;
3622 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3627 #if SHORTSIZE != SIZE16
3631 COPYNN(s, &ashort, sizeof(short));
3642 #if SHORTSIZE > SIZE16
3654 #if SHORTSIZE != SIZE16
3658 COPYNN(s, &ashort, sizeof(short));
3661 sv_setiv(sv, (IV)ashort);
3662 PUSHs(sv_2mortal(sv));
3670 #if SHORTSIZE > SIZE16
3676 sv_setiv(sv, (IV)ashort);
3677 PUSHs(sv_2mortal(sv));
3685 #if SHORTSIZE == SIZE16
3686 along = (strend - s) / SIZE16;
3688 unatint = natint && datumtype == 'S';
3689 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3694 #if SHORTSIZE != SIZE16
3696 unsigned short aushort;
3698 COPYNN(s, &aushort, sizeof(unsigned short));
3699 s += sizeof(unsigned short);
3707 COPY16(s, &aushort);
3710 if (datumtype == 'n')
3711 aushort = PerlSock_ntohs(aushort);
3714 if (datumtype == 'v')
3715 aushort = vtohs(aushort);
3724 #if SHORTSIZE != SIZE16
3726 unsigned short aushort;
3728 COPYNN(s, &aushort, sizeof(unsigned short));
3729 s += sizeof(unsigned short);
3731 sv_setiv(sv, (UV)aushort);
3732 PUSHs(sv_2mortal(sv));
3739 COPY16(s, &aushort);
3743 if (datumtype == 'n')
3744 aushort = PerlSock_ntohs(aushort);
3747 if (datumtype == 'v')
3748 aushort = vtohs(aushort);
3750 sv_setiv(sv, (UV)aushort);
3751 PUSHs(sv_2mortal(sv));
3757 along = (strend - s) / sizeof(int);
3762 Copy(s, &aint, 1, int);
3765 cdouble += (NV)aint;
3774 Copy(s, &aint, 1, int);
3778 /* Without the dummy below unpack("i", pack("i",-1))
3779 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3780 * cc with optimization turned on.
3782 * The bug was detected in
3783 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3784 * with optimization (-O4) turned on.
3785 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3786 * does not have this problem even with -O4.
3788 * This bug was reported as DECC_BUGS 1431
3789 * and tracked internally as GEM_BUGS 7775.
3791 * The bug is fixed in
3792 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3793 * UNIX V4.0F support: DEC C V5.9-006 or later
3794 * UNIX V4.0E support: DEC C V5.8-011 or later
3797 * See also few lines later for the same bug.
3800 sv_setiv(sv, (IV)aint) :
3802 sv_setiv(sv, (IV)aint);
3803 PUSHs(sv_2mortal(sv));
3808 along = (strend - s) / sizeof(unsigned int);
3813 Copy(s, &auint, 1, unsigned int);
3814 s += sizeof(unsigned int);
3816 cdouble += (NV)auint;
3825 Copy(s, &auint, 1, unsigned int);
3826 s += sizeof(unsigned int);
3829 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3830 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3831 * See details few lines earlier. */
3833 sv_setuv(sv, (UV)auint) :
3835 sv_setuv(sv, (UV)auint);
3836 PUSHs(sv_2mortal(sv));
3841 #if LONGSIZE == SIZE32
3842 along = (strend - s) / SIZE32;
3844 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3849 #if LONGSIZE != SIZE32
3853 COPYNN(s, &along, sizeof(long));
3856 cdouble += (NV)along;
3866 #if LONGSIZE > SIZE32
3867 if (along > 2147483647)
3868 along -= 4294967296;
3872 cdouble += (NV)along;
3881 #if LONGSIZE != SIZE32
3885 COPYNN(s, &along, sizeof(long));
3888 sv_setiv(sv, (IV)along);
3889 PUSHs(sv_2mortal(sv));
3897 #if LONGSIZE > SIZE32
3898 if (along > 2147483647)
3899 along -= 4294967296;
3903 sv_setiv(sv, (IV)along);
3904 PUSHs(sv_2mortal(sv));
3912 #if LONGSIZE == SIZE32
3913 along = (strend - s) / SIZE32;
3915 unatint = natint && datumtype == 'L';
3916 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3921 #if LONGSIZE != SIZE32
3923 unsigned long aulong;
3925 COPYNN(s, &aulong, sizeof(unsigned long));
3926 s += sizeof(unsigned long);
3928 cdouble += (NV)aulong;
3940 if (datumtype == 'N')
3941 aulong = PerlSock_ntohl(aulong);
3944 if (datumtype == 'V')
3945 aulong = vtohl(aulong);
3948 cdouble += (NV)aulong;
3957 #if LONGSIZE != SIZE32
3959 unsigned long aulong;
3961 COPYNN(s, &aulong, sizeof(unsigned long));
3962 s += sizeof(unsigned long);
3964 sv_setuv(sv, (UV)aulong);
3965 PUSHs(sv_2mortal(sv));
3975 if (datumtype == 'N')
3976 aulong = PerlSock_ntohl(aulong);
3979 if (datumtype == 'V')
3980 aulong = vtohl(aulong);
3983 sv_setuv(sv, (UV)aulong);
3984 PUSHs(sv_2mortal(sv));
3990 along = (strend - s) / sizeof(char*);
3996 if (sizeof(char*) > strend - s)
3999 Copy(s, &aptr, 1, char*);
4005 PUSHs(sv_2mortal(sv));
4015 while ((len > 0) && (s < strend)) {
4016 auv = (auv << 7) | (*s & 0x7f);
4017 if (!(*s++ & 0x80)) {
4021 PUSHs(sv_2mortal(sv));
4025 else if (++bytes >= sizeof(UV)) { /* promote to string */
4029 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4030 while (s < strend) {
4031 sv = mul128(sv, *s & 0x7f);
4032 if (!(*s++ & 0x80)) {
4041 PUSHs(sv_2mortal(sv));
4046 if ((s >= strend) && bytes)
4047 DIE(aTHX_ "Unterminated compressed integer");
4052 if (sizeof(char*) > strend - s)
4055 Copy(s, &aptr, 1, char*);
4060 sv_setpvn(sv, aptr, len);
4061 PUSHs(sv_2mortal(sv));
4065 along = (strend - s) / sizeof(Quad_t);
4071 if (s + sizeof(Quad_t) > strend)
4074 Copy(s, &aquad, 1, Quad_t);
4075 s += sizeof(Quad_t);
4078 if (aquad >= IV_MIN && aquad <= IV_MAX)
4079 sv_setiv(sv, (IV)aquad);
4081 sv_setnv(sv, (NV)aquad);
4082 PUSHs(sv_2mortal(sv));
4086 along = (strend - s) / sizeof(Quad_t);
4092 if (s + sizeof(Uquad_t) > strend)
4095 Copy(s, &auquad, 1, Uquad_t);
4096 s += sizeof(Uquad_t);
4099 if (auquad <= UV_MAX)
4100 sv_setuv(sv, (UV)auquad);
4102 sv_setnv(sv, (NV)auquad);
4103 PUSHs(sv_2mortal(sv));
4107 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4110 along = (strend - s) / sizeof(float);
4115 Copy(s, &afloat, 1, float);
4124 Copy(s, &afloat, 1, float);
4127 sv_setnv(sv, (NV)afloat);
4128 PUSHs(sv_2mortal(sv));
4134 along = (strend - s) / sizeof(double);
4139 Copy(s, &adouble, 1, double);
4140 s += sizeof(double);
4148 Copy(s, &adouble, 1, double);
4149 s += sizeof(double);
4151 sv_setnv(sv, (NV)adouble);
4152 PUSHs(sv_2mortal(sv));
4158 * Initialise the decode mapping. By using a table driven
4159 * algorithm, the code will be character-set independent
4160 * (and just as fast as doing character arithmetic)
4162 if (PL_uudmap['M'] == 0) {
4165 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4166 PL_uudmap[(U8)PL_uuemap[i]] = i;
4168 * Because ' ' and '`' map to the same value,
4169 * we need to decode them both the same.
4174 along = (strend - s) * 3 / 4;
4175 sv = NEWSV(42, along);
4178 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4183 len = PL_uudmap[*(U8*)s++] & 077;
4185 if (s < strend && ISUUCHAR(*s))
4186 a = PL_uudmap[*(U8*)s++] & 077;
4189 if (s < strend && ISUUCHAR(*s))
4190 b = PL_uudmap[*(U8*)s++] & 077;
4193 if (s < strend && ISUUCHAR(*s))
4194 c = PL_uudmap[*(U8*)s++] & 077;
4197 if (s < strend && ISUUCHAR(*s))
4198 d = PL_uudmap[*(U8*)s++] & 077;
4201 hunk[0] = (a << 2) | (b >> 4);
4202 hunk[1] = (b << 4) | (c >> 2);
4203 hunk[2] = (c << 6) | d;
4204 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4209 else if (s[1] == '\n') /* possible checksum byte */
4212 XPUSHs(sv_2mortal(sv));
4217 if (strchr("fFdD", datumtype) ||
4218 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4222 while (checksum >= 16) {
4226 while (checksum >= 4) {
4232 along = (1 << checksum) - 1;
4233 while (cdouble < 0.0)
4235 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4236 sv_setnv(sv, cdouble);
4239 if (checksum < 32) {
4240 aulong = (1 << checksum) - 1;
4243 sv_setuv(sv, (UV)culong);
4245 XPUSHs(sv_2mortal(sv));
4249 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4250 PUSHs(&PL_sv_undef);
4255 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4259 *hunk = PL_uuemap[len];
4260 sv_catpvn(sv, hunk, 1);
4263 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4264 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4265 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4266 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4267 sv_catpvn(sv, hunk, 4);
4272 char r = (len > 1 ? s[1] : '\0');
4273 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4274 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4275 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4276 hunk[3] = PL_uuemap[0];
4277 sv_catpvn(sv, hunk, 4);
4279 sv_catpvn(sv, "\n", 1);
4283 S_is_an_int(pTHX_ char *s, STRLEN l)
4286 SV *result = newSVpvn(s, l);
4287 char *result_c = SvPV(result, n_a); /* convenience */
4288 char *out = result_c;
4298 SvREFCNT_dec(result);
4321 SvREFCNT_dec(result);
4327 SvCUR_set(result, out - result_c);
4331 /* pnum must be '\0' terminated */
4333 S_div128(pTHX_ SV *pnum, bool *done)
4336 char *s = SvPV(pnum, len);
4345 i = m * 10 + (*t - '0');
4347 r = (i >> 7); /* r < 10 */
4354 SvCUR_set(pnum, (STRLEN) (t - s));
4361 djSP; dMARK; dORIGMARK; dTARGET;
4362 register SV *cat = TARG;
4365 register char *pat = SvPVx(*++MARK, fromlen);
4366 register char *patend = pat + fromlen;
4371 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4372 static char *space10 = " ";
4374 /* These must not be in registers: */
4389 #ifdef PERL_NATINT_PACK
4390 int natint; /* native integer */
4395 sv_setpvn(cat, "", 0);
4396 while (pat < patend) {
4397 SV *lengthcode = Nullsv;
4398 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4399 datumtype = *pat++ & 0xFF;
4400 #ifdef PERL_NATINT_PACK
4403 if (isSPACE(datumtype))
4405 if (datumtype == '#') {
4406 while (pat < patend && *pat != '\n')
4411 char *natstr = "sSiIlL";
4413 if (strchr(natstr, datumtype)) {
4414 #ifdef PERL_NATINT_PACK
4420 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4423 len = strchr("@Xxu", datumtype) ? 0 : items;
4426 else if (isDIGIT(*pat)) {
4428 while (isDIGIT(*pat)) {
4429 len = (len * 10) + (*pat++ - '0');
4431 DIE(aTHX_ "Repeat count in pack overflows");
4438 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4439 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4440 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4441 ? *MARK : &PL_sv_no)));
4445 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4446 case ',': /* grandfather in commas but with a warning */
4447 if (commas++ == 0 && ckWARN(WARN_PACK))
4448 Perl_warner(aTHX_ WARN_PACK,
4449 "Invalid type in pack: '%c'", (int)datumtype);
4452 DIE(aTHX_ "%% may only be used in unpack");
4463 if (SvCUR(cat) < len)
4464 DIE(aTHX_ "X outside of string");
4471 sv_catpvn(cat, null10, 10);
4474 sv_catpvn(cat, null10, len);
4480 aptr = SvPV(fromstr, fromlen);
4481 if (pat[-1] == '*') {
4483 if (datumtype == 'Z')
4486 if (fromlen >= len) {
4487 sv_catpvn(cat, aptr, len);
4488 if (datumtype == 'Z')
4489 *(SvEND(cat)-1) = '\0';
4492 sv_catpvn(cat, aptr, fromlen);
4494 if (datumtype == 'A') {
4496 sv_catpvn(cat, space10, 10);
4499 sv_catpvn(cat, space10, len);
4503 sv_catpvn(cat, null10, 10);
4506 sv_catpvn(cat, null10, len);
4518 str = SvPV(fromstr, fromlen);
4522 SvCUR(cat) += (len+7)/8;
4523 SvGROW(cat, SvCUR(cat) + 1);
4524 aptr = SvPVX(cat) + aint;
4529 if (datumtype == 'B') {
4530 for (len = 0; len++ < aint;) {
4531 items |= *str++ & 1;
4535 *aptr++ = items & 0xff;
4541 for (len = 0; len++ < aint;) {
4547 *aptr++ = items & 0xff;
4553 if (datumtype == 'B')
4554 items <<= 7 - (aint & 7);
4556 items >>= 7 - (aint & 7);
4557 *aptr++ = items & 0xff;
4559 str = SvPVX(cat) + SvCUR(cat);
4574 str = SvPV(fromstr, fromlen);
4578 SvCUR(cat) += (len+1)/2;
4579 SvGROW(cat, SvCUR(cat) + 1);
4580 aptr = SvPVX(cat) + aint;
4585 if (datumtype == 'H') {
4586 for (len = 0; len++ < aint;) {
4588 items |= ((*str++ & 15) + 9) & 15;
4590 items |= *str++ & 15;
4594 *aptr++ = items & 0xff;
4600 for (len = 0; len++ < aint;) {
4602 items |= (((*str++ & 15) + 9) & 15) << 4;
4604 items |= (*str++ & 15) << 4;
4608 *aptr++ = items & 0xff;
4614 *aptr++ = items & 0xff;
4615 str = SvPVX(cat) + SvCUR(cat);
4626 aint = SvIV(fromstr);
4628 sv_catpvn(cat, &achar, sizeof(char));
4634 auint = SvUV(fromstr);
4635 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4636 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4641 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4646 afloat = (float)SvNV(fromstr);
4647 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4654 adouble = (double)SvNV(fromstr);
4655 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4661 ashort = (I16)SvIV(fromstr);
4663 ashort = PerlSock_htons(ashort);
4665 CAT16(cat, &ashort);
4671 ashort = (I16)SvIV(fromstr);
4673 ashort = htovs(ashort);
4675 CAT16(cat, &ashort);
4679 #if SHORTSIZE != SIZE16
4681 unsigned short aushort;
4685 aushort = SvUV(fromstr);
4686 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4696 aushort = (U16)SvUV(fromstr);
4697 CAT16(cat, &aushort);
4703 #if SHORTSIZE != SIZE16
4709 ashort = SvIV(fromstr);
4710 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4718 ashort = (I16)SvIV(fromstr);
4719 CAT16(cat, &ashort);
4726 auint = SvUV(fromstr);
4727 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4733 adouble = Perl_floor(SvNV(fromstr));
4736 DIE(aTHX_ "Cannot compress negative numbers");
4739 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4740 adouble <= 0xffffffff
4742 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4743 adouble <= UV_MAX_cxux
4750 char buf[1 + sizeof(UV)];
4751 char *in = buf + sizeof(buf);
4752 UV auv = U_V(adouble);
4755 *--in = (auv & 0x7f) | 0x80;
4758 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4759 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4761 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4762 char *from, *result, *in;
4767 /* Copy string and check for compliance */
4768 from = SvPV(fromstr, len);
4769 if ((norm = is_an_int(from, len)) == NULL)
4770 DIE(aTHX_ "can compress only unsigned integer");
4772 New('w', result, len, char);
4776 *--in = div128(norm, &done) | 0x80;
4777 result[len - 1] &= 0x7F; /* clear continue bit */
4778 sv_catpvn(cat, in, (result + len) - in);
4780 SvREFCNT_dec(norm); /* free norm */
4782 else if (SvNOKp(fromstr)) {
4783 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4784 char *in = buf + sizeof(buf);
4787 double next = floor(adouble / 128);
4788 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4789 if (--in < buf) /* this cannot happen ;-) */
4790 DIE(aTHX_ "Cannot compress integer");
4792 } while (adouble > 0);
4793 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4794 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4797 DIE(aTHX_ "Cannot compress non integer");
4803 aint = SvIV(fromstr);
4804 sv_catpvn(cat, (char*)&aint, sizeof(int));
4810 aulong = SvUV(fromstr);
4812 aulong = PerlSock_htonl(aulong);
4814 CAT32(cat, &aulong);
4820 aulong = SvUV(fromstr);
4822 aulong = htovl(aulong);
4824 CAT32(cat, &aulong);
4828 #if LONGSIZE != SIZE32
4830 unsigned long aulong;
4834 aulong = SvUV(fromstr);
4835 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4843 aulong = SvUV(fromstr);
4844 CAT32(cat, &aulong);
4849 #if LONGSIZE != SIZE32
4855 along = SvIV(fromstr);
4856 sv_catpvn(cat, (char *)&along, sizeof(long));
4864 along = SvIV(fromstr);
4873 auquad = (Uquad_t)SvUV(fromstr);
4874 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4880 aquad = (Quad_t)SvIV(fromstr);
4881 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4886 len = 1; /* assume SV is correct length */
4891 if (fromstr == &PL_sv_undef)
4895 /* XXX better yet, could spirit away the string to
4896 * a safe spot and hang on to it until the result
4897 * of pack() (and all copies of the result) are
4900 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4901 || (SvPADTMP(fromstr)
4902 && !SvREADONLY(fromstr))))
4904 Perl_warner(aTHX_ WARN_PACK,
4905 "Attempt to pack pointer to temporary value");
4907 if (SvPOK(fromstr) || SvNIOK(fromstr))
4908 aptr = SvPV(fromstr,n_a);
4910 aptr = SvPV_force(fromstr,n_a);
4912 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4917 aptr = SvPV(fromstr, fromlen);
4918 SvGROW(cat, fromlen * 4 / 3);
4923 while (fromlen > 0) {
4930 doencodes(cat, aptr, todo);
4949 register I32 limit = POPi; /* note, negative is forever */
4952 register char *s = SvPV(sv, len);
4953 char *strend = s + len;
4955 register REGEXP *rx;
4959 I32 maxiters = (strend - s) + 10;
4962 I32 origlimit = limit;
4965 AV *oldstack = PL_curstack;
4966 I32 gimme = GIMME_V;
4967 I32 oldsave = PL_savestack_ix;
4968 I32 make_mortal = 1;
4969 MAGIC *mg = (MAGIC *) NULL;
4972 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4977 DIE(aTHX_ "panic: do_split");
4978 rx = pm->op_pmregexp;
4980 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4981 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4983 if (pm->op_pmreplroot) {
4985 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4987 ary = GvAVn((GV*)pm->op_pmreplroot);
4990 else if (gimme != G_ARRAY)
4992 ary = (AV*)PL_curpad[0];
4994 ary = GvAVn(PL_defgv);
4995 #endif /* USE_THREADS */
4998 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5004 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5006 XPUSHs(SvTIED_obj((SV*)ary, mg));
5012 for (i = AvFILLp(ary); i >= 0; i--)
5013 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5015 /* temporarily switch stacks */
5016 SWITCHSTACK(PL_curstack, ary);
5020 base = SP - PL_stack_base;
5022 if (pm->op_pmflags & PMf_SKIPWHITE) {
5023 if (pm->op_pmflags & PMf_LOCALE) {
5024 while (isSPACE_LC(*s))
5032 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5033 SAVEINT(PL_multiline);
5034 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5038 limit = maxiters + 2;
5039 if (pm->op_pmflags & PMf_WHITE) {
5042 while (m < strend &&
5043 !((pm->op_pmflags & PMf_LOCALE)
5044 ? isSPACE_LC(*m) : isSPACE(*m)))
5049 dstr = NEWSV(30, m-s);
5050 sv_setpvn(dstr, s, m-s);
5056 while (s < strend &&
5057 ((pm->op_pmflags & PMf_LOCALE)
5058 ? isSPACE_LC(*s) : isSPACE(*s)))
5062 else if (strEQ("^", rx->precomp)) {
5065 for (m = s; m < strend && *m != '\n'; m++) ;
5069 dstr = NEWSV(30, m-s);
5070 sv_setpvn(dstr, s, m-s);
5077 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5078 && (rx->reganch & ROPT_CHECK_ALL)
5079 && !(rx->reganch & ROPT_ANCH)) {
5080 int tail = (rx->reganch & RE_INTUIT_TAIL);
5081 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5085 if (len == 1 && !tail) {
5089 for (m = s; m < strend && *m != c; m++) ;
5092 dstr = NEWSV(30, m-s);
5093 sv_setpvn(dstr, s, m-s);
5102 while (s < strend && --limit &&
5103 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5104 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5107 dstr = NEWSV(31, m-s);
5108 sv_setpvn(dstr, s, m-s);
5112 s = m + len; /* Fake \n at the end */
5117 maxiters += (strend - s) * rx->nparens;
5118 while (s < strend && --limit
5119 /* && (!rx->check_substr
5120 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5122 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5123 1 /* minend */, sv, NULL, 0))
5125 TAINT_IF(RX_MATCH_TAINTED(rx));
5126 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5131 strend = s + (strend - m);
5133 m = rx->startp[0] + orig;
5134 dstr = NEWSV(32, m-s);
5135 sv_setpvn(dstr, s, m-s);
5140 for (i = 1; i <= rx->nparens; i++) {
5141 s = rx->startp[i] + orig;
5142 m = rx->endp[i] + orig;
5144 dstr = NEWSV(33, m-s);
5145 sv_setpvn(dstr, s, m-s);
5148 dstr = NEWSV(33, 0);
5154 s = rx->endp[0] + orig;
5158 LEAVE_SCOPE(oldsave);
5159 iters = (SP - PL_stack_base) - base;
5160 if (iters > maxiters)
5161 DIE(aTHX_ "Split loop");
5163 /* keep field after final delim? */
5164 if (s < strend || (iters && origlimit)) {
5165 dstr = NEWSV(34, strend-s);
5166 sv_setpvn(dstr, s, strend-s);
5172 else if (!origlimit) {
5173 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5179 SWITCHSTACK(ary, oldstack);
5180 if (SvSMAGICAL(ary)) {
5185 if (gimme == G_ARRAY) {
5187 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5195 call_method("PUSH",G_SCALAR|G_DISCARD);
5198 if (gimme == G_ARRAY) {
5199 /* EXTEND should not be needed - we just popped them */
5201 for (i=0; i < iters; i++) {
5202 SV **svp = av_fetch(ary, i, FALSE);
5203 PUSHs((svp) ? *svp : &PL_sv_undef);
5210 if (gimme == G_ARRAY)
5213 if (iters || !pm->op_pmreplroot) {
5223 Perl_unlock_condpair(pTHX_ void *svv)
5226 MAGIC *mg = mg_find((SV*)svv, 'm');
5229 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5230 MUTEX_LOCK(MgMUTEXP(mg));
5231 if (MgOWNER(mg) != thr)
5232 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5234 COND_SIGNAL(MgOWNERCONDP(mg));
5235 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5236 PTR2UV(thr), PTR2UV(svv));)
5237 MUTEX_UNLOCK(MgMUTEXP(mg));
5239 #endif /* USE_THREADS */
5252 mg = condpair_magic(sv);
5253 MUTEX_LOCK(MgMUTEXP(mg));
5254 if (MgOWNER(mg) == thr)
5255 MUTEX_UNLOCK(MgMUTEXP(mg));
5258 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5260 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5261 PTR2UV(thr), PTR2UV(sv));)
5262 MUTEX_UNLOCK(MgMUTEXP(mg));
5263 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5265 #endif /* USE_THREADS */
5266 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5267 || SvTYPE(retsv) == SVt_PVCV) {
5268 retsv = refto(retsv);
5279 if (PL_op->op_private & OPpLVAL_INTRO)
5280 PUSHs(*save_threadsv(PL_op->op_targ));
5282 PUSHs(THREADSV(PL_op->op_targ));
5285 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5286 #endif /* USE_THREADS */