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 */
1081 bool isutf = DO_UTF8(tmpstr);
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';
1096 (void)SvPOK_only_UTF8(TARG);
1098 (void)SvPOK_only(TARG);
1107 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1110 SETn( left - right );
1117 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1120 if (PL_op->op_private & HINT_INTEGER) {
1134 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1137 if (PL_op->op_private & HINT_INTEGER) {
1151 djSP; tryAMAGICbinSET(lt,0);
1154 SETs(boolSV(TOPn < value));
1161 djSP; tryAMAGICbinSET(gt,0);
1164 SETs(boolSV(TOPn > value));
1171 djSP; tryAMAGICbinSET(le,0);
1174 SETs(boolSV(TOPn <= value));
1181 djSP; tryAMAGICbinSET(ge,0);
1184 SETs(boolSV(TOPn >= value));
1191 djSP; tryAMAGICbinSET(ne,0);
1194 SETs(boolSV(TOPn != value));
1201 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1207 if (Perl_isnan(left) || Perl_isnan(right)) {
1211 value = (left > right) - (left < right);
1215 else if (left < right)
1217 else if (left > right)
1231 djSP; tryAMAGICbinSET(slt,0);
1234 int cmp = ((PL_op->op_private & OPpLOCALE)
1235 ? sv_cmp_locale(left, right)
1236 : sv_cmp(left, right));
1237 SETs(boolSV(cmp < 0));
1244 djSP; tryAMAGICbinSET(sgt,0);
1247 int cmp = ((PL_op->op_private & OPpLOCALE)
1248 ? sv_cmp_locale(left, right)
1249 : sv_cmp(left, right));
1250 SETs(boolSV(cmp > 0));
1257 djSP; tryAMAGICbinSET(sle,0);
1260 int cmp = ((PL_op->op_private & OPpLOCALE)
1261 ? sv_cmp_locale(left, right)
1262 : sv_cmp(left, right));
1263 SETs(boolSV(cmp <= 0));
1270 djSP; tryAMAGICbinSET(sge,0);
1273 int cmp = ((PL_op->op_private & OPpLOCALE)
1274 ? sv_cmp_locale(left, right)
1275 : sv_cmp(left, right));
1276 SETs(boolSV(cmp >= 0));
1283 djSP; tryAMAGICbinSET(seq,0);
1286 SETs(boolSV(sv_eq(left, right)));
1293 djSP; tryAMAGICbinSET(sne,0);
1296 SETs(boolSV(!sv_eq(left, right)));
1303 djSP; dTARGET; tryAMAGICbin(scmp,0);
1306 int cmp = ((PL_op->op_private & OPpLOCALE)
1307 ? sv_cmp_locale(left, right)
1308 : sv_cmp(left, right));
1316 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1319 if (SvNIOKp(left) || SvNIOKp(right)) {
1320 if (PL_op->op_private & HINT_INTEGER) {
1321 IV i = SvIV(left) & SvIV(right);
1325 UV u = SvUV(left) & SvUV(right);
1330 do_vop(PL_op->op_type, TARG, left, right);
1339 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1342 if (SvNIOKp(left) || SvNIOKp(right)) {
1343 if (PL_op->op_private & HINT_INTEGER) {
1344 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1348 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1353 do_vop(PL_op->op_type, TARG, left, right);
1362 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1365 if (SvNIOKp(left) || SvNIOKp(right)) {
1366 if (PL_op->op_private & HINT_INTEGER) {
1367 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1371 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1376 do_vop(PL_op->op_type, TARG, left, right);
1385 djSP; dTARGET; tryAMAGICun(neg);
1390 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1392 if (SvIVX(sv) == IV_MIN) {
1393 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1396 else if (SvUVX(sv) <= IV_MAX) {
1401 else if (SvIVX(sv) != IV_MIN) {
1408 else if (SvPOKp(sv)) {
1410 char *s = SvPV(sv, len);
1411 if (isIDFIRST(*s)) {
1412 sv_setpvn(TARG, "-", 1);
1415 else if (*s == '+' || *s == '-') {
1417 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1419 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1420 sv_setpvn(TARG, "-", 1);
1424 sv_setnv(TARG, -SvNV(sv));
1435 djSP; tryAMAGICunSET(not);
1436 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1442 djSP; dTARGET; tryAMAGICun(compl);
1446 if (PL_op->op_private & HINT_INTEGER) {
1456 register char *tmps;
1457 register long *tmpl;
1462 tmps = SvPV_force(TARG, len);
1465 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1468 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1472 for ( ; anum > 0; anum--, tmps++)
1481 /* integer versions of some of the above */
1485 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1488 SETi( left * right );
1495 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1499 DIE(aTHX_ "Illegal division by zero");
1500 value = POPi / value;
1508 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1512 DIE(aTHX_ "Illegal modulus zero");
1513 SETi( left % right );
1520 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1523 SETi( left + right );
1530 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1533 SETi( left - right );
1540 djSP; tryAMAGICbinSET(lt,0);
1543 SETs(boolSV(left < right));
1550 djSP; tryAMAGICbinSET(gt,0);
1553 SETs(boolSV(left > right));
1560 djSP; tryAMAGICbinSET(le,0);
1563 SETs(boolSV(left <= right));
1570 djSP; tryAMAGICbinSET(ge,0);
1573 SETs(boolSV(left >= right));
1580 djSP; tryAMAGICbinSET(eq,0);
1583 SETs(boolSV(left == right));
1590 djSP; tryAMAGICbinSET(ne,0);
1593 SETs(boolSV(left != right));
1600 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1607 else if (left < right)
1618 djSP; dTARGET; tryAMAGICun(neg);
1623 /* High falutin' math. */
1627 djSP; dTARGET; tryAMAGICbin(atan2,0);
1630 SETn(Perl_atan2(left, right));
1637 djSP; dTARGET; tryAMAGICun(sin);
1641 value = Perl_sin(value);
1649 djSP; dTARGET; tryAMAGICun(cos);
1653 value = Perl_cos(value);
1659 /* Support Configure command-line overrides for rand() functions.
1660 After 5.005, perhaps we should replace this by Configure support
1661 for drand48(), random(), or rand(). For 5.005, though, maintain
1662 compatibility by calling rand() but allow the user to override it.
1663 See INSTALL for details. --Andy Dougherty 15 July 1998
1665 /* Now it's after 5.005, and Configure supports drand48() and random(),
1666 in addition to rand(). So the overrides should not be needed any more.
1667 --Jarkko Hietaniemi 27 September 1998
1670 #ifndef HAS_DRAND48_PROTO
1671 extern double drand48 (void);
1684 if (!PL_srand_called) {
1685 (void)seedDrand01((Rand_seed_t)seed());
1686 PL_srand_called = TRUE;
1701 (void)seedDrand01((Rand_seed_t)anum);
1702 PL_srand_called = TRUE;
1711 * This is really just a quick hack which grabs various garbage
1712 * values. It really should be a real hash algorithm which
1713 * spreads the effect of every input bit onto every output bit,
1714 * if someone who knows about such things would bother to write it.
1715 * Might be a good idea to add that function to CORE as well.
1716 * No numbers below come from careful analysis or anything here,
1717 * except they are primes and SEED_C1 > 1E6 to get a full-width
1718 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1719 * probably be bigger too.
1722 # define SEED_C1 1000003
1723 #define SEED_C4 73819
1725 # define SEED_C1 25747
1726 #define SEED_C4 20639
1730 #define SEED_C5 26107
1733 #ifndef PERL_NO_DEV_RANDOM
1738 # include <starlet.h>
1739 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1740 * in 100-ns units, typically incremented ever 10 ms. */
1741 unsigned int when[2];
1743 # ifdef HAS_GETTIMEOFDAY
1744 struct timeval when;
1750 /* This test is an escape hatch, this symbol isn't set by Configure. */
1751 #ifndef PERL_NO_DEV_RANDOM
1752 #ifndef PERL_RANDOM_DEVICE
1753 /* /dev/random isn't used by default because reads from it will block
1754 * if there isn't enough entropy available. You can compile with
1755 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1756 * is enough real entropy to fill the seed. */
1757 # define PERL_RANDOM_DEVICE "/dev/urandom"
1759 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1761 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1770 _ckvmssts(sys$gettim(when));
1771 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1773 # ifdef HAS_GETTIMEOFDAY
1774 gettimeofday(&when,(struct timezone *) 0);
1775 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1778 u = (U32)SEED_C1 * when;
1781 u += SEED_C3 * (U32)PerlProc_getpid();
1782 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1783 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1784 u += SEED_C5 * (U32)PTR2UV(&when);
1791 djSP; dTARGET; tryAMAGICun(exp);
1795 value = Perl_exp(value);
1803 djSP; dTARGET; tryAMAGICun(log);
1808 RESTORE_NUMERIC_STANDARD();
1809 DIE(aTHX_ "Can't take log of %g", value);
1811 value = Perl_log(value);
1819 djSP; dTARGET; tryAMAGICun(sqrt);
1824 RESTORE_NUMERIC_STANDARD();
1825 DIE(aTHX_ "Can't take sqrt of %g", value);
1827 value = Perl_sqrt(value);
1840 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1846 (void)Perl_modf(value, &value);
1848 (void)Perl_modf(-value, &value);
1863 djSP; dTARGET; tryAMAGICun(abs);
1868 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1869 (iv = SvIVX(TOPs)) != IV_MIN) {
1891 argtype = 1; /* allow underscores */
1892 XPUSHn(scan_hex(tmps, 99, &argtype));
1905 while (*tmps && isSPACE(*tmps))
1909 argtype = 1; /* allow underscores */
1911 value = scan_hex(++tmps, 99, &argtype);
1912 else if (*tmps == 'b')
1913 value = scan_bin(++tmps, 99, &argtype);
1915 value = scan_oct(tmps, 99, &argtype);
1928 SETi(sv_len_utf8(sv));
1944 I32 lvalue = PL_op->op_flags & OPf_MOD;
1946 I32 arybase = PL_curcop->cop_arybase;
1950 SvTAINTED_off(TARG); /* decontaminate */
1951 SvUTF8_off(TARG); /* decontaminate */
1955 repl = SvPV(sv, repl_len);
1962 tmps = SvPV(sv, curlen);
1964 utfcurlen = sv_len_utf8(sv);
1965 if (utfcurlen == curlen)
1973 if (pos >= arybase) {
1991 else if (len >= 0) {
1993 if (rem > (I32)curlen)
2008 Perl_croak(aTHX_ "substr outside of string");
2009 if (ckWARN(WARN_SUBSTR))
2010 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2015 sv_pos_u2b(sv, &pos, &rem);
2017 sv_setpvn(TARG, tmps, rem);
2021 sv_insert(sv, pos, rem, repl, repl_len);
2022 else if (lvalue) { /* it's an lvalue! */
2023 if (!SvGMAGICAL(sv)) {
2027 if (ckWARN(WARN_SUBSTR))
2028 Perl_warner(aTHX_ WARN_SUBSTR,
2029 "Attempt to use reference as lvalue in substr");
2031 if (SvOK(sv)) /* is it defined ? */
2032 (void)SvPOK_only_UTF8(sv);
2034 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2037 if (SvTYPE(TARG) < SVt_PVLV) {
2038 sv_upgrade(TARG, SVt_PVLV);
2039 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2043 if (LvTARG(TARG) != sv) {
2045 SvREFCNT_dec(LvTARG(TARG));
2046 LvTARG(TARG) = SvREFCNT_inc(sv);
2048 LvTARGOFF(TARG) = pos;
2049 LvTARGLEN(TARG) = rem;
2053 PUSHs(TARG); /* avoid SvSETMAGIC here */
2060 register I32 size = POPi;
2061 register I32 offset = POPi;
2062 register SV *src = POPs;
2063 I32 lvalue = PL_op->op_flags & OPf_MOD;
2065 SvTAINTED_off(TARG); /* decontaminate */
2066 if (lvalue) { /* it's an lvalue! */
2067 if (SvTYPE(TARG) < SVt_PVLV) {
2068 sv_upgrade(TARG, SVt_PVLV);
2069 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2072 if (LvTARG(TARG) != src) {
2074 SvREFCNT_dec(LvTARG(TARG));
2075 LvTARG(TARG) = SvREFCNT_inc(src);
2077 LvTARGOFF(TARG) = offset;
2078 LvTARGLEN(TARG) = size;
2081 sv_setuv(TARG, do_vecget(src, offset, size));
2096 I32 arybase = PL_curcop->cop_arybase;
2101 offset = POPi - arybase;
2104 tmps = SvPV(big, biglen);
2105 if (offset > 0 && DO_UTF8(big))
2106 sv_pos_u2b(big, &offset, 0);
2109 else if (offset > biglen)
2111 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2112 (unsigned char*)tmps + biglen, little, 0)))
2115 retval = tmps2 - tmps;
2116 if (retval > 0 && DO_UTF8(big))
2117 sv_pos_b2u(big, &retval);
2118 PUSHi(retval + arybase);
2133 I32 arybase = PL_curcop->cop_arybase;
2139 tmps2 = SvPV(little, llen);
2140 tmps = SvPV(big, blen);
2144 if (offset > 0 && DO_UTF8(big))
2145 sv_pos_u2b(big, &offset, 0);
2146 offset = offset - arybase + llen;
2150 else if (offset > blen)
2152 if (!(tmps2 = rninstr(tmps, tmps + offset,
2153 tmps2, tmps2 + llen)))
2156 retval = tmps2 - tmps;
2157 if (retval > 0 && DO_UTF8(big))
2158 sv_pos_b2u(big, &retval);
2159 PUSHi(retval + arybase);
2165 djSP; dMARK; dORIGMARK; dTARGET;
2166 do_sprintf(TARG, SP-MARK, MARK+1);
2167 TAINT_IF(SvTAINTED(TARG));
2179 U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
2182 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2183 value = utf8_to_uv(tmps, &retlen);
2185 value = (UV)(*tmps & 255);
2196 (void)SvUPGRADE(TARG,SVt_PV);
2198 if (value > 255 && !IN_BYTE) {
2199 SvGROW(TARG, UTF8_MAXLEN+1);
2201 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2202 SvCUR_set(TARG, tmps - SvPVX(TARG));
2204 (void)SvPOK_only(TARG);
2215 (void)SvPOK_only(TARG);
2222 djSP; dTARGET; dPOPTOPssrl;
2225 char *tmps = SvPV(left, n_a);
2227 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2229 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2233 "The crypt() function is unimplemented due to excessive paranoia.");
2246 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2248 U8 tmpbuf[UTF8_MAXLEN];
2250 UV uv = utf8_to_uv(s, &ulen);
2252 if (PL_op->op_private & OPpLOCALE) {
2255 uv = toTITLE_LC_uni(uv);
2258 uv = toTITLE_utf8(s);
2260 tend = uv_to_utf8(tmpbuf, uv);
2262 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2264 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2265 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2270 s = (U8*)SvPV_force(sv, slen);
2271 Copy(tmpbuf, s, ulen, U8);
2275 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2277 SvUTF8_off(TARG); /* decontaminate */
2282 s = (U8*)SvPV_force(sv, slen);
2284 if (PL_op->op_private & OPpLOCALE) {
2287 *s = toUPPER_LC(*s);
2305 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2307 U8 tmpbuf[UTF8_MAXLEN];
2309 UV uv = utf8_to_uv(s, &ulen);
2311 if (PL_op->op_private & OPpLOCALE) {
2314 uv = toLOWER_LC_uni(uv);
2317 uv = toLOWER_utf8(s);
2319 tend = uv_to_utf8(tmpbuf, uv);
2321 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2323 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2324 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2329 s = (U8*)SvPV_force(sv, slen);
2330 Copy(tmpbuf, s, ulen, U8);
2334 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2336 SvUTF8_off(TARG); /* decontaminate */
2341 s = (U8*)SvPV_force(sv, slen);
2343 if (PL_op->op_private & OPpLOCALE) {
2346 *s = toLOWER_LC(*s);
2370 s = (U8*)SvPV(sv,len);
2372 SvUTF8_off(TARG); /* decontaminate */
2373 sv_setpvn(TARG, "", 0);
2377 (void)SvUPGRADE(TARG, SVt_PV);
2378 SvGROW(TARG, (len * 2) + 1);
2379 (void)SvPOK_only(TARG);
2380 d = (U8*)SvPVX(TARG);
2382 if (PL_op->op_private & OPpLOCALE) {
2386 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2392 d = uv_to_utf8(d, toUPPER_utf8( s ));
2398 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2403 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2405 SvUTF8_off(TARG); /* decontaminate */
2410 s = (U8*)SvPV_force(sv, len);
2412 register U8 *send = s + len;
2414 if (PL_op->op_private & OPpLOCALE) {
2417 for (; s < send; s++)
2418 *s = toUPPER_LC(*s);
2421 for (; s < send; s++)
2444 s = (U8*)SvPV(sv,len);
2446 SvUTF8_off(TARG); /* decontaminate */
2447 sv_setpvn(TARG, "", 0);
2451 (void)SvUPGRADE(TARG, SVt_PV);
2452 SvGROW(TARG, (len * 2) + 1);
2453 (void)SvPOK_only(TARG);
2454 d = (U8*)SvPVX(TARG);
2456 if (PL_op->op_private & OPpLOCALE) {
2460 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2466 d = uv_to_utf8(d, toLOWER_utf8(s));
2472 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2477 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2479 SvUTF8_off(TARG); /* decontaminate */
2485 s = (U8*)SvPV_force(sv, len);
2487 register U8 *send = s + len;
2489 if (PL_op->op_private & OPpLOCALE) {
2492 for (; s < send; s++)
2493 *s = toLOWER_LC(*s);
2496 for (; s < send; s++)
2511 register char *s = SvPV(sv,len);
2514 SvUTF8_off(TARG); /* decontaminate */
2516 (void)SvUPGRADE(TARG, SVt_PV);
2517 SvGROW(TARG, (len * 2) + 1);
2522 STRLEN ulen = UTF8SKIP(s);
2546 SvCUR_set(TARG, d - SvPVX(TARG));
2547 (void)SvPOK_only_UTF8(TARG);
2550 sv_setpvn(TARG, s, len);
2552 if (SvSMAGICAL(TARG))
2561 djSP; dMARK; dORIGMARK;
2563 register AV* av = (AV*)POPs;
2564 register I32 lval = PL_op->op_flags & OPf_MOD;
2565 I32 arybase = PL_curcop->cop_arybase;
2568 if (SvTYPE(av) == SVt_PVAV) {
2569 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2571 for (svp = MARK + 1; svp <= SP; svp++) {
2576 if (max > AvMAX(av))
2579 while (++MARK <= SP) {
2580 elem = SvIVx(*MARK);
2584 svp = av_fetch(av, elem, lval);
2586 if (!svp || *svp == &PL_sv_undef)
2587 DIE(aTHX_ PL_no_aelem, elem);
2588 if (PL_op->op_private & OPpLVAL_INTRO)
2589 save_aelem(av, elem, svp);
2591 *MARK = svp ? *svp : &PL_sv_undef;
2594 if (GIMME != G_ARRAY) {
2602 /* Associative arrays. */
2607 HV *hash = (HV*)POPs;
2609 I32 gimme = GIMME_V;
2610 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2613 /* might clobber stack_sp */
2614 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2619 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2620 if (gimme == G_ARRAY) {
2623 /* might clobber stack_sp */
2625 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2630 else if (gimme == G_SCALAR)
2649 I32 gimme = GIMME_V;
2650 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2654 if (PL_op->op_private & OPpSLICE) {
2658 hvtype = SvTYPE(hv);
2659 if (hvtype == SVt_PVHV) { /* hash element */
2660 while (++MARK <= SP) {
2661 sv = hv_delete_ent(hv, *MARK, discard, 0);
2662 *MARK = sv ? sv : &PL_sv_undef;
2665 else if (hvtype == SVt_PVAV) {
2666 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2667 while (++MARK <= SP) {
2668 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2669 *MARK = sv ? sv : &PL_sv_undef;
2672 else { /* pseudo-hash element */
2673 while (++MARK <= SP) {
2674 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2675 *MARK = sv ? sv : &PL_sv_undef;
2680 DIE(aTHX_ "Not a HASH reference");
2683 else if (gimme == G_SCALAR) {
2692 if (SvTYPE(hv) == SVt_PVHV)
2693 sv = hv_delete_ent(hv, keysv, discard, 0);
2694 else if (SvTYPE(hv) == SVt_PVAV) {
2695 if (PL_op->op_flags & OPf_SPECIAL)
2696 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2698 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2701 DIE(aTHX_ "Not a HASH reference");
2716 if (PL_op->op_private & OPpEXISTS_SUB) {
2720 cv = sv_2cv(sv, &hv, &gv, FALSE);
2723 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2729 if (SvTYPE(hv) == SVt_PVHV) {
2730 if (hv_exists_ent(hv, tmpsv, 0))
2733 else if (SvTYPE(hv) == SVt_PVAV) {
2734 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2735 if (av_exists((AV*)hv, SvIV(tmpsv)))
2738 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2742 DIE(aTHX_ "Not a HASH reference");
2749 djSP; dMARK; dORIGMARK;
2750 register HV *hv = (HV*)POPs;
2751 register I32 lval = PL_op->op_flags & OPf_MOD;
2752 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2754 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2755 DIE(aTHX_ "Can't localize pseudo-hash element");
2757 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2758 while (++MARK <= SP) {
2762 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2763 svp = he ? &HeVAL(he) : 0;
2766 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2769 if (!svp || *svp == &PL_sv_undef) {
2771 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2773 if (PL_op->op_private & OPpLVAL_INTRO)
2774 save_helem(hv, keysv, svp);
2776 *MARK = svp ? *svp : &PL_sv_undef;
2779 if (GIMME != G_ARRAY) {
2787 /* List operators. */
2792 if (GIMME != G_ARRAY) {
2794 *MARK = *SP; /* unwanted list, return last item */
2796 *MARK = &PL_sv_undef;
2805 SV **lastrelem = PL_stack_sp;
2806 SV **lastlelem = PL_stack_base + POPMARK;
2807 SV **firstlelem = PL_stack_base + POPMARK + 1;
2808 register SV **firstrelem = lastlelem + 1;
2809 I32 arybase = PL_curcop->cop_arybase;
2810 I32 lval = PL_op->op_flags & OPf_MOD;
2811 I32 is_something_there = lval;
2813 register I32 max = lastrelem - lastlelem;
2814 register SV **lelem;
2817 if (GIMME != G_ARRAY) {
2818 ix = SvIVx(*lastlelem);
2823 if (ix < 0 || ix >= max)
2824 *firstlelem = &PL_sv_undef;
2826 *firstlelem = firstrelem[ix];
2832 SP = firstlelem - 1;
2836 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2842 if (ix < 0 || ix >= max)
2843 *lelem = &PL_sv_undef;
2845 is_something_there = TRUE;
2846 if (!(*lelem = firstrelem[ix]))
2847 *lelem = &PL_sv_undef;
2850 if (is_something_there)
2853 SP = firstlelem - 1;
2859 djSP; dMARK; dORIGMARK;
2860 I32 items = SP - MARK;
2861 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2862 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2869 djSP; dMARK; dORIGMARK;
2870 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2874 SV *val = NEWSV(46, 0);
2876 sv_setsv(val, *++MARK);
2877 else if (ckWARN(WARN_MISC))
2878 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2879 (void)hv_store_ent(hv,key,val,0);
2888 djSP; dMARK; dORIGMARK;
2889 register AV *ary = (AV*)*++MARK;
2893 register I32 offset;
2894 register I32 length;
2901 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2902 *MARK-- = SvTIED_obj((SV*)ary, mg);
2906 call_method("SPLICE",GIMME_V);
2915 offset = i = SvIVx(*MARK);
2917 offset += AvFILLp(ary) + 1;
2919 offset -= PL_curcop->cop_arybase;
2921 DIE(aTHX_ PL_no_aelem, i);
2923 length = SvIVx(*MARK++);
2925 length += AvFILLp(ary) - offset + 1;
2931 length = AvMAX(ary) + 1; /* close enough to infinity */
2935 length = AvMAX(ary) + 1;
2937 if (offset > AvFILLp(ary) + 1)
2938 offset = AvFILLp(ary) + 1;
2939 after = AvFILLp(ary) + 1 - (offset + length);
2940 if (after < 0) { /* not that much array */
2941 length += after; /* offset+length now in array */
2947 /* At this point, MARK .. SP-1 is our new LIST */
2950 diff = newlen - length;
2951 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2954 if (diff < 0) { /* shrinking the area */
2956 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2957 Copy(MARK, tmparyval, newlen, SV*);
2960 MARK = ORIGMARK + 1;
2961 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2962 MEXTEND(MARK, length);
2963 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2965 EXTEND_MORTAL(length);
2966 for (i = length, dst = MARK; i; i--) {
2967 sv_2mortal(*dst); /* free them eventualy */
2974 *MARK = AvARRAY(ary)[offset+length-1];
2977 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2978 SvREFCNT_dec(*dst++); /* free them now */
2981 AvFILLp(ary) += diff;
2983 /* pull up or down? */
2985 if (offset < after) { /* easier to pull up */
2986 if (offset) { /* esp. if nothing to pull */
2987 src = &AvARRAY(ary)[offset-1];
2988 dst = src - diff; /* diff is negative */
2989 for (i = offset; i > 0; i--) /* can't trust Copy */
2993 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2997 if (after) { /* anything to pull down? */
2998 src = AvARRAY(ary) + offset + length;
2999 dst = src + diff; /* diff is negative */
3000 Move(src, dst, after, SV*);
3002 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3003 /* avoid later double free */
3007 dst[--i] = &PL_sv_undef;
3010 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3012 *dst = NEWSV(46, 0);
3013 sv_setsv(*dst++, *src++);
3015 Safefree(tmparyval);
3018 else { /* no, expanding (or same) */
3020 New(452, tmparyval, length, SV*); /* so remember deletion */
3021 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3024 if (diff > 0) { /* expanding */
3026 /* push up or down? */
3028 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3032 Move(src, dst, offset, SV*);
3034 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3036 AvFILLp(ary) += diff;
3039 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3040 av_extend(ary, AvFILLp(ary) + diff);
3041 AvFILLp(ary) += diff;
3044 dst = AvARRAY(ary) + AvFILLp(ary);
3046 for (i = after; i; i--) {
3053 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3054 *dst = NEWSV(46, 0);
3055 sv_setsv(*dst++, *src++);
3057 MARK = ORIGMARK + 1;
3058 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3060 Copy(tmparyval, MARK, length, SV*);
3062 EXTEND_MORTAL(length);
3063 for (i = length, dst = MARK; i; i--) {
3064 sv_2mortal(*dst); /* free them eventualy */
3068 Safefree(tmparyval);
3072 else if (length--) {
3073 *MARK = tmparyval[length];
3076 while (length-- > 0)
3077 SvREFCNT_dec(tmparyval[length]);
3079 Safefree(tmparyval);
3082 *MARK = &PL_sv_undef;
3090 djSP; dMARK; dORIGMARK; dTARGET;
3091 register AV *ary = (AV*)*++MARK;
3092 register SV *sv = &PL_sv_undef;
3095 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3096 *MARK-- = SvTIED_obj((SV*)ary, mg);
3100 call_method("PUSH",G_SCALAR|G_DISCARD);
3105 /* Why no pre-extend of ary here ? */
3106 for (++MARK; MARK <= SP; MARK++) {
3109 sv_setsv(sv, *MARK);
3114 PUSHi( AvFILL(ary) + 1 );
3122 SV *sv = av_pop(av);
3124 (void)sv_2mortal(sv);
3133 SV *sv = av_shift(av);
3138 (void)sv_2mortal(sv);
3145 djSP; dMARK; dORIGMARK; dTARGET;
3146 register AV *ary = (AV*)*++MARK;
3151 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3152 *MARK-- = SvTIED_obj((SV*)ary, mg);
3156 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3161 av_unshift(ary, SP - MARK);
3164 sv_setsv(sv, *++MARK);
3165 (void)av_store(ary, i++, sv);
3169 PUSHi( AvFILL(ary) + 1 );
3179 if (GIMME == G_ARRAY) {
3186 /* safe as long as stack cannot get extended in the above */
3191 register char *down;
3196 SvUTF8_off(TARG); /* decontaminate */
3198 do_join(TARG, &PL_sv_no, MARK, SP);
3200 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3201 up = SvPV_force(TARG, len);
3203 if (DO_UTF8(TARG)) { /* first reverse each character */
3204 U8* s = (U8*)SvPVX(TARG);
3205 U8* send = (U8*)(s + len);
3214 down = (char*)(s - 1);
3215 if (s > send || !((*down & 0xc0) == 0x80)) {
3216 if (ckWARN_d(WARN_UTF8))
3217 Perl_warner(aTHX_ WARN_UTF8,
3218 "Malformed UTF-8 character");
3230 down = SvPVX(TARG) + len - 1;
3236 (void)SvPOK_only_UTF8(TARG);
3245 S_mul128(pTHX_ SV *sv, U8 m)
3248 char *s = SvPV(sv, len);
3252 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3253 SV *tmpNew = newSVpvn("0000000000", 10);
3255 sv_catsv(tmpNew, sv);
3256 SvREFCNT_dec(sv); /* free old sv */
3261 while (!*t) /* trailing '\0'? */
3264 i = ((*t - '0') << 7) + m;
3265 *(t--) = '0' + (i % 10);
3271 /* Explosives and implosives. */
3273 #if 'I' == 73 && 'J' == 74
3274 /* On an ASCII/ISO kind of system */
3275 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3278 Some other sort of character set - use memchr() so we don't match
3281 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3288 I32 start_sp_offset = SP - PL_stack_base;
3289 I32 gimme = GIMME_V;
3293 register char *pat = SvPV(left, llen);
3294 register char *s = SvPV(right, rlen);
3295 char *strend = s + rlen;
3297 register char *patend = pat + llen;
3303 /* These must not be in registers: */
3320 register U32 culong;
3324 #ifdef PERL_NATINT_PACK
3325 int natint; /* native integer */
3326 int unatint; /* unsigned native integer */
3329 if (gimme != G_ARRAY) { /* arrange to do first one only */
3331 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3332 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3334 while (isDIGIT(*patend) || *patend == '*')
3340 while (pat < patend) {
3342 datumtype = *pat++ & 0xFF;
3343 #ifdef PERL_NATINT_PACK
3346 if (isSPACE(datumtype))
3348 if (datumtype == '#') {
3349 while (pat < patend && *pat != '\n')
3354 char *natstr = "sSiIlL";
3356 if (strchr(natstr, datumtype)) {
3357 #ifdef PERL_NATINT_PACK
3363 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3368 else if (*pat == '*') {
3369 len = strend - strbeg; /* long enough */
3373 else if (isDIGIT(*pat)) {
3375 while (isDIGIT(*pat)) {
3376 len = (len * 10) + (*pat++ - '0');
3378 DIE(aTHX_ "Repeat count in unpack overflows");
3382 len = (datumtype != '@');
3386 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3387 case ',': /* grandfather in commas but with a warning */
3388 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3389 Perl_warner(aTHX_ WARN_UNPACK,
3390 "Invalid type in unpack: '%c'", (int)datumtype);
3393 if (len == 1 && pat[-1] != '1')
3402 if (len > strend - strbeg)
3403 DIE(aTHX_ "@ outside of string");
3407 if (len > s - strbeg)
3408 DIE(aTHX_ "X outside of string");
3412 if (len > strend - s)
3413 DIE(aTHX_ "x outside of string");
3417 if (start_sp_offset >= SP - PL_stack_base)
3418 DIE(aTHX_ "/ must follow a numeric type");
3421 pat++; /* ignore '*' for compatibility with pack */
3423 DIE(aTHX_ "/ cannot take a count" );
3430 if (len > strend - s)
3433 goto uchar_checksum;
3434 sv = NEWSV(35, len);
3435 sv_setpvn(sv, s, len);
3437 if (datumtype == 'A' || datumtype == 'Z') {
3438 aptr = s; /* borrow register */
3439 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3444 else { /* 'A' strips both nulls and spaces */
3445 s = SvPVX(sv) + len - 1;
3446 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3450 SvCUR_set(sv, s - SvPVX(sv));
3451 s = aptr; /* unborrow register */
3453 XPUSHs(sv_2mortal(sv));
3457 if (star || len > (strend - s) * 8)
3458 len = (strend - s) * 8;
3461 Newz(601, PL_bitcount, 256, char);
3462 for (bits = 1; bits < 256; bits++) {
3463 if (bits & 1) PL_bitcount[bits]++;
3464 if (bits & 2) PL_bitcount[bits]++;
3465 if (bits & 4) PL_bitcount[bits]++;
3466 if (bits & 8) PL_bitcount[bits]++;
3467 if (bits & 16) PL_bitcount[bits]++;
3468 if (bits & 32) PL_bitcount[bits]++;
3469 if (bits & 64) PL_bitcount[bits]++;
3470 if (bits & 128) PL_bitcount[bits]++;
3474 culong += PL_bitcount[*(unsigned char*)s++];
3479 if (datumtype == 'b') {
3481 if (bits & 1) culong++;
3487 if (bits & 128) culong++;
3494 sv = NEWSV(35, len + 1);
3498 if (datumtype == 'b') {
3500 for (len = 0; len < aint; len++) {
3501 if (len & 7) /*SUPPRESS 595*/
3505 *str++ = '0' + (bits & 1);
3510 for (len = 0; len < aint; len++) {
3515 *str++ = '0' + ((bits & 128) != 0);
3519 XPUSHs(sv_2mortal(sv));
3523 if (star || len > (strend - s) * 2)
3524 len = (strend - s) * 2;
3525 sv = NEWSV(35, len + 1);
3529 if (datumtype == 'h') {
3531 for (len = 0; len < aint; len++) {
3536 *str++ = PL_hexdigit[bits & 15];
3541 for (len = 0; len < aint; len++) {
3546 *str++ = PL_hexdigit[(bits >> 4) & 15];
3550 XPUSHs(sv_2mortal(sv));
3553 if (len > strend - s)
3558 if (aint >= 128) /* fake up signed chars */
3568 if (aint >= 128) /* fake up signed chars */
3571 sv_setiv(sv, (IV)aint);
3572 PUSHs(sv_2mortal(sv));
3577 if (len > strend - s)
3592 sv_setiv(sv, (IV)auint);
3593 PUSHs(sv_2mortal(sv));
3598 if (len > strend - s)
3601 while (len-- > 0 && s < strend) {
3602 auint = utf8_to_uv((U8*)s, &along);
3605 cdouble += (NV)auint;
3613 while (len-- > 0 && s < strend) {
3614 auint = utf8_to_uv((U8*)s, &along);
3617 sv_setuv(sv, (UV)auint);
3618 PUSHs(sv_2mortal(sv));
3623 #if SHORTSIZE == SIZE16
3624 along = (strend - s) / SIZE16;
3626 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3631 #if SHORTSIZE != SIZE16
3635 COPYNN(s, &ashort, sizeof(short));
3646 #if SHORTSIZE > SIZE16
3658 #if SHORTSIZE != SIZE16
3662 COPYNN(s, &ashort, sizeof(short));
3665 sv_setiv(sv, (IV)ashort);
3666 PUSHs(sv_2mortal(sv));
3674 #if SHORTSIZE > SIZE16
3680 sv_setiv(sv, (IV)ashort);
3681 PUSHs(sv_2mortal(sv));
3689 #if SHORTSIZE == SIZE16
3690 along = (strend - s) / SIZE16;
3692 unatint = natint && datumtype == 'S';
3693 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3698 #if SHORTSIZE != SIZE16
3700 unsigned short aushort;
3702 COPYNN(s, &aushort, sizeof(unsigned short));
3703 s += sizeof(unsigned short);
3711 COPY16(s, &aushort);
3714 if (datumtype == 'n')
3715 aushort = PerlSock_ntohs(aushort);
3718 if (datumtype == 'v')
3719 aushort = vtohs(aushort);
3728 #if SHORTSIZE != SIZE16
3730 unsigned short aushort;
3732 COPYNN(s, &aushort, sizeof(unsigned short));
3733 s += sizeof(unsigned short);
3735 sv_setiv(sv, (UV)aushort);
3736 PUSHs(sv_2mortal(sv));
3743 COPY16(s, &aushort);
3747 if (datumtype == 'n')
3748 aushort = PerlSock_ntohs(aushort);
3751 if (datumtype == 'v')
3752 aushort = vtohs(aushort);
3754 sv_setiv(sv, (UV)aushort);
3755 PUSHs(sv_2mortal(sv));
3761 along = (strend - s) / sizeof(int);
3766 Copy(s, &aint, 1, int);
3769 cdouble += (NV)aint;
3778 Copy(s, &aint, 1, int);
3782 /* Without the dummy below unpack("i", pack("i",-1))
3783 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3784 * cc with optimization turned on.
3786 * The bug was detected in
3787 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3788 * with optimization (-O4) turned on.
3789 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3790 * does not have this problem even with -O4.
3792 * This bug was reported as DECC_BUGS 1431
3793 * and tracked internally as GEM_BUGS 7775.
3795 * The bug is fixed in
3796 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3797 * UNIX V4.0F support: DEC C V5.9-006 or later
3798 * UNIX V4.0E support: DEC C V5.8-011 or later
3801 * See also few lines later for the same bug.
3804 sv_setiv(sv, (IV)aint) :
3806 sv_setiv(sv, (IV)aint);
3807 PUSHs(sv_2mortal(sv));
3812 along = (strend - s) / sizeof(unsigned int);
3817 Copy(s, &auint, 1, unsigned int);
3818 s += sizeof(unsigned int);
3820 cdouble += (NV)auint;
3829 Copy(s, &auint, 1, unsigned int);
3830 s += sizeof(unsigned int);
3833 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3834 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3835 * See details few lines earlier. */
3837 sv_setuv(sv, (UV)auint) :
3839 sv_setuv(sv, (UV)auint);
3840 PUSHs(sv_2mortal(sv));
3845 #if LONGSIZE == SIZE32
3846 along = (strend - s) / SIZE32;
3848 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3853 #if LONGSIZE != SIZE32
3857 COPYNN(s, &along, sizeof(long));
3860 cdouble += (NV)along;
3870 #if LONGSIZE > SIZE32
3871 if (along > 2147483647)
3872 along -= 4294967296;
3876 cdouble += (NV)along;
3885 #if LONGSIZE != SIZE32
3889 COPYNN(s, &along, sizeof(long));
3892 sv_setiv(sv, (IV)along);
3893 PUSHs(sv_2mortal(sv));
3901 #if LONGSIZE > SIZE32
3902 if (along > 2147483647)
3903 along -= 4294967296;
3907 sv_setiv(sv, (IV)along);
3908 PUSHs(sv_2mortal(sv));
3916 #if LONGSIZE == SIZE32
3917 along = (strend - s) / SIZE32;
3919 unatint = natint && datumtype == 'L';
3920 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3925 #if LONGSIZE != SIZE32
3927 unsigned long aulong;
3929 COPYNN(s, &aulong, sizeof(unsigned long));
3930 s += sizeof(unsigned long);
3932 cdouble += (NV)aulong;
3944 if (datumtype == 'N')
3945 aulong = PerlSock_ntohl(aulong);
3948 if (datumtype == 'V')
3949 aulong = vtohl(aulong);
3952 cdouble += (NV)aulong;
3961 #if LONGSIZE != SIZE32
3963 unsigned long aulong;
3965 COPYNN(s, &aulong, sizeof(unsigned long));
3966 s += sizeof(unsigned long);
3968 sv_setuv(sv, (UV)aulong);
3969 PUSHs(sv_2mortal(sv));
3979 if (datumtype == 'N')
3980 aulong = PerlSock_ntohl(aulong);
3983 if (datumtype == 'V')
3984 aulong = vtohl(aulong);
3987 sv_setuv(sv, (UV)aulong);
3988 PUSHs(sv_2mortal(sv));
3994 along = (strend - s) / sizeof(char*);
4000 if (sizeof(char*) > strend - s)
4003 Copy(s, &aptr, 1, char*);
4009 PUSHs(sv_2mortal(sv));
4019 while ((len > 0) && (s < strend)) {
4020 auv = (auv << 7) | (*s & 0x7f);
4021 if (!(*s++ & 0x80)) {
4025 PUSHs(sv_2mortal(sv));
4029 else if (++bytes >= sizeof(UV)) { /* promote to string */
4033 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4034 while (s < strend) {
4035 sv = mul128(sv, *s & 0x7f);
4036 if (!(*s++ & 0x80)) {
4045 PUSHs(sv_2mortal(sv));
4050 if ((s >= strend) && bytes)
4051 DIE(aTHX_ "Unterminated compressed integer");
4056 if (sizeof(char*) > strend - s)
4059 Copy(s, &aptr, 1, char*);
4064 sv_setpvn(sv, aptr, len);
4065 PUSHs(sv_2mortal(sv));
4069 along = (strend - s) / sizeof(Quad_t);
4075 if (s + sizeof(Quad_t) > strend)
4078 Copy(s, &aquad, 1, Quad_t);
4079 s += sizeof(Quad_t);
4082 if (aquad >= IV_MIN && aquad <= IV_MAX)
4083 sv_setiv(sv, (IV)aquad);
4085 sv_setnv(sv, (NV)aquad);
4086 PUSHs(sv_2mortal(sv));
4090 along = (strend - s) / sizeof(Quad_t);
4096 if (s + sizeof(Uquad_t) > strend)
4099 Copy(s, &auquad, 1, Uquad_t);
4100 s += sizeof(Uquad_t);
4103 if (auquad <= UV_MAX)
4104 sv_setuv(sv, (UV)auquad);
4106 sv_setnv(sv, (NV)auquad);
4107 PUSHs(sv_2mortal(sv));
4111 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4114 along = (strend - s) / sizeof(float);
4119 Copy(s, &afloat, 1, float);
4128 Copy(s, &afloat, 1, float);
4131 sv_setnv(sv, (NV)afloat);
4132 PUSHs(sv_2mortal(sv));
4138 along = (strend - s) / sizeof(double);
4143 Copy(s, &adouble, 1, double);
4144 s += sizeof(double);
4152 Copy(s, &adouble, 1, double);
4153 s += sizeof(double);
4155 sv_setnv(sv, (NV)adouble);
4156 PUSHs(sv_2mortal(sv));
4162 * Initialise the decode mapping. By using a table driven
4163 * algorithm, the code will be character-set independent
4164 * (and just as fast as doing character arithmetic)
4166 if (PL_uudmap['M'] == 0) {
4169 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4170 PL_uudmap[(U8)PL_uuemap[i]] = i;
4172 * Because ' ' and '`' map to the same value,
4173 * we need to decode them both the same.
4178 along = (strend - s) * 3 / 4;
4179 sv = NEWSV(42, along);
4182 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4187 len = PL_uudmap[*(U8*)s++] & 077;
4189 if (s < strend && ISUUCHAR(*s))
4190 a = PL_uudmap[*(U8*)s++] & 077;
4193 if (s < strend && ISUUCHAR(*s))
4194 b = PL_uudmap[*(U8*)s++] & 077;
4197 if (s < strend && ISUUCHAR(*s))
4198 c = PL_uudmap[*(U8*)s++] & 077;
4201 if (s < strend && ISUUCHAR(*s))
4202 d = PL_uudmap[*(U8*)s++] & 077;
4205 hunk[0] = (a << 2) | (b >> 4);
4206 hunk[1] = (b << 4) | (c >> 2);
4207 hunk[2] = (c << 6) | d;
4208 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4213 else if (s[1] == '\n') /* possible checksum byte */
4216 XPUSHs(sv_2mortal(sv));
4221 if (strchr("fFdD", datumtype) ||
4222 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4226 while (checksum >= 16) {
4230 while (checksum >= 4) {
4236 along = (1 << checksum) - 1;
4237 while (cdouble < 0.0)
4239 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4240 sv_setnv(sv, cdouble);
4243 if (checksum < 32) {
4244 aulong = (1 << checksum) - 1;
4247 sv_setuv(sv, (UV)culong);
4249 XPUSHs(sv_2mortal(sv));
4253 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4254 PUSHs(&PL_sv_undef);
4259 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4263 *hunk = PL_uuemap[len];
4264 sv_catpvn(sv, hunk, 1);
4267 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4268 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4269 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4270 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4271 sv_catpvn(sv, hunk, 4);
4276 char r = (len > 1 ? s[1] : '\0');
4277 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4278 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4279 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4280 hunk[3] = PL_uuemap[0];
4281 sv_catpvn(sv, hunk, 4);
4283 sv_catpvn(sv, "\n", 1);
4287 S_is_an_int(pTHX_ char *s, STRLEN l)
4290 SV *result = newSVpvn(s, l);
4291 char *result_c = SvPV(result, n_a); /* convenience */
4292 char *out = result_c;
4302 SvREFCNT_dec(result);
4325 SvREFCNT_dec(result);
4331 SvCUR_set(result, out - result_c);
4335 /* pnum must be '\0' terminated */
4337 S_div128(pTHX_ SV *pnum, bool *done)
4340 char *s = SvPV(pnum, len);
4349 i = m * 10 + (*t - '0');
4351 r = (i >> 7); /* r < 10 */
4358 SvCUR_set(pnum, (STRLEN) (t - s));
4365 djSP; dMARK; dORIGMARK; dTARGET;
4366 register SV *cat = TARG;
4369 register char *pat = SvPVx(*++MARK, fromlen);
4370 register char *patend = pat + fromlen;
4375 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4376 static char *space10 = " ";
4378 /* These must not be in registers: */
4393 #ifdef PERL_NATINT_PACK
4394 int natint; /* native integer */
4399 sv_setpvn(cat, "", 0);
4400 while (pat < patend) {
4401 SV *lengthcode = Nullsv;
4402 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4403 datumtype = *pat++ & 0xFF;
4404 #ifdef PERL_NATINT_PACK
4407 if (isSPACE(datumtype))
4409 if (datumtype == '#') {
4410 while (pat < patend && *pat != '\n')
4415 char *natstr = "sSiIlL";
4417 if (strchr(natstr, datumtype)) {
4418 #ifdef PERL_NATINT_PACK
4424 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4427 len = strchr("@Xxu", datumtype) ? 0 : items;
4430 else if (isDIGIT(*pat)) {
4432 while (isDIGIT(*pat)) {
4433 len = (len * 10) + (*pat++ - '0');
4435 DIE(aTHX_ "Repeat count in pack overflows");
4442 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4443 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4444 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4445 ? *MARK : &PL_sv_no)
4446 + (*pat == 'Z' ? 1 : 0)));
4450 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4451 case ',': /* grandfather in commas but with a warning */
4452 if (commas++ == 0 && ckWARN(WARN_PACK))
4453 Perl_warner(aTHX_ WARN_PACK,
4454 "Invalid type in pack: '%c'", (int)datumtype);
4457 DIE(aTHX_ "%% may only be used in unpack");
4468 if (SvCUR(cat) < len)
4469 DIE(aTHX_ "X outside of string");
4476 sv_catpvn(cat, null10, 10);
4479 sv_catpvn(cat, null10, len);
4485 aptr = SvPV(fromstr, fromlen);
4486 if (pat[-1] == '*') {
4488 if (datumtype == 'Z')
4491 if (fromlen >= len) {
4492 sv_catpvn(cat, aptr, len);
4493 if (datumtype == 'Z')
4494 *(SvEND(cat)-1) = '\0';
4497 sv_catpvn(cat, aptr, fromlen);
4499 if (datumtype == 'A') {
4501 sv_catpvn(cat, space10, 10);
4504 sv_catpvn(cat, space10, len);
4508 sv_catpvn(cat, null10, 10);
4511 sv_catpvn(cat, null10, len);
4523 str = SvPV(fromstr, fromlen);
4527 SvCUR(cat) += (len+7)/8;
4528 SvGROW(cat, SvCUR(cat) + 1);
4529 aptr = SvPVX(cat) + aint;
4534 if (datumtype == 'B') {
4535 for (len = 0; len++ < aint;) {
4536 items |= *str++ & 1;
4540 *aptr++ = items & 0xff;
4546 for (len = 0; len++ < aint;) {
4552 *aptr++ = items & 0xff;
4558 if (datumtype == 'B')
4559 items <<= 7 - (aint & 7);
4561 items >>= 7 - (aint & 7);
4562 *aptr++ = items & 0xff;
4564 str = SvPVX(cat) + SvCUR(cat);
4579 str = SvPV(fromstr, fromlen);
4583 SvCUR(cat) += (len+1)/2;
4584 SvGROW(cat, SvCUR(cat) + 1);
4585 aptr = SvPVX(cat) + aint;
4590 if (datumtype == 'H') {
4591 for (len = 0; len++ < aint;) {
4593 items |= ((*str++ & 15) + 9) & 15;
4595 items |= *str++ & 15;
4599 *aptr++ = items & 0xff;
4605 for (len = 0; len++ < aint;) {
4607 items |= (((*str++ & 15) + 9) & 15) << 4;
4609 items |= (*str++ & 15) << 4;
4613 *aptr++ = items & 0xff;
4619 *aptr++ = items & 0xff;
4620 str = SvPVX(cat) + SvCUR(cat);
4631 aint = SvIV(fromstr);
4633 sv_catpvn(cat, &achar, sizeof(char));
4639 auint = SvUV(fromstr);
4640 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4641 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4646 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4651 afloat = (float)SvNV(fromstr);
4652 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4659 adouble = (double)SvNV(fromstr);
4660 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4666 ashort = (I16)SvIV(fromstr);
4668 ashort = PerlSock_htons(ashort);
4670 CAT16(cat, &ashort);
4676 ashort = (I16)SvIV(fromstr);
4678 ashort = htovs(ashort);
4680 CAT16(cat, &ashort);
4684 #if SHORTSIZE != SIZE16
4686 unsigned short aushort;
4690 aushort = SvUV(fromstr);
4691 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4701 aushort = (U16)SvUV(fromstr);
4702 CAT16(cat, &aushort);
4708 #if SHORTSIZE != SIZE16
4714 ashort = SvIV(fromstr);
4715 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4723 ashort = (I16)SvIV(fromstr);
4724 CAT16(cat, &ashort);
4731 auint = SvUV(fromstr);
4732 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4738 adouble = Perl_floor(SvNV(fromstr));
4741 DIE(aTHX_ "Cannot compress negative numbers");
4744 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4745 adouble <= 0xffffffff
4747 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4748 adouble <= UV_MAX_cxux
4755 char buf[1 + sizeof(UV)];
4756 char *in = buf + sizeof(buf);
4757 UV auv = U_V(adouble);
4760 *--in = (auv & 0x7f) | 0x80;
4763 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4764 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4766 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4767 char *from, *result, *in;
4772 /* Copy string and check for compliance */
4773 from = SvPV(fromstr, len);
4774 if ((norm = is_an_int(from, len)) == NULL)
4775 DIE(aTHX_ "can compress only unsigned integer");
4777 New('w', result, len, char);
4781 *--in = div128(norm, &done) | 0x80;
4782 result[len - 1] &= 0x7F; /* clear continue bit */
4783 sv_catpvn(cat, in, (result + len) - in);
4785 SvREFCNT_dec(norm); /* free norm */
4787 else if (SvNOKp(fromstr)) {
4788 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4789 char *in = buf + sizeof(buf);
4792 double next = floor(adouble / 128);
4793 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4794 if (--in < buf) /* this cannot happen ;-) */
4795 DIE(aTHX_ "Cannot compress integer");
4797 } while (adouble > 0);
4798 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4799 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4802 DIE(aTHX_ "Cannot compress non integer");
4808 aint = SvIV(fromstr);
4809 sv_catpvn(cat, (char*)&aint, sizeof(int));
4815 aulong = SvUV(fromstr);
4817 aulong = PerlSock_htonl(aulong);
4819 CAT32(cat, &aulong);
4825 aulong = SvUV(fromstr);
4827 aulong = htovl(aulong);
4829 CAT32(cat, &aulong);
4833 #if LONGSIZE != SIZE32
4835 unsigned long aulong;
4839 aulong = SvUV(fromstr);
4840 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4848 aulong = SvUV(fromstr);
4849 CAT32(cat, &aulong);
4854 #if LONGSIZE != SIZE32
4860 along = SvIV(fromstr);
4861 sv_catpvn(cat, (char *)&along, sizeof(long));
4869 along = SvIV(fromstr);
4878 auquad = (Uquad_t)SvUV(fromstr);
4879 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4885 aquad = (Quad_t)SvIV(fromstr);
4886 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4891 len = 1; /* assume SV is correct length */
4896 if (fromstr == &PL_sv_undef)
4900 /* XXX better yet, could spirit away the string to
4901 * a safe spot and hang on to it until the result
4902 * of pack() (and all copies of the result) are
4905 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4906 || (SvPADTMP(fromstr)
4907 && !SvREADONLY(fromstr))))
4909 Perl_warner(aTHX_ WARN_PACK,
4910 "Attempt to pack pointer to temporary value");
4912 if (SvPOK(fromstr) || SvNIOK(fromstr))
4913 aptr = SvPV(fromstr,n_a);
4915 aptr = SvPV_force(fromstr,n_a);
4917 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4922 aptr = SvPV(fromstr, fromlen);
4923 SvGROW(cat, fromlen * 4 / 3);
4928 while (fromlen > 0) {
4935 doencodes(cat, aptr, todo);
4954 register I32 limit = POPi; /* note, negative is forever */
4957 register char *s = SvPV(sv, len);
4958 char *strend = s + len;
4960 register REGEXP *rx;
4964 I32 maxiters = (strend - s) + 10;
4967 I32 origlimit = limit;
4970 AV *oldstack = PL_curstack;
4971 I32 gimme = GIMME_V;
4972 I32 oldsave = PL_savestack_ix;
4973 I32 make_mortal = 1;
4974 MAGIC *mg = (MAGIC *) NULL;
4977 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4982 DIE(aTHX_ "panic: do_split");
4983 rx = pm->op_pmregexp;
4985 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4986 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4988 if (pm->op_pmreplroot) {
4990 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4992 ary = GvAVn((GV*)pm->op_pmreplroot);
4995 else if (gimme != G_ARRAY)
4997 ary = (AV*)PL_curpad[0];
4999 ary = GvAVn(PL_defgv);
5000 #endif /* USE_THREADS */
5003 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5009 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5011 XPUSHs(SvTIED_obj((SV*)ary, mg));
5017 for (i = AvFILLp(ary); i >= 0; i--)
5018 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5020 /* temporarily switch stacks */
5021 SWITCHSTACK(PL_curstack, ary);
5025 base = SP - PL_stack_base;
5027 if (pm->op_pmflags & PMf_SKIPWHITE) {
5028 if (pm->op_pmflags & PMf_LOCALE) {
5029 while (isSPACE_LC(*s))
5037 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5038 SAVEINT(PL_multiline);
5039 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5043 limit = maxiters + 2;
5044 if (pm->op_pmflags & PMf_WHITE) {
5047 while (m < strend &&
5048 !((pm->op_pmflags & PMf_LOCALE)
5049 ? isSPACE_LC(*m) : isSPACE(*m)))
5054 dstr = NEWSV(30, m-s);
5055 sv_setpvn(dstr, s, m-s);
5061 while (s < strend &&
5062 ((pm->op_pmflags & PMf_LOCALE)
5063 ? isSPACE_LC(*s) : isSPACE(*s)))
5067 else if (strEQ("^", rx->precomp)) {
5070 for (m = s; m < strend && *m != '\n'; m++) ;
5074 dstr = NEWSV(30, m-s);
5075 sv_setpvn(dstr, s, m-s);
5082 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5083 && (rx->reganch & ROPT_CHECK_ALL)
5084 && !(rx->reganch & ROPT_ANCH)) {
5085 int tail = (rx->reganch & RE_INTUIT_TAIL);
5086 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5090 if (len == 1 && !tail) {
5094 for (m = s; m < strend && *m != c; m++) ;
5097 dstr = NEWSV(30, m-s);
5098 sv_setpvn(dstr, s, m-s);
5107 while (s < strend && --limit &&
5108 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5109 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5112 dstr = NEWSV(31, m-s);
5113 sv_setpvn(dstr, s, m-s);
5117 s = m + len; /* Fake \n at the end */
5122 maxiters += (strend - s) * rx->nparens;
5123 while (s < strend && --limit
5124 /* && (!rx->check_substr
5125 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5127 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5128 1 /* minend */, sv, NULL, 0))
5130 TAINT_IF(RX_MATCH_TAINTED(rx));
5131 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5136 strend = s + (strend - m);
5138 m = rx->startp[0] + orig;
5139 dstr = NEWSV(32, m-s);
5140 sv_setpvn(dstr, s, m-s);
5145 for (i = 1; i <= rx->nparens; i++) {
5146 s = rx->startp[i] + orig;
5147 m = rx->endp[i] + orig;
5149 dstr = NEWSV(33, m-s);
5150 sv_setpvn(dstr, s, m-s);
5153 dstr = NEWSV(33, 0);
5159 s = rx->endp[0] + orig;
5163 LEAVE_SCOPE(oldsave);
5164 iters = (SP - PL_stack_base) - base;
5165 if (iters > maxiters)
5166 DIE(aTHX_ "Split loop");
5168 /* keep field after final delim? */
5169 if (s < strend || (iters && origlimit)) {
5170 dstr = NEWSV(34, strend-s);
5171 sv_setpvn(dstr, s, strend-s);
5177 else if (!origlimit) {
5178 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5184 SWITCHSTACK(ary, oldstack);
5185 if (SvSMAGICAL(ary)) {
5190 if (gimme == G_ARRAY) {
5192 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5200 call_method("PUSH",G_SCALAR|G_DISCARD);
5203 if (gimme == G_ARRAY) {
5204 /* EXTEND should not be needed - we just popped them */
5206 for (i=0; i < iters; i++) {
5207 SV **svp = av_fetch(ary, i, FALSE);
5208 PUSHs((svp) ? *svp : &PL_sv_undef);
5215 if (gimme == G_ARRAY)
5218 if (iters || !pm->op_pmreplroot) {
5228 Perl_unlock_condpair(pTHX_ void *svv)
5231 MAGIC *mg = mg_find((SV*)svv, 'm');
5234 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5235 MUTEX_LOCK(MgMUTEXP(mg));
5236 if (MgOWNER(mg) != thr)
5237 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5239 COND_SIGNAL(MgOWNERCONDP(mg));
5240 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5241 PTR2UV(thr), PTR2UV(svv));)
5242 MUTEX_UNLOCK(MgMUTEXP(mg));
5244 #endif /* USE_THREADS */
5257 mg = condpair_magic(sv);
5258 MUTEX_LOCK(MgMUTEXP(mg));
5259 if (MgOWNER(mg) == thr)
5260 MUTEX_UNLOCK(MgMUTEXP(mg));
5263 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5265 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5266 PTR2UV(thr), PTR2UV(sv));)
5267 MUTEX_UNLOCK(MgMUTEXP(mg));
5268 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5270 #endif /* USE_THREADS */
5271 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5272 || SvTYPE(retsv) == SVt_PVCV) {
5273 retsv = refto(retsv);
5284 if (PL_op->op_private & OPpLVAL_INTRO)
5285 PUSHs(*save_threadsv(PL_op->op_targ));
5287 PUSHs(THREADSV(PL_op->op_targ));
5290 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5291 #endif /* USE_THREADS */