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 argtype = 1; /* allow underscores */
1889 XPUSHn(scan_hex(tmps, 99, &argtype));
1902 while (*tmps && isSPACE(*tmps))
1906 argtype = 1; /* allow underscores */
1908 value = scan_hex(++tmps, 99, &argtype);
1909 else if (*tmps == 'b')
1910 value = scan_bin(++tmps, 99, &argtype);
1912 value = scan_oct(tmps, 99, &argtype);
1925 SETi(sv_len_utf8(sv));
1941 I32 lvalue = PL_op->op_flags & OPf_MOD;
1943 I32 arybase = PL_curcop->cop_arybase;
1947 SvTAINTED_off(TARG); /* decontaminate */
1948 SvUTF8_off(TARG); /* decontaminate */
1952 repl = SvPV(sv, repl_len);
1959 tmps = SvPV(sv, curlen);
1961 utfcurlen = sv_len_utf8(sv);
1962 if (utfcurlen == curlen)
1970 if (pos >= arybase) {
1988 else if (len >= 0) {
1990 if (rem > (I32)curlen)
2005 Perl_croak(aTHX_ "substr outside of string");
2006 if (ckWARN(WARN_SUBSTR))
2007 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2012 sv_pos_u2b(sv, &pos, &rem);
2016 sv_setpvn(TARG, tmps, rem);
2018 sv_insert(sv, pos, rem, repl, repl_len);
2019 else if (lvalue) { /* it's an lvalue! */
2020 if (!SvGMAGICAL(sv)) {
2024 if (ckWARN(WARN_SUBSTR))
2025 Perl_warner(aTHX_ WARN_SUBSTR,
2026 "Attempt to use reference as lvalue in substr");
2028 if (SvOK(sv)) /* is it defined ? */
2029 (void)SvPOK_only(sv);
2031 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2034 if (SvTYPE(TARG) < SVt_PVLV) {
2035 sv_upgrade(TARG, SVt_PVLV);
2036 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2040 if (LvTARG(TARG) != sv) {
2042 SvREFCNT_dec(LvTARG(TARG));
2043 LvTARG(TARG) = SvREFCNT_inc(sv);
2045 LvTARGOFF(TARG) = pos;
2046 LvTARGLEN(TARG) = rem;
2050 PUSHs(TARG); /* avoid SvSETMAGIC here */
2057 register I32 size = POPi;
2058 register I32 offset = POPi;
2059 register SV *src = POPs;
2060 I32 lvalue = PL_op->op_flags & OPf_MOD;
2062 SvTAINTED_off(TARG); /* decontaminate */
2063 if (lvalue) { /* it's an lvalue! */
2064 if (SvTYPE(TARG) < SVt_PVLV) {
2065 sv_upgrade(TARG, SVt_PVLV);
2066 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2069 if (LvTARG(TARG) != src) {
2071 SvREFCNT_dec(LvTARG(TARG));
2072 LvTARG(TARG) = SvREFCNT_inc(src);
2074 LvTARGOFF(TARG) = offset;
2075 LvTARGLEN(TARG) = size;
2078 sv_setuv(TARG, do_vecget(src, offset, size));
2093 I32 arybase = PL_curcop->cop_arybase;
2098 offset = POPi - arybase;
2101 tmps = SvPV(big, biglen);
2102 if (offset > 0 && DO_UTF8(big))
2103 sv_pos_u2b(big, &offset, 0);
2106 else if (offset > biglen)
2108 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2109 (unsigned char*)tmps + biglen, little, 0)))
2112 retval = tmps2 - tmps;
2113 if (retval > 0 && DO_UTF8(big))
2114 sv_pos_b2u(big, &retval);
2115 PUSHi(retval + arybase);
2130 I32 arybase = PL_curcop->cop_arybase;
2136 tmps2 = SvPV(little, llen);
2137 tmps = SvPV(big, blen);
2141 if (offset > 0 && DO_UTF8(big))
2142 sv_pos_u2b(big, &offset, 0);
2143 offset = offset - arybase + llen;
2147 else if (offset > blen)
2149 if (!(tmps2 = rninstr(tmps, tmps + offset,
2150 tmps2, tmps2 + llen)))
2153 retval = tmps2 - tmps;
2154 if (retval > 0 && DO_UTF8(big))
2155 sv_pos_b2u(big, &retval);
2156 PUSHi(retval + arybase);
2162 djSP; dMARK; dORIGMARK; dTARGET;
2163 do_sprintf(TARG, SP-MARK, MARK+1);
2164 TAINT_IF(SvTAINTED(TARG));
2176 U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
2179 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2180 value = utf8_to_uv(tmps, &retlen);
2182 value = (UV)(*tmps & 255);
2193 (void)SvUPGRADE(TARG,SVt_PV);
2195 if (value > 255 && !IN_BYTE) {
2196 SvGROW(TARG, UTF8_MAXLEN+1);
2198 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2199 SvCUR_set(TARG, tmps - SvPVX(TARG));
2201 (void)SvPOK_only(TARG);
2212 SvUTF8_off(TARG); /* decontaminate */
2213 (void)SvPOK_only(TARG);
2220 djSP; dTARGET; dPOPTOPssrl;
2223 char *tmps = SvPV(left, n_a);
2225 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2227 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2231 "The crypt() function is unimplemented due to excessive paranoia.");
2244 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2246 U8 tmpbuf[UTF8_MAXLEN];
2248 UV uv = utf8_to_uv(s, &ulen);
2250 if (PL_op->op_private & OPpLOCALE) {
2253 uv = toTITLE_LC_uni(uv);
2256 uv = toTITLE_utf8(s);
2258 tend = uv_to_utf8(tmpbuf, uv);
2260 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2262 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2263 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2268 s = (U8*)SvPV_force(sv, slen);
2269 Copy(tmpbuf, s, ulen, U8);
2273 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2275 SvUTF8_off(TARG); /* decontaminate */
2280 s = (U8*)SvPV_force(sv, slen);
2282 if (PL_op->op_private & OPpLOCALE) {
2285 *s = toUPPER_LC(*s);
2303 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2305 U8 tmpbuf[UTF8_MAXLEN];
2307 UV uv = utf8_to_uv(s, &ulen);
2309 if (PL_op->op_private & OPpLOCALE) {
2312 uv = toLOWER_LC_uni(uv);
2315 uv = toLOWER_utf8(s);
2317 tend = uv_to_utf8(tmpbuf, uv);
2319 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2321 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2322 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2327 s = (U8*)SvPV_force(sv, slen);
2328 Copy(tmpbuf, s, ulen, U8);
2332 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2334 SvUTF8_off(TARG); /* decontaminate */
2339 s = (U8*)SvPV_force(sv, slen);
2341 if (PL_op->op_private & OPpLOCALE) {
2344 *s = toLOWER_LC(*s);
2368 s = (U8*)SvPV(sv,len);
2370 SvUTF8_off(TARG); /* decontaminate */
2371 sv_setpvn(TARG, "", 0);
2375 (void)SvUPGRADE(TARG, SVt_PV);
2376 SvGROW(TARG, (len * 2) + 1);
2377 (void)SvPOK_only(TARG);
2378 d = (U8*)SvPVX(TARG);
2380 if (PL_op->op_private & OPpLOCALE) {
2384 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2390 d = uv_to_utf8(d, toUPPER_utf8( s ));
2396 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2401 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2403 SvUTF8_off(TARG); /* decontaminate */
2408 s = (U8*)SvPV_force(sv, len);
2410 register U8 *send = s + len;
2412 if (PL_op->op_private & OPpLOCALE) {
2415 for (; s < send; s++)
2416 *s = toUPPER_LC(*s);
2419 for (; s < send; s++)
2442 s = (U8*)SvPV(sv,len);
2444 SvUTF8_off(TARG); /* decontaminate */
2445 sv_setpvn(TARG, "", 0);
2449 (void)SvUPGRADE(TARG, SVt_PV);
2450 SvGROW(TARG, (len * 2) + 1);
2451 (void)SvPOK_only(TARG);
2452 d = (U8*)SvPVX(TARG);
2454 if (PL_op->op_private & OPpLOCALE) {
2458 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2464 d = uv_to_utf8(d, toLOWER_utf8(s));
2470 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2475 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2477 SvUTF8_off(TARG); /* decontaminate */
2483 s = (U8*)SvPV_force(sv, len);
2485 register U8 *send = s + len;
2487 if (PL_op->op_private & OPpLOCALE) {
2490 for (; s < send; s++)
2491 *s = toLOWER_LC(*s);
2494 for (; s < send; s++)
2509 register char *s = SvPV(sv,len);
2512 SvUTF8_off(TARG); /* decontaminate */
2514 (void)SvUPGRADE(TARG, SVt_PV);
2515 SvGROW(TARG, (len * 2) + 1);
2520 STRLEN ulen = UTF8SKIP(s);
2544 SvCUR_set(TARG, d - SvPVX(TARG));
2545 (void)SvPOK_only(TARG);
2548 sv_setpvn(TARG, s, len);
2550 if (SvSMAGICAL(TARG))
2559 djSP; dMARK; dORIGMARK;
2561 register AV* av = (AV*)POPs;
2562 register I32 lval = PL_op->op_flags & OPf_MOD;
2563 I32 arybase = PL_curcop->cop_arybase;
2566 if (SvTYPE(av) == SVt_PVAV) {
2567 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2569 for (svp = MARK + 1; svp <= SP; svp++) {
2574 if (max > AvMAX(av))
2577 while (++MARK <= SP) {
2578 elem = SvIVx(*MARK);
2582 svp = av_fetch(av, elem, lval);
2584 if (!svp || *svp == &PL_sv_undef)
2585 DIE(aTHX_ PL_no_aelem, elem);
2586 if (PL_op->op_private & OPpLVAL_INTRO)
2587 save_aelem(av, elem, svp);
2589 *MARK = svp ? *svp : &PL_sv_undef;
2592 if (GIMME != G_ARRAY) {
2600 /* Associative arrays. */
2605 HV *hash = (HV*)POPs;
2607 I32 gimme = GIMME_V;
2608 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2611 /* might clobber stack_sp */
2612 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2617 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2618 if (gimme == G_ARRAY) {
2621 /* might clobber stack_sp */
2623 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2628 else if (gimme == G_SCALAR)
2647 I32 gimme = GIMME_V;
2648 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2652 if (PL_op->op_private & OPpSLICE) {
2656 hvtype = SvTYPE(hv);
2657 if (hvtype == SVt_PVHV) { /* hash element */
2658 while (++MARK <= SP) {
2659 sv = hv_delete_ent(hv, *MARK, discard, 0);
2660 *MARK = sv ? sv : &PL_sv_undef;
2663 else if (hvtype == SVt_PVAV) {
2664 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2665 while (++MARK <= SP) {
2666 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2667 *MARK = sv ? sv : &PL_sv_undef;
2670 else { /* pseudo-hash element */
2671 while (++MARK <= SP) {
2672 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2673 *MARK = sv ? sv : &PL_sv_undef;
2678 DIE(aTHX_ "Not a HASH reference");
2681 else if (gimme == G_SCALAR) {
2690 if (SvTYPE(hv) == SVt_PVHV)
2691 sv = hv_delete_ent(hv, keysv, discard, 0);
2692 else if (SvTYPE(hv) == SVt_PVAV) {
2693 if (PL_op->op_flags & OPf_SPECIAL)
2694 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2696 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2699 DIE(aTHX_ "Not a HASH reference");
2714 if (PL_op->op_private & OPpEXISTS_SUB) {
2718 cv = sv_2cv(sv, &hv, &gv, FALSE);
2721 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2727 if (SvTYPE(hv) == SVt_PVHV) {
2728 if (hv_exists_ent(hv, tmpsv, 0))
2731 else if (SvTYPE(hv) == SVt_PVAV) {
2732 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2733 if (av_exists((AV*)hv, SvIV(tmpsv)))
2736 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2740 DIE(aTHX_ "Not a HASH reference");
2747 djSP; dMARK; dORIGMARK;
2748 register HV *hv = (HV*)POPs;
2749 register I32 lval = PL_op->op_flags & OPf_MOD;
2750 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2752 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2753 DIE(aTHX_ "Can't localize pseudo-hash element");
2755 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2756 while (++MARK <= SP) {
2760 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2761 svp = he ? &HeVAL(he) : 0;
2764 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2767 if (!svp || *svp == &PL_sv_undef) {
2769 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2771 if (PL_op->op_private & OPpLVAL_INTRO)
2772 save_helem(hv, keysv, svp);
2774 *MARK = svp ? *svp : &PL_sv_undef;
2777 if (GIMME != G_ARRAY) {
2785 /* List operators. */
2790 if (GIMME != G_ARRAY) {
2792 *MARK = *SP; /* unwanted list, return last item */
2794 *MARK = &PL_sv_undef;
2803 SV **lastrelem = PL_stack_sp;
2804 SV **lastlelem = PL_stack_base + POPMARK;
2805 SV **firstlelem = PL_stack_base + POPMARK + 1;
2806 register SV **firstrelem = lastlelem + 1;
2807 I32 arybase = PL_curcop->cop_arybase;
2808 I32 lval = PL_op->op_flags & OPf_MOD;
2809 I32 is_something_there = lval;
2811 register I32 max = lastrelem - lastlelem;
2812 register SV **lelem;
2815 if (GIMME != G_ARRAY) {
2816 ix = SvIVx(*lastlelem);
2821 if (ix < 0 || ix >= max)
2822 *firstlelem = &PL_sv_undef;
2824 *firstlelem = firstrelem[ix];
2830 SP = firstlelem - 1;
2834 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2840 if (ix < 0 || ix >= max)
2841 *lelem = &PL_sv_undef;
2843 is_something_there = TRUE;
2844 if (!(*lelem = firstrelem[ix]))
2845 *lelem = &PL_sv_undef;
2848 if (is_something_there)
2851 SP = firstlelem - 1;
2857 djSP; dMARK; dORIGMARK;
2858 I32 items = SP - MARK;
2859 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2860 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2867 djSP; dMARK; dORIGMARK;
2868 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2872 SV *val = NEWSV(46, 0);
2874 sv_setsv(val, *++MARK);
2875 else if (ckWARN(WARN_MISC))
2876 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2877 (void)hv_store_ent(hv,key,val,0);
2886 djSP; dMARK; dORIGMARK;
2887 register AV *ary = (AV*)*++MARK;
2891 register I32 offset;
2892 register I32 length;
2899 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2900 *MARK-- = SvTIED_obj((SV*)ary, mg);
2904 call_method("SPLICE",GIMME_V);
2913 offset = i = SvIVx(*MARK);
2915 offset += AvFILLp(ary) + 1;
2917 offset -= PL_curcop->cop_arybase;
2919 DIE(aTHX_ PL_no_aelem, i);
2921 length = SvIVx(*MARK++);
2923 length += AvFILLp(ary) - offset + 1;
2929 length = AvMAX(ary) + 1; /* close enough to infinity */
2933 length = AvMAX(ary) + 1;
2935 if (offset > AvFILLp(ary) + 1)
2936 offset = AvFILLp(ary) + 1;
2937 after = AvFILLp(ary) + 1 - (offset + length);
2938 if (after < 0) { /* not that much array */
2939 length += after; /* offset+length now in array */
2945 /* At this point, MARK .. SP-1 is our new LIST */
2948 diff = newlen - length;
2949 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2952 if (diff < 0) { /* shrinking the area */
2954 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2955 Copy(MARK, tmparyval, newlen, SV*);
2958 MARK = ORIGMARK + 1;
2959 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2960 MEXTEND(MARK, length);
2961 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2963 EXTEND_MORTAL(length);
2964 for (i = length, dst = MARK; i; i--) {
2965 sv_2mortal(*dst); /* free them eventualy */
2972 *MARK = AvARRAY(ary)[offset+length-1];
2975 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2976 SvREFCNT_dec(*dst++); /* free them now */
2979 AvFILLp(ary) += diff;
2981 /* pull up or down? */
2983 if (offset < after) { /* easier to pull up */
2984 if (offset) { /* esp. if nothing to pull */
2985 src = &AvARRAY(ary)[offset-1];
2986 dst = src - diff; /* diff is negative */
2987 for (i = offset; i > 0; i--) /* can't trust Copy */
2991 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2995 if (after) { /* anything to pull down? */
2996 src = AvARRAY(ary) + offset + length;
2997 dst = src + diff; /* diff is negative */
2998 Move(src, dst, after, SV*);
3000 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3001 /* avoid later double free */
3005 dst[--i] = &PL_sv_undef;
3008 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3010 *dst = NEWSV(46, 0);
3011 sv_setsv(*dst++, *src++);
3013 Safefree(tmparyval);
3016 else { /* no, expanding (or same) */
3018 New(452, tmparyval, length, SV*); /* so remember deletion */
3019 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3022 if (diff > 0) { /* expanding */
3024 /* push up or down? */
3026 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3030 Move(src, dst, offset, SV*);
3032 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3034 AvFILLp(ary) += diff;
3037 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3038 av_extend(ary, AvFILLp(ary) + diff);
3039 AvFILLp(ary) += diff;
3042 dst = AvARRAY(ary) + AvFILLp(ary);
3044 for (i = after; i; i--) {
3051 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3052 *dst = NEWSV(46, 0);
3053 sv_setsv(*dst++, *src++);
3055 MARK = ORIGMARK + 1;
3056 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3058 Copy(tmparyval, MARK, length, SV*);
3060 EXTEND_MORTAL(length);
3061 for (i = length, dst = MARK; i; i--) {
3062 sv_2mortal(*dst); /* free them eventualy */
3066 Safefree(tmparyval);
3070 else if (length--) {
3071 *MARK = tmparyval[length];
3074 while (length-- > 0)
3075 SvREFCNT_dec(tmparyval[length]);
3077 Safefree(tmparyval);
3080 *MARK = &PL_sv_undef;
3088 djSP; dMARK; dORIGMARK; dTARGET;
3089 register AV *ary = (AV*)*++MARK;
3090 register SV *sv = &PL_sv_undef;
3093 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3094 *MARK-- = SvTIED_obj((SV*)ary, mg);
3098 call_method("PUSH",G_SCALAR|G_DISCARD);
3103 /* Why no pre-extend of ary here ? */
3104 for (++MARK; MARK <= SP; MARK++) {
3107 sv_setsv(sv, *MARK);
3112 PUSHi( AvFILL(ary) + 1 );
3120 SV *sv = av_pop(av);
3122 (void)sv_2mortal(sv);
3131 SV *sv = av_shift(av);
3136 (void)sv_2mortal(sv);
3143 djSP; dMARK; dORIGMARK; dTARGET;
3144 register AV *ary = (AV*)*++MARK;
3149 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3150 *MARK-- = SvTIED_obj((SV*)ary, mg);
3154 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3159 av_unshift(ary, SP - MARK);
3162 sv_setsv(sv, *++MARK);
3163 (void)av_store(ary, i++, sv);
3167 PUSHi( AvFILL(ary) + 1 );
3177 if (GIMME == G_ARRAY) {
3184 /* safe as long as stack cannot get extended in the above */
3189 register char *down;
3194 SvUTF8_off(TARG); /* decontaminate */
3196 do_join(TARG, &PL_sv_no, MARK, SP);
3198 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3199 up = SvPV_force(TARG, len);
3201 if (DO_UTF8(TARG)) { /* first reverse each character */
3202 U8* s = (U8*)SvPVX(TARG);
3203 U8* send = (U8*)(s + len);
3212 down = (char*)(s - 1);
3213 if (s > send || !((*down & 0xc0) == 0x80)) {
3214 if (ckWARN_d(WARN_UTF8))
3215 Perl_warner(aTHX_ WARN_UTF8,
3216 "Malformed UTF-8 character");
3228 down = SvPVX(TARG) + len - 1;
3234 (void)SvPOK_only(TARG);
3243 S_mul128(pTHX_ SV *sv, U8 m)
3246 char *s = SvPV(sv, len);
3250 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3251 SV *tmpNew = newSVpvn("0000000000", 10);
3253 sv_catsv(tmpNew, sv);
3254 SvREFCNT_dec(sv); /* free old sv */
3259 while (!*t) /* trailing '\0'? */
3262 i = ((*t - '0') << 7) + m;
3263 *(t--) = '0' + (i % 10);
3269 /* Explosives and implosives. */
3271 #if 'I' == 73 && 'J' == 74
3272 /* On an ASCII/ISO kind of system */
3273 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3276 Some other sort of character set - use memchr() so we don't match
3279 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3286 I32 start_sp_offset = SP - PL_stack_base;
3287 I32 gimme = GIMME_V;
3291 register char *pat = SvPV(left, llen);
3292 register char *s = SvPV(right, rlen);
3293 char *strend = s + rlen;
3295 register char *patend = pat + llen;
3301 /* These must not be in registers: */
3318 register U32 culong;
3322 #ifdef PERL_NATINT_PACK
3323 int natint; /* native integer */
3324 int unatint; /* unsigned native integer */
3327 if (gimme != G_ARRAY) { /* arrange to do first one only */
3329 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3330 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3332 while (isDIGIT(*patend) || *patend == '*')
3338 while (pat < patend) {
3340 datumtype = *pat++ & 0xFF;
3341 #ifdef PERL_NATINT_PACK
3344 if (isSPACE(datumtype))
3346 if (datumtype == '#') {
3347 while (pat < patend && *pat != '\n')
3352 char *natstr = "sSiIlL";
3354 if (strchr(natstr, datumtype)) {
3355 #ifdef PERL_NATINT_PACK
3361 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3366 else if (*pat == '*') {
3367 len = strend - strbeg; /* long enough */
3371 else if (isDIGIT(*pat)) {
3373 while (isDIGIT(*pat)) {
3374 len = (len * 10) + (*pat++ - '0');
3376 DIE(aTHX_ "Repeat count in unpack overflows");
3380 len = (datumtype != '@');
3384 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3385 case ',': /* grandfather in commas but with a warning */
3386 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3387 Perl_warner(aTHX_ WARN_UNPACK,
3388 "Invalid type in unpack: '%c'", (int)datumtype);
3391 if (len == 1 && pat[-1] != '1')
3400 if (len > strend - strbeg)
3401 DIE(aTHX_ "@ outside of string");
3405 if (len > s - strbeg)
3406 DIE(aTHX_ "X outside of string");
3410 if (len > strend - s)
3411 DIE(aTHX_ "x outside of string");
3415 if (start_sp_offset >= SP - PL_stack_base)
3416 DIE(aTHX_ "/ must follow a numeric type");
3419 pat++; /* ignore '*' for compatibility with pack */
3421 DIE(aTHX_ "/ cannot take a count" );
3428 if (len > strend - s)
3431 goto uchar_checksum;
3432 sv = NEWSV(35, len);
3433 sv_setpvn(sv, s, len);
3435 if (datumtype == 'A' || datumtype == 'Z') {
3436 aptr = s; /* borrow register */
3437 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3442 else { /* 'A' strips both nulls and spaces */
3443 s = SvPVX(sv) + len - 1;
3444 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3448 SvCUR_set(sv, s - SvPVX(sv));
3449 s = aptr; /* unborrow register */
3451 XPUSHs(sv_2mortal(sv));
3455 if (star || len > (strend - s) * 8)
3456 len = (strend - s) * 8;
3459 Newz(601, PL_bitcount, 256, char);
3460 for (bits = 1; bits < 256; bits++) {
3461 if (bits & 1) PL_bitcount[bits]++;
3462 if (bits & 2) PL_bitcount[bits]++;
3463 if (bits & 4) PL_bitcount[bits]++;
3464 if (bits & 8) PL_bitcount[bits]++;
3465 if (bits & 16) PL_bitcount[bits]++;
3466 if (bits & 32) PL_bitcount[bits]++;
3467 if (bits & 64) PL_bitcount[bits]++;
3468 if (bits & 128) PL_bitcount[bits]++;
3472 culong += PL_bitcount[*(unsigned char*)s++];
3477 if (datumtype == 'b') {
3479 if (bits & 1) culong++;
3485 if (bits & 128) culong++;
3492 sv = NEWSV(35, len + 1);
3496 if (datumtype == 'b') {
3498 for (len = 0; len < aint; len++) {
3499 if (len & 7) /*SUPPRESS 595*/
3503 *str++ = '0' + (bits & 1);
3508 for (len = 0; len < aint; len++) {
3513 *str++ = '0' + ((bits & 128) != 0);
3517 XPUSHs(sv_2mortal(sv));
3521 if (star || len > (strend - s) * 2)
3522 len = (strend - s) * 2;
3523 sv = NEWSV(35, len + 1);
3527 if (datumtype == 'h') {
3529 for (len = 0; len < aint; len++) {
3534 *str++ = PL_hexdigit[bits & 15];
3539 for (len = 0; len < aint; len++) {
3544 *str++ = PL_hexdigit[(bits >> 4) & 15];
3548 XPUSHs(sv_2mortal(sv));
3551 if (len > strend - s)
3556 if (aint >= 128) /* fake up signed chars */
3566 if (aint >= 128) /* fake up signed chars */
3569 sv_setiv(sv, (IV)aint);
3570 PUSHs(sv_2mortal(sv));
3575 if (len > strend - s)
3590 sv_setiv(sv, (IV)auint);
3591 PUSHs(sv_2mortal(sv));
3596 if (len > strend - s)
3599 while (len-- > 0 && s < strend) {
3600 auint = utf8_to_uv((U8*)s, &along);
3603 cdouble += (NV)auint;
3611 while (len-- > 0 && s < strend) {
3612 auint = utf8_to_uv((U8*)s, &along);
3615 sv_setuv(sv, (UV)auint);
3616 PUSHs(sv_2mortal(sv));
3621 #if SHORTSIZE == SIZE16
3622 along = (strend - s) / SIZE16;
3624 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3629 #if SHORTSIZE != SIZE16
3633 COPYNN(s, &ashort, sizeof(short));
3644 #if SHORTSIZE > SIZE16
3656 #if SHORTSIZE != SIZE16
3660 COPYNN(s, &ashort, sizeof(short));
3663 sv_setiv(sv, (IV)ashort);
3664 PUSHs(sv_2mortal(sv));
3672 #if SHORTSIZE > SIZE16
3678 sv_setiv(sv, (IV)ashort);
3679 PUSHs(sv_2mortal(sv));
3687 #if SHORTSIZE == SIZE16
3688 along = (strend - s) / SIZE16;
3690 unatint = natint && datumtype == 'S';
3691 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3696 #if SHORTSIZE != SIZE16
3698 unsigned short aushort;
3700 COPYNN(s, &aushort, sizeof(unsigned short));
3701 s += sizeof(unsigned short);
3709 COPY16(s, &aushort);
3712 if (datumtype == 'n')
3713 aushort = PerlSock_ntohs(aushort);
3716 if (datumtype == 'v')
3717 aushort = vtohs(aushort);
3726 #if SHORTSIZE != SIZE16
3728 unsigned short aushort;
3730 COPYNN(s, &aushort, sizeof(unsigned short));
3731 s += sizeof(unsigned short);
3733 sv_setiv(sv, (UV)aushort);
3734 PUSHs(sv_2mortal(sv));
3741 COPY16(s, &aushort);
3745 if (datumtype == 'n')
3746 aushort = PerlSock_ntohs(aushort);
3749 if (datumtype == 'v')
3750 aushort = vtohs(aushort);
3752 sv_setiv(sv, (UV)aushort);
3753 PUSHs(sv_2mortal(sv));
3759 along = (strend - s) / sizeof(int);
3764 Copy(s, &aint, 1, int);
3767 cdouble += (NV)aint;
3776 Copy(s, &aint, 1, int);
3780 /* Without the dummy below unpack("i", pack("i",-1))
3781 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3782 * cc with optimization turned on.
3784 * The bug was detected in
3785 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3786 * with optimization (-O4) turned on.
3787 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3788 * does not have this problem even with -O4.
3790 * This bug was reported as DECC_BUGS 1431
3791 * and tracked internally as GEM_BUGS 7775.
3793 * The bug is fixed in
3794 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3795 * UNIX V4.0F support: DEC C V5.9-006 or later
3796 * UNIX V4.0E support: DEC C V5.8-011 or later
3799 * See also few lines later for the same bug.
3802 sv_setiv(sv, (IV)aint) :
3804 sv_setiv(sv, (IV)aint);
3805 PUSHs(sv_2mortal(sv));
3810 along = (strend - s) / sizeof(unsigned int);
3815 Copy(s, &auint, 1, unsigned int);
3816 s += sizeof(unsigned int);
3818 cdouble += (NV)auint;
3827 Copy(s, &auint, 1, unsigned int);
3828 s += sizeof(unsigned int);
3831 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3832 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3833 * See details few lines earlier. */
3835 sv_setuv(sv, (UV)auint) :
3837 sv_setuv(sv, (UV)auint);
3838 PUSHs(sv_2mortal(sv));
3843 #if LONGSIZE == SIZE32
3844 along = (strend - s) / SIZE32;
3846 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3851 #if LONGSIZE != SIZE32
3855 COPYNN(s, &along, sizeof(long));
3858 cdouble += (NV)along;
3868 #if LONGSIZE > SIZE32
3869 if (along > 2147483647)
3870 along -= 4294967296;
3874 cdouble += (NV)along;
3883 #if LONGSIZE != SIZE32
3887 COPYNN(s, &along, sizeof(long));
3890 sv_setiv(sv, (IV)along);
3891 PUSHs(sv_2mortal(sv));
3899 #if LONGSIZE > SIZE32
3900 if (along > 2147483647)
3901 along -= 4294967296;
3905 sv_setiv(sv, (IV)along);
3906 PUSHs(sv_2mortal(sv));
3914 #if LONGSIZE == SIZE32
3915 along = (strend - s) / SIZE32;
3917 unatint = natint && datumtype == 'L';
3918 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3923 #if LONGSIZE != SIZE32
3925 unsigned long aulong;
3927 COPYNN(s, &aulong, sizeof(unsigned long));
3928 s += sizeof(unsigned long);
3930 cdouble += (NV)aulong;
3942 if (datumtype == 'N')
3943 aulong = PerlSock_ntohl(aulong);
3946 if (datumtype == 'V')
3947 aulong = vtohl(aulong);
3950 cdouble += (NV)aulong;
3959 #if LONGSIZE != SIZE32
3961 unsigned long aulong;
3963 COPYNN(s, &aulong, sizeof(unsigned long));
3964 s += sizeof(unsigned long);
3966 sv_setuv(sv, (UV)aulong);
3967 PUSHs(sv_2mortal(sv));
3977 if (datumtype == 'N')
3978 aulong = PerlSock_ntohl(aulong);
3981 if (datumtype == 'V')
3982 aulong = vtohl(aulong);
3985 sv_setuv(sv, (UV)aulong);
3986 PUSHs(sv_2mortal(sv));
3992 along = (strend - s) / sizeof(char*);
3998 if (sizeof(char*) > strend - s)
4001 Copy(s, &aptr, 1, char*);
4007 PUSHs(sv_2mortal(sv));
4017 while ((len > 0) && (s < strend)) {
4018 auv = (auv << 7) | (*s & 0x7f);
4019 if (!(*s++ & 0x80)) {
4023 PUSHs(sv_2mortal(sv));
4027 else if (++bytes >= sizeof(UV)) { /* promote to string */
4031 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4032 while (s < strend) {
4033 sv = mul128(sv, *s & 0x7f);
4034 if (!(*s++ & 0x80)) {
4043 PUSHs(sv_2mortal(sv));
4048 if ((s >= strend) && bytes)
4049 DIE(aTHX_ "Unterminated compressed integer");
4054 if (sizeof(char*) > strend - s)
4057 Copy(s, &aptr, 1, char*);
4062 sv_setpvn(sv, aptr, len);
4063 PUSHs(sv_2mortal(sv));
4067 along = (strend - s) / sizeof(Quad_t);
4073 if (s + sizeof(Quad_t) > strend)
4076 Copy(s, &aquad, 1, Quad_t);
4077 s += sizeof(Quad_t);
4080 if (aquad >= IV_MIN && aquad <= IV_MAX)
4081 sv_setiv(sv, (IV)aquad);
4083 sv_setnv(sv, (NV)aquad);
4084 PUSHs(sv_2mortal(sv));
4088 along = (strend - s) / sizeof(Quad_t);
4094 if (s + sizeof(Uquad_t) > strend)
4097 Copy(s, &auquad, 1, Uquad_t);
4098 s += sizeof(Uquad_t);
4101 if (auquad <= UV_MAX)
4102 sv_setuv(sv, (UV)auquad);
4104 sv_setnv(sv, (NV)auquad);
4105 PUSHs(sv_2mortal(sv));
4109 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4112 along = (strend - s) / sizeof(float);
4117 Copy(s, &afloat, 1, float);
4126 Copy(s, &afloat, 1, float);
4129 sv_setnv(sv, (NV)afloat);
4130 PUSHs(sv_2mortal(sv));
4136 along = (strend - s) / sizeof(double);
4141 Copy(s, &adouble, 1, double);
4142 s += sizeof(double);
4150 Copy(s, &adouble, 1, double);
4151 s += sizeof(double);
4153 sv_setnv(sv, (NV)adouble);
4154 PUSHs(sv_2mortal(sv));
4160 * Initialise the decode mapping. By using a table driven
4161 * algorithm, the code will be character-set independent
4162 * (and just as fast as doing character arithmetic)
4164 if (PL_uudmap['M'] == 0) {
4167 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4168 PL_uudmap[(U8)PL_uuemap[i]] = i;
4170 * Because ' ' and '`' map to the same value,
4171 * we need to decode them both the same.
4176 along = (strend - s) * 3 / 4;
4177 sv = NEWSV(42, along);
4180 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4185 len = PL_uudmap[*(U8*)s++] & 077;
4187 if (s < strend && ISUUCHAR(*s))
4188 a = PL_uudmap[*(U8*)s++] & 077;
4191 if (s < strend && ISUUCHAR(*s))
4192 b = PL_uudmap[*(U8*)s++] & 077;
4195 if (s < strend && ISUUCHAR(*s))
4196 c = PL_uudmap[*(U8*)s++] & 077;
4199 if (s < strend && ISUUCHAR(*s))
4200 d = PL_uudmap[*(U8*)s++] & 077;
4203 hunk[0] = (a << 2) | (b >> 4);
4204 hunk[1] = (b << 4) | (c >> 2);
4205 hunk[2] = (c << 6) | d;
4206 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4211 else if (s[1] == '\n') /* possible checksum byte */
4214 XPUSHs(sv_2mortal(sv));
4219 if (strchr("fFdD", datumtype) ||
4220 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4224 while (checksum >= 16) {
4228 while (checksum >= 4) {
4234 along = (1 << checksum) - 1;
4235 while (cdouble < 0.0)
4237 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4238 sv_setnv(sv, cdouble);
4241 if (checksum < 32) {
4242 aulong = (1 << checksum) - 1;
4245 sv_setuv(sv, (UV)culong);
4247 XPUSHs(sv_2mortal(sv));
4251 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4252 PUSHs(&PL_sv_undef);
4257 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4261 *hunk = PL_uuemap[len];
4262 sv_catpvn(sv, hunk, 1);
4265 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4266 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4267 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4268 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4269 sv_catpvn(sv, hunk, 4);
4274 char r = (len > 1 ? s[1] : '\0');
4275 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4276 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4277 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4278 hunk[3] = PL_uuemap[0];
4279 sv_catpvn(sv, hunk, 4);
4281 sv_catpvn(sv, "\n", 1);
4285 S_is_an_int(pTHX_ char *s, STRLEN l)
4288 SV *result = newSVpvn(s, l);
4289 char *result_c = SvPV(result, n_a); /* convenience */
4290 char *out = result_c;
4300 SvREFCNT_dec(result);
4323 SvREFCNT_dec(result);
4329 SvCUR_set(result, out - result_c);
4333 /* pnum must be '\0' terminated */
4335 S_div128(pTHX_ SV *pnum, bool *done)
4338 char *s = SvPV(pnum, len);
4347 i = m * 10 + (*t - '0');
4349 r = (i >> 7); /* r < 10 */
4356 SvCUR_set(pnum, (STRLEN) (t - s));
4363 djSP; dMARK; dORIGMARK; dTARGET;
4364 register SV *cat = TARG;
4367 register char *pat = SvPVx(*++MARK, fromlen);
4368 register char *patend = pat + fromlen;
4373 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4374 static char *space10 = " ";
4376 /* These must not be in registers: */
4391 #ifdef PERL_NATINT_PACK
4392 int natint; /* native integer */
4397 sv_setpvn(cat, "", 0);
4398 while (pat < patend) {
4399 SV *lengthcode = Nullsv;
4400 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4401 datumtype = *pat++ & 0xFF;
4402 #ifdef PERL_NATINT_PACK
4405 if (isSPACE(datumtype))
4407 if (datumtype == '#') {
4408 while (pat < patend && *pat != '\n')
4413 char *natstr = "sSiIlL";
4415 if (strchr(natstr, datumtype)) {
4416 #ifdef PERL_NATINT_PACK
4422 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4425 len = strchr("@Xxu", datumtype) ? 0 : items;
4428 else if (isDIGIT(*pat)) {
4430 while (isDIGIT(*pat)) {
4431 len = (len * 10) + (*pat++ - '0');
4433 DIE(aTHX_ "Repeat count in pack overflows");
4440 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4441 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4442 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4443 ? *MARK : &PL_sv_no)
4444 + (*pat == 'Z' ? 1 : 0)));
4448 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4449 case ',': /* grandfather in commas but with a warning */
4450 if (commas++ == 0 && ckWARN(WARN_PACK))
4451 Perl_warner(aTHX_ WARN_PACK,
4452 "Invalid type in pack: '%c'", (int)datumtype);
4455 DIE(aTHX_ "%% may only be used in unpack");
4466 if (SvCUR(cat) < len)
4467 DIE(aTHX_ "X outside of string");
4474 sv_catpvn(cat, null10, 10);
4477 sv_catpvn(cat, null10, len);
4483 aptr = SvPV(fromstr, fromlen);
4484 if (pat[-1] == '*') {
4486 if (datumtype == 'Z')
4489 if (fromlen >= len) {
4490 sv_catpvn(cat, aptr, len);
4491 if (datumtype == 'Z')
4492 *(SvEND(cat)-1) = '\0';
4495 sv_catpvn(cat, aptr, fromlen);
4497 if (datumtype == 'A') {
4499 sv_catpvn(cat, space10, 10);
4502 sv_catpvn(cat, space10, len);
4506 sv_catpvn(cat, null10, 10);
4509 sv_catpvn(cat, null10, len);
4521 str = SvPV(fromstr, fromlen);
4525 SvCUR(cat) += (len+7)/8;
4526 SvGROW(cat, SvCUR(cat) + 1);
4527 aptr = SvPVX(cat) + aint;
4532 if (datumtype == 'B') {
4533 for (len = 0; len++ < aint;) {
4534 items |= *str++ & 1;
4538 *aptr++ = items & 0xff;
4544 for (len = 0; len++ < aint;) {
4550 *aptr++ = items & 0xff;
4556 if (datumtype == 'B')
4557 items <<= 7 - (aint & 7);
4559 items >>= 7 - (aint & 7);
4560 *aptr++ = items & 0xff;
4562 str = SvPVX(cat) + SvCUR(cat);
4577 str = SvPV(fromstr, fromlen);
4581 SvCUR(cat) += (len+1)/2;
4582 SvGROW(cat, SvCUR(cat) + 1);
4583 aptr = SvPVX(cat) + aint;
4588 if (datumtype == 'H') {
4589 for (len = 0; len++ < aint;) {
4591 items |= ((*str++ & 15) + 9) & 15;
4593 items |= *str++ & 15;
4597 *aptr++ = items & 0xff;
4603 for (len = 0; len++ < aint;) {
4605 items |= (((*str++ & 15) + 9) & 15) << 4;
4607 items |= (*str++ & 15) << 4;
4611 *aptr++ = items & 0xff;
4617 *aptr++ = items & 0xff;
4618 str = SvPVX(cat) + SvCUR(cat);
4629 aint = SvIV(fromstr);
4631 sv_catpvn(cat, &achar, sizeof(char));
4637 auint = SvUV(fromstr);
4638 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
4639 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4644 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4649 afloat = (float)SvNV(fromstr);
4650 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4657 adouble = (double)SvNV(fromstr);
4658 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4664 ashort = (I16)SvIV(fromstr);
4666 ashort = PerlSock_htons(ashort);
4668 CAT16(cat, &ashort);
4674 ashort = (I16)SvIV(fromstr);
4676 ashort = htovs(ashort);
4678 CAT16(cat, &ashort);
4682 #if SHORTSIZE != SIZE16
4684 unsigned short aushort;
4688 aushort = SvUV(fromstr);
4689 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4699 aushort = (U16)SvUV(fromstr);
4700 CAT16(cat, &aushort);
4706 #if SHORTSIZE != SIZE16
4712 ashort = SvIV(fromstr);
4713 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4721 ashort = (I16)SvIV(fromstr);
4722 CAT16(cat, &ashort);
4729 auint = SvUV(fromstr);
4730 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4736 adouble = Perl_floor(SvNV(fromstr));
4739 DIE(aTHX_ "Cannot compress negative numbers");
4742 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4743 adouble <= 0xffffffff
4745 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4746 adouble <= UV_MAX_cxux
4753 char buf[1 + sizeof(UV)];
4754 char *in = buf + sizeof(buf);
4755 UV auv = U_V(adouble);
4758 *--in = (auv & 0x7f) | 0x80;
4761 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4762 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4764 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4765 char *from, *result, *in;
4770 /* Copy string and check for compliance */
4771 from = SvPV(fromstr, len);
4772 if ((norm = is_an_int(from, len)) == NULL)
4773 DIE(aTHX_ "can compress only unsigned integer");
4775 New('w', result, len, char);
4779 *--in = div128(norm, &done) | 0x80;
4780 result[len - 1] &= 0x7F; /* clear continue bit */
4781 sv_catpvn(cat, in, (result + len) - in);
4783 SvREFCNT_dec(norm); /* free norm */
4785 else if (SvNOKp(fromstr)) {
4786 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4787 char *in = buf + sizeof(buf);
4790 double next = floor(adouble / 128);
4791 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4792 if (--in < buf) /* this cannot happen ;-) */
4793 DIE(aTHX_ "Cannot compress integer");
4795 } while (adouble > 0);
4796 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4797 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4800 DIE(aTHX_ "Cannot compress non integer");
4806 aint = SvIV(fromstr);
4807 sv_catpvn(cat, (char*)&aint, sizeof(int));
4813 aulong = SvUV(fromstr);
4815 aulong = PerlSock_htonl(aulong);
4817 CAT32(cat, &aulong);
4823 aulong = SvUV(fromstr);
4825 aulong = htovl(aulong);
4827 CAT32(cat, &aulong);
4831 #if LONGSIZE != SIZE32
4833 unsigned long aulong;
4837 aulong = SvUV(fromstr);
4838 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4846 aulong = SvUV(fromstr);
4847 CAT32(cat, &aulong);
4852 #if LONGSIZE != SIZE32
4858 along = SvIV(fromstr);
4859 sv_catpvn(cat, (char *)&along, sizeof(long));
4867 along = SvIV(fromstr);
4876 auquad = (Uquad_t)SvUV(fromstr);
4877 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4883 aquad = (Quad_t)SvIV(fromstr);
4884 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4889 len = 1; /* assume SV is correct length */
4894 if (fromstr == &PL_sv_undef)
4898 /* XXX better yet, could spirit away the string to
4899 * a safe spot and hang on to it until the result
4900 * of pack() (and all copies of the result) are
4903 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4904 || (SvPADTMP(fromstr)
4905 && !SvREADONLY(fromstr))))
4907 Perl_warner(aTHX_ WARN_PACK,
4908 "Attempt to pack pointer to temporary value");
4910 if (SvPOK(fromstr) || SvNIOK(fromstr))
4911 aptr = SvPV(fromstr,n_a);
4913 aptr = SvPV_force(fromstr,n_a);
4915 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4920 aptr = SvPV(fromstr, fromlen);
4921 SvGROW(cat, fromlen * 4 / 3);
4926 while (fromlen > 0) {
4933 doencodes(cat, aptr, todo);
4952 register I32 limit = POPi; /* note, negative is forever */
4955 register char *s = SvPV(sv, len);
4956 char *strend = s + len;
4958 register REGEXP *rx;
4962 I32 maxiters = (strend - s) + 10;
4965 I32 origlimit = limit;
4968 AV *oldstack = PL_curstack;
4969 I32 gimme = GIMME_V;
4970 I32 oldsave = PL_savestack_ix;
4971 I32 make_mortal = 1;
4972 MAGIC *mg = (MAGIC *) NULL;
4975 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4980 DIE(aTHX_ "panic: do_split");
4981 rx = pm->op_pmregexp;
4983 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4984 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4986 if (pm->op_pmreplroot) {
4988 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4990 ary = GvAVn((GV*)pm->op_pmreplroot);
4993 else if (gimme != G_ARRAY)
4995 ary = (AV*)PL_curpad[0];
4997 ary = GvAVn(PL_defgv);
4998 #endif /* USE_THREADS */
5001 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5007 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5009 XPUSHs(SvTIED_obj((SV*)ary, mg));
5015 for (i = AvFILLp(ary); i >= 0; i--)
5016 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5018 /* temporarily switch stacks */
5019 SWITCHSTACK(PL_curstack, ary);
5023 base = SP - PL_stack_base;
5025 if (pm->op_pmflags & PMf_SKIPWHITE) {
5026 if (pm->op_pmflags & PMf_LOCALE) {
5027 while (isSPACE_LC(*s))
5035 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5036 SAVEINT(PL_multiline);
5037 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5041 limit = maxiters + 2;
5042 if (pm->op_pmflags & PMf_WHITE) {
5045 while (m < strend &&
5046 !((pm->op_pmflags & PMf_LOCALE)
5047 ? isSPACE_LC(*m) : isSPACE(*m)))
5052 dstr = NEWSV(30, m-s);
5053 sv_setpvn(dstr, s, m-s);
5059 while (s < strend &&
5060 ((pm->op_pmflags & PMf_LOCALE)
5061 ? isSPACE_LC(*s) : isSPACE(*s)))
5065 else if (strEQ("^", rx->precomp)) {
5068 for (m = s; m < strend && *m != '\n'; m++) ;
5072 dstr = NEWSV(30, m-s);
5073 sv_setpvn(dstr, s, m-s);
5080 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5081 && (rx->reganch & ROPT_CHECK_ALL)
5082 && !(rx->reganch & ROPT_ANCH)) {
5083 int tail = (rx->reganch & RE_INTUIT_TAIL);
5084 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5088 if (len == 1 && !tail) {
5092 for (m = s; m < strend && *m != c; m++) ;
5095 dstr = NEWSV(30, m-s);
5096 sv_setpvn(dstr, s, m-s);
5105 while (s < strend && --limit &&
5106 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5107 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5110 dstr = NEWSV(31, m-s);
5111 sv_setpvn(dstr, s, m-s);
5115 s = m + len; /* Fake \n at the end */
5120 maxiters += (strend - s) * rx->nparens;
5121 while (s < strend && --limit
5122 /* && (!rx->check_substr
5123 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5125 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5126 1 /* minend */, sv, NULL, 0))
5128 TAINT_IF(RX_MATCH_TAINTED(rx));
5129 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5134 strend = s + (strend - m);
5136 m = rx->startp[0] + orig;
5137 dstr = NEWSV(32, m-s);
5138 sv_setpvn(dstr, s, m-s);
5143 for (i = 1; i <= rx->nparens; i++) {
5144 s = rx->startp[i] + orig;
5145 m = rx->endp[i] + orig;
5147 dstr = NEWSV(33, m-s);
5148 sv_setpvn(dstr, s, m-s);
5151 dstr = NEWSV(33, 0);
5157 s = rx->endp[0] + orig;
5161 LEAVE_SCOPE(oldsave);
5162 iters = (SP - PL_stack_base) - base;
5163 if (iters > maxiters)
5164 DIE(aTHX_ "Split loop");
5166 /* keep field after final delim? */
5167 if (s < strend || (iters && origlimit)) {
5168 dstr = NEWSV(34, strend-s);
5169 sv_setpvn(dstr, s, strend-s);
5175 else if (!origlimit) {
5176 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5182 SWITCHSTACK(ary, oldstack);
5183 if (SvSMAGICAL(ary)) {
5188 if (gimme == G_ARRAY) {
5190 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5198 call_method("PUSH",G_SCALAR|G_DISCARD);
5201 if (gimme == G_ARRAY) {
5202 /* EXTEND should not be needed - we just popped them */
5204 for (i=0; i < iters; i++) {
5205 SV **svp = av_fetch(ary, i, FALSE);
5206 PUSHs((svp) ? *svp : &PL_sv_undef);
5213 if (gimme == G_ARRAY)
5216 if (iters || !pm->op_pmreplroot) {
5226 Perl_unlock_condpair(pTHX_ void *svv)
5229 MAGIC *mg = mg_find((SV*)svv, 'm');
5232 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5233 MUTEX_LOCK(MgMUTEXP(mg));
5234 if (MgOWNER(mg) != thr)
5235 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5237 COND_SIGNAL(MgOWNERCONDP(mg));
5238 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5239 PTR2UV(thr), PTR2UV(svv));)
5240 MUTEX_UNLOCK(MgMUTEXP(mg));
5242 #endif /* USE_THREADS */
5255 mg = condpair_magic(sv);
5256 MUTEX_LOCK(MgMUTEXP(mg));
5257 if (MgOWNER(mg) == thr)
5258 MUTEX_UNLOCK(MgMUTEXP(mg));
5261 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5263 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5264 PTR2UV(thr), PTR2UV(sv));)
5265 MUTEX_UNLOCK(MgMUTEXP(mg));
5266 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5268 #endif /* USE_THREADS */
5269 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5270 || SvTYPE(retsv) == SVt_PVCV) {
5271 retsv = refto(retsv);
5282 if (PL_op->op_private & OPpLVAL_INTRO)
5283 PUSHs(*save_threadsv(PL_op->op_targ));
5285 PUSHs(THREADSV(PL_op->op_targ));
5288 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5289 #endif /* USE_THREADS */