3 * Copyright (c) 1991-1999, 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 * Types used in bitwise operations.
33 * Normally we'd just use IV and UV. However, some hardware and
34 * software combinations (e.g. Alpha and current OSF/1) don't have a
35 * floating-point type to use for NV that has adequate bits to fully
36 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
38 * It just so happens that "int" is the right size almost everywhere.
44 * Mask used after bitwise operations.
46 * There is at least one realm (Cray word machines) that doesn't
47 * have an integral type (except char) small enough to be represented
48 * in a double without loss; that is, it has no 32-bit type.
50 #if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
52 # define BW_MASK ((1 << BW_BITS) - 1)
53 # define BW_SIGN (1 << (BW_BITS - 1))
54 # define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
55 # define BWu(u) ((u) & BW_MASK)
62 * Offset for integer pack/unpack.
64 * On architectures where I16 and I32 aren't really 16 and 32 bits,
65 * which for now are all Crays, pack and unpack have to play games.
69 * These values are required for portability of pack() output.
70 * If they're not right on your machine, then pack() and unpack()
71 * wouldn't work right anyway; you'll need to apply the Cray hack.
72 * (I'd like to check them with #if, but you can't use sizeof() in
73 * the preprocessor.) --???
76 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
77 defines are now in config.h. --Andy Dougherty April 1998
82 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
85 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
86 # define PERL_NATINT_PACK
89 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
90 # if BYTEORDER == 0x12345678
91 # define OFF16(p) (char*)(p)
92 # define OFF32(p) (char*)(p)
94 # if BYTEORDER == 0x87654321
95 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
96 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
98 }}}} bad cray byte order
101 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
102 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
103 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
104 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
105 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
107 # define COPY16(s,p) Copy(s, p, SIZE16, char)
108 # define COPY32(s,p) Copy(s, p, SIZE32, char)
109 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
110 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
111 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
114 /* variations on pp_null */
120 /* XXX I can't imagine anyone who doesn't have this actually _needs_
121 it, since pid_t is an integral type.
124 #ifdef NEED_GETPID_PROTO
125 extern Pid_t getpid (void);
131 if (GIMME_V == G_SCALAR)
132 XPUSHs(&PL_sv_undef);
146 if (PL_op->op_private & OPpLVAL_INTRO)
147 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
149 if (PL_op->op_flags & OPf_REF) {
153 if (GIMME == G_ARRAY) {
154 I32 maxarg = AvFILL((AV*)TARG) + 1;
156 if (SvMAGICAL(TARG)) {
158 for (i=0; i < maxarg; i++) {
159 SV **svp = av_fetch((AV*)TARG, i, FALSE);
160 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
164 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
169 SV* sv = sv_newmortal();
170 I32 maxarg = AvFILL((AV*)TARG) + 1;
171 sv_setiv(sv, maxarg);
183 if (PL_op->op_private & OPpLVAL_INTRO)
184 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
185 if (PL_op->op_flags & OPf_REF)
188 if (gimme == G_ARRAY) {
191 else if (gimme == G_SCALAR) {
192 SV* sv = sv_newmortal();
193 if (HvFILL((HV*)TARG))
194 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
195 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
205 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
216 tryAMAGICunDEREF(to_gv);
219 if (SvTYPE(sv) == SVt_PVIO) {
220 GV *gv = (GV*) sv_newmortal();
221 gv_init(gv, 0, "", 0, 0);
222 GvIOp(gv) = (IO *)sv;
223 (void)SvREFCNT_inc(sv);
226 else if (SvTYPE(sv) != SVt_PVGV)
227 DIE(aTHX_ "Not a GLOB reference");
230 if (SvTYPE(sv) != SVt_PVGV) {
234 if (SvGMAGICAL(sv)) {
240 /* If this is a 'my' scalar and flag is set then vivify
243 if (PL_op->op_private & OPpDEREF) {
244 GV *gv = (GV *) newSV(0);
247 if (cUNOP->op_first->op_type == OP_PADSV) {
248 SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
249 name = SvPV(padname,len);
251 gv_init(gv, PL_curcop->cop_stash, name, len, 0);
252 sv_upgrade(sv, SVt_RV);
253 SvRV(sv) = (SV *) gv;
258 if (PL_op->op_flags & OPf_REF ||
259 PL_op->op_private & HINT_STRICT_REFS)
260 DIE(aTHX_ PL_no_usym, "a symbol");
261 if (ckWARN(WARN_UNINITIALIZED))
262 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
266 if ((PL_op->op_flags & OPf_SPECIAL) &&
267 !(PL_op->op_flags & OPf_MOD))
269 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
274 if (PL_op->op_private & HINT_STRICT_REFS)
275 DIE(aTHX_ PL_no_symref, sym, "a symbol");
276 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
280 if (PL_op->op_private & OPpLVAL_INTRO)
281 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
292 tryAMAGICunDEREF(to_sv);
295 switch (SvTYPE(sv)) {
299 DIE(aTHX_ "Not a SCALAR reference");
307 if (SvTYPE(gv) != SVt_PVGV) {
308 if (SvGMAGICAL(sv)) {
314 if (PL_op->op_flags & OPf_REF ||
315 PL_op->op_private & HINT_STRICT_REFS)
316 DIE(aTHX_ PL_no_usym, "a SCALAR");
317 if (ckWARN(WARN_UNINITIALIZED))
318 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
322 if ((PL_op->op_flags & OPf_SPECIAL) &&
323 !(PL_op->op_flags & OPf_MOD))
325 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
330 if (PL_op->op_private & HINT_STRICT_REFS)
331 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
332 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
337 if (PL_op->op_flags & OPf_MOD) {
338 if (PL_op->op_private & OPpLVAL_INTRO)
339 sv = save_scalar((GV*)TOPs);
340 else if (PL_op->op_private & OPpDEREF)
341 vivify_ref(sv, PL_op->op_private & OPpDEREF);
351 SV *sv = AvARYLEN(av);
353 AvARYLEN(av) = sv = NEWSV(0,0);
354 sv_upgrade(sv, SVt_IV);
355 sv_magic(sv, (SV*)av, '#', Nullch, 0);
363 djSP; dTARGET; dPOPss;
365 if (PL_op->op_flags & OPf_MOD) {
366 if (SvTYPE(TARG) < SVt_PVLV) {
367 sv_upgrade(TARG, SVt_PVLV);
368 sv_magic(TARG, Nullsv, '.', Nullch, 0);
372 if (LvTARG(TARG) != sv) {
374 SvREFCNT_dec(LvTARG(TARG));
375 LvTARG(TARG) = SvREFCNT_inc(sv);
377 PUSHs(TARG); /* no SvSETMAGIC */
383 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
384 mg = mg_find(sv, 'g');
385 if (mg && mg->mg_len >= 0) {
389 PUSHi(i + PL_curcop->cop_arybase);
403 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
404 /* (But not in defined().) */
405 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
408 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
411 cv = (CV*)&PL_sv_undef;
425 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
426 char *s = SvPVX(TOPs);
427 if (strnEQ(s, "CORE::", 6)) {
430 code = keyword(s + 6, SvCUR(TOPs) - 6);
431 if (code < 0) { /* Overridable. */
432 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
433 int i = 0, n = 0, seen_question = 0;
435 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
437 while (i < MAXO) { /* The slow way. */
438 if (strEQ(s + 6, PL_op_name[i])
439 || strEQ(s + 6, PL_op_desc[i]))
445 goto nonesuch; /* Should not happen... */
447 oa = PL_opargs[i] >> OASHIFT;
449 if (oa & OA_OPTIONAL) {
453 else if (seen_question)
454 goto set; /* XXXX system, exec */
455 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
456 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
459 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
460 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
464 ret = sv_2mortal(newSVpvn(str, n - 1));
466 else if (code) /* Non-Overridable */
468 else { /* None such */
470 Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
474 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
476 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
485 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
487 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
503 if (GIMME != G_ARRAY) {
507 *MARK = &PL_sv_undef;
508 *MARK = refto(*MARK);
512 EXTEND_MORTAL(SP - MARK);
514 *MARK = refto(*MARK);
519 S_refto(pTHX_ SV *sv)
523 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
526 if (!(sv = LvTARG(sv)))
529 (void)SvREFCNT_inc(sv);
531 else if (SvPADTMP(sv))
535 (void)SvREFCNT_inc(sv);
538 sv_upgrade(rv, SVt_RV);
552 if (sv && SvGMAGICAL(sv))
555 if (!sv || !SvROK(sv))
559 pv = sv_reftype(sv,TRUE);
560 PUSHp(pv, strlen(pv));
570 stash = PL_curcop->cop_stash;
574 char *ptr = SvPV(ssv,len);
575 if (ckWARN(WARN_UNSAFE) && len == 0)
576 Perl_warner(aTHX_ WARN_UNSAFE,
577 "Explicit blessing to '' (assuming package main)");
578 stash = gv_stashpvn(ptr, len, TRUE);
581 (void)sv_bless(TOPs, stash);
595 elem = SvPV(sv, n_a);
599 switch (elem ? *elem : '\0')
602 if (strEQ(elem, "ARRAY"))
603 tmpRef = (SV*)GvAV(gv);
606 if (strEQ(elem, "CODE"))
607 tmpRef = (SV*)GvCVu(gv);
610 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
611 tmpRef = (SV*)GvIOp(gv);
614 if (strEQ(elem, "GLOB"))
618 if (strEQ(elem, "HASH"))
619 tmpRef = (SV*)GvHV(gv);
622 if (strEQ(elem, "IO"))
623 tmpRef = (SV*)GvIOp(gv);
626 if (strEQ(elem, "NAME"))
627 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
630 if (strEQ(elem, "PACKAGE"))
631 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
634 if (strEQ(elem, "SCALAR"))
648 /* Pattern matching */
653 register unsigned char *s;
656 register I32 *sfirst;
660 if (sv == PL_lastscream) {
666 SvSCREAM_off(PL_lastscream);
667 SvREFCNT_dec(PL_lastscream);
669 PL_lastscream = SvREFCNT_inc(sv);
672 s = (unsigned char*)(SvPV(sv, len));
676 if (pos > PL_maxscream) {
677 if (PL_maxscream < 0) {
678 PL_maxscream = pos + 80;
679 New(301, PL_screamfirst, 256, I32);
680 New(302, PL_screamnext, PL_maxscream, I32);
683 PL_maxscream = pos + pos / 4;
684 Renew(PL_screamnext, PL_maxscream, I32);
688 sfirst = PL_screamfirst;
689 snext = PL_screamnext;
691 if (!sfirst || !snext)
692 DIE(aTHX_ "do_study: out of memory");
694 for (ch = 256; ch; --ch)
701 snext[pos] = sfirst[ch] - pos;
708 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
717 if (PL_op->op_flags & OPf_STACKED)
723 TARG = sv_newmortal();
728 /* Lvalue operators. */
740 djSP; dMARK; dTARGET;
750 SETi(do_chomp(TOPs));
756 djSP; dMARK; dTARGET;
757 register I32 count = 0;
760 count += do_chomp(POPs);
771 if (!sv || !SvANY(sv))
773 switch (SvTYPE(sv)) {
775 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
779 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
783 if (CvROOT(sv) || CvXSUB(sv))
800 if (!PL_op->op_private) {
809 if (SvTHINKFIRST(sv))
812 switch (SvTYPE(sv)) {
822 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
823 Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
824 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
828 /* let user-undef'd sub keep its identity */
829 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
836 SvSetMagicSV(sv, &PL_sv_undef);
840 Newz(602, gp, 1, GP);
841 GvGP(sv) = gp_ref(gp);
842 GvSV(sv) = NEWSV(72,0);
843 GvLINE(sv) = PL_curcop->cop_line;
849 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
852 SvPV_set(sv, Nullch);
865 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
866 Perl_croak(aTHX_ PL_no_modify);
867 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
868 SvIVX(TOPs) != IV_MIN)
871 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
882 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
883 Perl_croak(aTHX_ PL_no_modify);
884 sv_setsv(TARG, TOPs);
885 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
886 SvIVX(TOPs) != IV_MAX)
889 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
903 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
904 Perl_croak(aTHX_ PL_no_modify);
905 sv_setsv(TARG, TOPs);
906 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
907 SvIVX(TOPs) != IV_MIN)
910 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
919 /* Ordinary operators. */
923 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
926 SETn( pow( left, right) );
933 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
936 SETn( left * right );
943 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
948 DIE(aTHX_ "Illegal division by zero");
950 /* insure that 20./5. == 4. */
953 if ((NV)I_V(left) == left &&
954 (NV)I_V(right) == right &&
955 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
959 value = left / right;
963 value = left / right;
972 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
982 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
984 right = (right_neg = (i < 0)) ? -i : i;
989 right_neg = dright < 0;
994 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
996 left = (left_neg = (i < 0)) ? -i : i;
1004 left_neg = dleft < 0;
1013 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1015 # define CAST_D2UV(d) U_V(d)
1017 # define CAST_D2UV(d) ((UV)(d))
1019 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1020 * or, in other words, precision of UV more than of NV.
1021 * But in fact the approach below turned out to be an
1022 * optimization - floor() may be slow */
1023 if (dright <= UV_MAX && dleft <= UV_MAX) {
1024 right = CAST_D2UV(dright);
1025 left = CAST_D2UV(dleft);
1030 /* Backward-compatibility clause: */
1031 dright = floor(dright + 0.5);
1032 dleft = floor(dleft + 0.5);
1035 DIE(aTHX_ "Illegal modulus zero");
1037 dans = Perl_fmod(dleft, dright);
1038 if ((left_neg != right_neg) && dans)
1039 dans = dright - dans;
1042 sv_setnv(TARG, dans);
1049 DIE(aTHX_ "Illegal modulus zero");
1052 if ((left_neg != right_neg) && ans)
1055 /* XXX may warn: unary minus operator applied to unsigned type */
1056 /* could change -foo to be (~foo)+1 instead */
1057 if (ans <= ~((UV)IV_MAX)+1)
1058 sv_setiv(TARG, ~ans+1);
1060 sv_setnv(TARG, -(NV)ans);
1063 sv_setuv(TARG, ans);
1072 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1074 register I32 count = POPi;
1075 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1077 I32 items = SP - MARK;
1080 max = items * count;
1089 repeatcpy((char*)(MARK + items), (char*)MARK,
1090 items * sizeof(SV*), count - 1);
1093 else if (count <= 0)
1096 else { /* Note: mark already snarfed by pp_list */
1101 SvSetSV(TARG, tmpstr);
1102 SvPV_force(TARG, len);
1107 SvGROW(TARG, (count * len) + 1);
1108 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1109 SvCUR(TARG) *= count;
1111 *SvEND(TARG) = '\0';
1113 (void)SvPOK_only(TARG);
1122 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1125 SETn( left - right );
1132 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1135 if (PL_op->op_private & HINT_INTEGER) {
1137 i = BWi(i) << shift;
1151 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1154 if (PL_op->op_private & HINT_INTEGER) {
1156 i = BWi(i) >> shift;
1170 djSP; tryAMAGICbinSET(lt,0);
1173 SETs(boolSV(TOPn < value));
1180 djSP; tryAMAGICbinSET(gt,0);
1183 SETs(boolSV(TOPn > value));
1190 djSP; tryAMAGICbinSET(le,0);
1193 SETs(boolSV(TOPn <= value));
1200 djSP; tryAMAGICbinSET(ge,0);
1203 SETs(boolSV(TOPn >= value));
1210 djSP; tryAMAGICbinSET(ne,0);
1213 SETs(boolSV(TOPn != value));
1220 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1227 else if (left < right)
1229 else if (left > right)
1242 djSP; tryAMAGICbinSET(slt,0);
1245 int cmp = ((PL_op->op_private & OPpLOCALE)
1246 ? sv_cmp_locale(left, right)
1247 : sv_cmp(left, right));
1248 SETs(boolSV(cmp < 0));
1255 djSP; tryAMAGICbinSET(sgt,0);
1258 int cmp = ((PL_op->op_private & OPpLOCALE)
1259 ? sv_cmp_locale(left, right)
1260 : sv_cmp(left, right));
1261 SETs(boolSV(cmp > 0));
1268 djSP; tryAMAGICbinSET(sle,0);
1271 int cmp = ((PL_op->op_private & OPpLOCALE)
1272 ? sv_cmp_locale(left, right)
1273 : sv_cmp(left, right));
1274 SETs(boolSV(cmp <= 0));
1281 djSP; tryAMAGICbinSET(sge,0);
1284 int cmp = ((PL_op->op_private & OPpLOCALE)
1285 ? sv_cmp_locale(left, right)
1286 : sv_cmp(left, right));
1287 SETs(boolSV(cmp >= 0));
1294 djSP; tryAMAGICbinSET(seq,0);
1297 SETs(boolSV(sv_eq(left, right)));
1304 djSP; tryAMAGICbinSET(sne,0);
1307 SETs(boolSV(!sv_eq(left, right)));
1314 djSP; dTARGET; tryAMAGICbin(scmp,0);
1317 int cmp = ((PL_op->op_private & OPpLOCALE)
1318 ? sv_cmp_locale(left, right)
1319 : sv_cmp(left, right));
1327 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1330 if (SvNIOKp(left) || SvNIOKp(right)) {
1331 if (PL_op->op_private & HINT_INTEGER) {
1332 IBW value = SvIV(left) & SvIV(right);
1336 UBW value = SvUV(left) & SvUV(right);
1341 do_vop(PL_op->op_type, TARG, left, right);
1350 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1353 if (SvNIOKp(left) || SvNIOKp(right)) {
1354 if (PL_op->op_private & HINT_INTEGER) {
1355 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1359 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1364 do_vop(PL_op->op_type, TARG, left, right);
1373 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1376 if (SvNIOKp(left) || SvNIOKp(right)) {
1377 if (PL_op->op_private & HINT_INTEGER) {
1378 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1382 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1387 do_vop(PL_op->op_type, TARG, left, right);
1396 djSP; dTARGET; tryAMAGICun(neg);
1401 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1403 else if (SvNIOKp(sv))
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 (IN_UTF8 && *(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) {
1444 IBW value = ~SvIV(sv);
1448 UBW value = ~SvUV(sv);
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)getpid();
1779 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1780 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1781 u += SEED_C5 * (U32)(UV)&when;
1788 djSP; dTARGET; tryAMAGICun(exp);
1792 value = Perl_exp(value);
1800 djSP; dTARGET; tryAMAGICun(log);
1805 RESTORE_NUMERIC_STANDARD();
1806 DIE(aTHX_ "Can't take log of %g", value);
1808 value = Perl_log(value);
1816 djSP; dTARGET; tryAMAGICun(sqrt);
1821 RESTORE_NUMERIC_STANDARD();
1822 DIE(aTHX_ "Can't take sqrt of %g", value);
1824 value = Perl_sqrt(value);
1837 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1843 (void)Perl_modf(value, &value);
1845 (void)Perl_modf(-value, &value);
1860 djSP; dTARGET; tryAMAGICun(abs);
1865 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1866 (iv = SvIVX(TOPs)) != IV_MIN) {
1888 XPUSHn(scan_hex(tmps, 99, &argtype));
1901 while (*tmps && isSPACE(*tmps))
1906 value = scan_hex(++tmps, 99, &argtype);
1907 else if (*tmps == 'b')
1908 value = scan_bin(++tmps, 99, &argtype);
1910 value = scan_oct(tmps, 99, &argtype);
1922 SETi( sv_len_utf8(TOPs) );
1926 SETi( sv_len(TOPs) );
1940 I32 lvalue = PL_op->op_flags & OPf_MOD;
1942 I32 arybase = PL_curcop->cop_arybase;
1946 SvTAINTED_off(TARG); /* decontaminate */
1950 repl = SvPV(sv, repl_len);
1957 tmps = SvPV(sv, curlen);
1959 utfcurlen = sv_len_utf8(sv);
1960 if (utfcurlen == curlen)
1968 if (pos >= arybase) {
1986 else if (len >= 0) {
1988 if (rem > (I32)curlen)
2002 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2003 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2008 sv_pos_u2b(sv, &pos, &rem);
2010 sv_setpvn(TARG, tmps, rem);
2011 if (lvalue) { /* it's an lvalue! */
2012 if (!SvGMAGICAL(sv)) {
2016 if (ckWARN(WARN_SUBSTR))
2017 Perl_warner(aTHX_ WARN_SUBSTR,
2018 "Attempt to use reference as lvalue in substr");
2020 if (SvOK(sv)) /* is it defined ? */
2021 (void)SvPOK_only(sv);
2023 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2026 if (SvTYPE(TARG) < SVt_PVLV) {
2027 sv_upgrade(TARG, SVt_PVLV);
2028 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2032 if (LvTARG(TARG) != sv) {
2034 SvREFCNT_dec(LvTARG(TARG));
2035 LvTARG(TARG) = SvREFCNT_inc(sv);
2037 LvTARGOFF(TARG) = pos;
2038 LvTARGLEN(TARG) = rem;
2041 sv_insert(sv, pos, rem, repl, repl_len);
2044 PUSHs(TARG); /* avoid SvSETMAGIC here */
2051 register I32 size = POPi;
2052 register I32 offset = POPi;
2053 register SV *src = POPs;
2054 I32 lvalue = PL_op->op_flags & OPf_MOD;
2056 unsigned char *s = (unsigned char*)SvPV(src, srclen);
2057 unsigned long retnum;
2060 SvTAINTED_off(TARG); /* decontaminate */
2061 offset *= size; /* turn into bit offset */
2062 len = (offset + size + 7) / 8;
2063 if (offset < 0 || size < 1)
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);
2073 if (LvTARG(TARG) != src) {
2075 SvREFCNT_dec(LvTARG(TARG));
2076 LvTARG(TARG) = SvREFCNT_inc(src);
2078 LvTARGOFF(TARG) = offset;
2079 LvTARGLEN(TARG) = size;
2087 if (offset >= srclen)
2090 retnum = (unsigned long) s[offset] << 8;
2092 else if (size == 32) {
2093 if (offset >= srclen)
2095 else if (offset + 1 >= srclen)
2096 retnum = (unsigned long) s[offset] << 24;
2097 else if (offset + 2 >= srclen)
2098 retnum = ((unsigned long) s[offset] << 24) +
2099 ((unsigned long) s[offset + 1] << 16);
2101 retnum = ((unsigned long) s[offset] << 24) +
2102 ((unsigned long) s[offset + 1] << 16) +
2103 (s[offset + 2] << 8);
2108 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2113 else if (size == 16)
2114 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2115 else if (size == 32)
2116 retnum = ((unsigned long) s[offset] << 24) +
2117 ((unsigned long) s[offset + 1] << 16) +
2118 (s[offset + 2] << 8) + s[offset+3];
2122 sv_setuv(TARG, (UV)retnum);
2137 I32 arybase = PL_curcop->cop_arybase;
2142 offset = POPi - arybase;
2145 tmps = SvPV(big, biglen);
2146 if (IN_UTF8 && offset > 0)
2147 sv_pos_u2b(big, &offset, 0);
2150 else if (offset > biglen)
2152 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2153 (unsigned char*)tmps + biglen, little, 0)))
2156 retval = tmps2 - tmps;
2157 if (IN_UTF8 && retval > 0)
2158 sv_pos_b2u(big, &retval);
2159 PUSHi(retval + arybase);
2174 I32 arybase = PL_curcop->cop_arybase;
2180 tmps2 = SvPV(little, llen);
2181 tmps = SvPV(big, blen);
2185 if (IN_UTF8 && offset > 0)
2186 sv_pos_u2b(big, &offset, 0);
2187 offset = offset - arybase + llen;
2191 else if (offset > blen)
2193 if (!(tmps2 = rninstr(tmps, tmps + offset,
2194 tmps2, tmps2 + llen)))
2197 retval = tmps2 - tmps;
2198 if (IN_UTF8 && retval > 0)
2199 sv_pos_b2u(big, &retval);
2200 PUSHi(retval + arybase);
2206 djSP; dMARK; dORIGMARK; dTARGET;
2207 do_sprintf(TARG, SP-MARK, MARK+1);
2208 TAINT_IF(SvTAINTED(TARG));
2219 U8 *tmps = (U8*)POPpx;
2222 if (IN_UTF8 && (*tmps & 0x80))
2223 value = utf8_to_uv(tmps, &retlen);
2225 value = (UV)(*tmps & 255);
2236 (void)SvUPGRADE(TARG,SVt_PV);
2238 if (IN_UTF8 && value >= 128) {
2241 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2242 SvCUR_set(TARG, tmps - SvPVX(TARG));
2244 (void)SvPOK_only(TARG);
2254 (void)SvPOK_only(TARG);
2261 djSP; dTARGET; dPOPTOPssrl;
2264 char *tmps = SvPV(left, n_a);
2266 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2268 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2272 "The crypt() function is unimplemented due to excessive paranoia.");
2285 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2289 UV uv = utf8_to_uv(s, &ulen);
2291 if (PL_op->op_private & OPpLOCALE) {
2294 uv = toTITLE_LC_uni(uv);
2297 uv = toTITLE_utf8(s);
2299 tend = uv_to_utf8(tmpbuf, uv);
2301 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2303 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2304 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2308 s = (U8*)SvPV_force(sv, slen);
2309 Copy(tmpbuf, s, ulen, U8);
2313 if (!SvPADTMP(sv)) {
2319 s = (U8*)SvPV_force(sv, slen);
2321 if (PL_op->op_private & OPpLOCALE) {
2324 *s = toUPPER_LC(*s);
2342 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2346 UV uv = utf8_to_uv(s, &ulen);
2348 if (PL_op->op_private & OPpLOCALE) {
2351 uv = toLOWER_LC_uni(uv);
2354 uv = toLOWER_utf8(s);
2356 tend = uv_to_utf8(tmpbuf, uv);
2358 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2360 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2361 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2365 s = (U8*)SvPV_force(sv, slen);
2366 Copy(tmpbuf, s, ulen, U8);
2370 if (!SvPADTMP(sv)) {
2376 s = (U8*)SvPV_force(sv, slen);
2378 if (PL_op->op_private & OPpLOCALE) {
2381 *s = toLOWER_LC(*s);
2406 s = (U8*)SvPV(sv,len);
2408 sv_setpvn(TARG, "", 0);
2412 (void)SvUPGRADE(TARG, SVt_PV);
2413 SvGROW(TARG, (len * 2) + 1);
2414 (void)SvPOK_only(TARG);
2415 d = (U8*)SvPVX(TARG);
2417 if (PL_op->op_private & OPpLOCALE) {
2421 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2427 d = uv_to_utf8(d, toUPPER_utf8( s ));
2432 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2437 if (!SvPADTMP(sv)) {
2443 s = (U8*)SvPV_force(sv, len);
2445 register U8 *send = s + len;
2447 if (PL_op->op_private & OPpLOCALE) {
2450 for (; s < send; s++)
2451 *s = toUPPER_LC(*s);
2454 for (; s < send; s++)
2477 s = (U8*)SvPV(sv,len);
2479 sv_setpvn(TARG, "", 0);
2483 (void)SvUPGRADE(TARG, SVt_PV);
2484 SvGROW(TARG, (len * 2) + 1);
2485 (void)SvPOK_only(TARG);
2486 d = (U8*)SvPVX(TARG);
2488 if (PL_op->op_private & OPpLOCALE) {
2492 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2498 d = uv_to_utf8(d, toLOWER_utf8(s));
2503 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2508 if (!SvPADTMP(sv)) {
2515 s = (U8*)SvPV_force(sv, len);
2517 register U8 *send = s + len;
2519 if (PL_op->op_private & OPpLOCALE) {
2522 for (; s < send; s++)
2523 *s = toLOWER_LC(*s);
2526 for (; s < send; s++)
2541 register char *s = SvPV(sv,len);
2545 (void)SvUPGRADE(TARG, SVt_PV);
2546 SvGROW(TARG, (len * 2) + 1);
2551 STRLEN ulen = UTF8SKIP(s);
2574 SvCUR_set(TARG, d - SvPVX(TARG));
2575 (void)SvPOK_only(TARG);
2578 sv_setpvn(TARG, s, len);
2580 if (SvSMAGICAL(TARG))
2589 djSP; dMARK; dORIGMARK;
2591 register AV* av = (AV*)POPs;
2592 register I32 lval = PL_op->op_flags & OPf_MOD;
2593 I32 arybase = PL_curcop->cop_arybase;
2596 if (SvTYPE(av) == SVt_PVAV) {
2597 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2599 for (svp = MARK + 1; svp <= SP; svp++) {
2604 if (max > AvMAX(av))
2607 while (++MARK <= SP) {
2608 elem = SvIVx(*MARK);
2612 svp = av_fetch(av, elem, lval);
2614 if (!svp || *svp == &PL_sv_undef)
2615 DIE(aTHX_ PL_no_aelem, elem);
2616 if (PL_op->op_private & OPpLVAL_INTRO)
2617 save_aelem(av, elem, svp);
2619 *MARK = svp ? *svp : &PL_sv_undef;
2622 if (GIMME != G_ARRAY) {
2630 /* Associative arrays. */
2635 HV *hash = (HV*)POPs;
2637 I32 gimme = GIMME_V;
2638 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2641 /* might clobber stack_sp */
2642 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2647 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2648 if (gimme == G_ARRAY) {
2651 /* might clobber stack_sp */
2653 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2658 else if (gimme == G_SCALAR)
2677 I32 gimme = GIMME_V;
2678 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2682 if (PL_op->op_private & OPpSLICE) {
2686 hvtype = SvTYPE(hv);
2687 while (++MARK <= SP) {
2688 if (hvtype == SVt_PVHV)
2689 sv = hv_delete_ent(hv, *MARK, discard, 0);
2691 DIE(aTHX_ "Not a HASH reference");
2692 *MARK = sv ? sv : &PL_sv_undef;
2696 else if (gimme == G_SCALAR) {
2705 if (SvTYPE(hv) == SVt_PVHV)
2706 sv = hv_delete_ent(hv, keysv, discard, 0);
2708 DIE(aTHX_ "Not a HASH reference");
2722 if (SvTYPE(hv) == SVt_PVHV) {
2723 if (hv_exists_ent(hv, tmpsv, 0))
2726 else if (SvTYPE(hv) == SVt_PVAV) {
2727 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2731 DIE(aTHX_ "Not a HASH reference");
2738 djSP; dMARK; dORIGMARK;
2739 register HV *hv = (HV*)POPs;
2740 register I32 lval = PL_op->op_flags & OPf_MOD;
2741 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2743 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2744 DIE(aTHX_ "Can't localize pseudo-hash element");
2746 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2747 while (++MARK <= SP) {
2751 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2752 svp = he ? &HeVAL(he) : 0;
2755 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2758 if (!svp || *svp == &PL_sv_undef) {
2760 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2762 if (PL_op->op_private & OPpLVAL_INTRO)
2763 save_helem(hv, keysv, svp);
2765 *MARK = svp ? *svp : &PL_sv_undef;
2768 if (GIMME != G_ARRAY) {
2776 /* List operators. */
2781 if (GIMME != G_ARRAY) {
2783 *MARK = *SP; /* unwanted list, return last item */
2785 *MARK = &PL_sv_undef;
2794 SV **lastrelem = PL_stack_sp;
2795 SV **lastlelem = PL_stack_base + POPMARK;
2796 SV **firstlelem = PL_stack_base + POPMARK + 1;
2797 register SV **firstrelem = lastlelem + 1;
2798 I32 arybase = PL_curcop->cop_arybase;
2799 I32 lval = PL_op->op_flags & OPf_MOD;
2800 I32 is_something_there = lval;
2802 register I32 max = lastrelem - lastlelem;
2803 register SV **lelem;
2806 if (GIMME != G_ARRAY) {
2807 ix = SvIVx(*lastlelem);
2812 if (ix < 0 || ix >= max)
2813 *firstlelem = &PL_sv_undef;
2815 *firstlelem = firstrelem[ix];
2821 SP = firstlelem - 1;
2825 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2831 if (ix < 0 || ix >= max)
2832 *lelem = &PL_sv_undef;
2834 is_something_there = TRUE;
2835 if (!(*lelem = firstrelem[ix]))
2836 *lelem = &PL_sv_undef;
2839 if (is_something_there)
2842 SP = firstlelem - 1;
2848 djSP; dMARK; dORIGMARK;
2849 I32 items = SP - MARK;
2850 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2851 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2858 djSP; dMARK; dORIGMARK;
2859 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2863 SV *val = NEWSV(46, 0);
2865 sv_setsv(val, *++MARK);
2866 else if (ckWARN(WARN_UNSAFE))
2867 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2868 (void)hv_store_ent(hv,key,val,0);
2877 djSP; dMARK; dORIGMARK;
2878 register AV *ary = (AV*)*++MARK;
2882 register I32 offset;
2883 register I32 length;
2890 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2891 *MARK-- = SvTIED_obj((SV*)ary, mg);
2895 call_method("SPLICE",GIMME_V);
2904 offset = i = SvIVx(*MARK);
2906 offset += AvFILLp(ary) + 1;
2908 offset -= PL_curcop->cop_arybase;
2910 DIE(aTHX_ PL_no_aelem, i);
2912 length = SvIVx(*MARK++);
2914 length += AvFILLp(ary) - offset + 1;
2920 length = AvMAX(ary) + 1; /* close enough to infinity */
2924 length = AvMAX(ary) + 1;
2926 if (offset > AvFILLp(ary) + 1)
2927 offset = AvFILLp(ary) + 1;
2928 after = AvFILLp(ary) + 1 - (offset + length);
2929 if (after < 0) { /* not that much array */
2930 length += after; /* offset+length now in array */
2936 /* At this point, MARK .. SP-1 is our new LIST */
2939 diff = newlen - length;
2940 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2943 if (diff < 0) { /* shrinking the area */
2945 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2946 Copy(MARK, tmparyval, newlen, SV*);
2949 MARK = ORIGMARK + 1;
2950 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2951 MEXTEND(MARK, length);
2952 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2954 EXTEND_MORTAL(length);
2955 for (i = length, dst = MARK; i; i--) {
2956 sv_2mortal(*dst); /* free them eventualy */
2963 *MARK = AvARRAY(ary)[offset+length-1];
2966 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2967 SvREFCNT_dec(*dst++); /* free them now */
2970 AvFILLp(ary) += diff;
2972 /* pull up or down? */
2974 if (offset < after) { /* easier to pull up */
2975 if (offset) { /* esp. if nothing to pull */
2976 src = &AvARRAY(ary)[offset-1];
2977 dst = src - diff; /* diff is negative */
2978 for (i = offset; i > 0; i--) /* can't trust Copy */
2982 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2986 if (after) { /* anything to pull down? */
2987 src = AvARRAY(ary) + offset + length;
2988 dst = src + diff; /* diff is negative */
2989 Move(src, dst, after, SV*);
2991 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2992 /* avoid later double free */
2996 dst[--i] = &PL_sv_undef;
2999 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3001 *dst = NEWSV(46, 0);
3002 sv_setsv(*dst++, *src++);
3004 Safefree(tmparyval);
3007 else { /* no, expanding (or same) */
3009 New(452, tmparyval, length, SV*); /* so remember deletion */
3010 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3013 if (diff > 0) { /* expanding */
3015 /* push up or down? */
3017 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3021 Move(src, dst, offset, SV*);
3023 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3025 AvFILLp(ary) += diff;
3028 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3029 av_extend(ary, AvFILLp(ary) + diff);
3030 AvFILLp(ary) += diff;
3033 dst = AvARRAY(ary) + AvFILLp(ary);
3035 for (i = after; i; i--) {
3042 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3043 *dst = NEWSV(46, 0);
3044 sv_setsv(*dst++, *src++);
3046 MARK = ORIGMARK + 1;
3047 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3049 Copy(tmparyval, MARK, length, SV*);
3051 EXTEND_MORTAL(length);
3052 for (i = length, dst = MARK; i; i--) {
3053 sv_2mortal(*dst); /* free them eventualy */
3057 Safefree(tmparyval);
3061 else if (length--) {
3062 *MARK = tmparyval[length];
3065 while (length-- > 0)
3066 SvREFCNT_dec(tmparyval[length]);
3068 Safefree(tmparyval);
3071 *MARK = &PL_sv_undef;
3079 djSP; dMARK; dORIGMARK; dTARGET;
3080 register AV *ary = (AV*)*++MARK;
3081 register SV *sv = &PL_sv_undef;
3084 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3085 *MARK-- = SvTIED_obj((SV*)ary, mg);
3089 call_method("PUSH",G_SCALAR|G_DISCARD);
3094 /* Why no pre-extend of ary here ? */
3095 for (++MARK; MARK <= SP; MARK++) {
3098 sv_setsv(sv, *MARK);
3103 PUSHi( AvFILL(ary) + 1 );
3111 SV *sv = av_pop(av);
3113 (void)sv_2mortal(sv);
3122 SV *sv = av_shift(av);
3127 (void)sv_2mortal(sv);
3134 djSP; dMARK; dORIGMARK; dTARGET;
3135 register AV *ary = (AV*)*++MARK;
3140 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3141 *MARK-- = SvTIED_obj((SV*)ary, mg);
3145 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3150 av_unshift(ary, SP - MARK);
3153 sv_setsv(sv, *++MARK);
3154 (void)av_store(ary, i++, sv);
3158 PUSHi( AvFILL(ary) + 1 );
3168 if (GIMME == G_ARRAY) {
3179 register char *down;
3185 do_join(TARG, &PL_sv_no, MARK, SP);
3187 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3188 up = SvPV_force(TARG, len);
3190 if (IN_UTF8) { /* first reverse each character */
3191 U8* s = (U8*)SvPVX(TARG);
3192 U8* send = (U8*)(s + len);
3201 down = (char*)(s - 1);
3202 if (s > send || !((*down & 0xc0) == 0x80)) {
3203 if (ckWARN_d(WARN_UTF8))
3204 Perl_warner(aTHX_ WARN_UTF8,
3205 "Malformed UTF-8 character");
3217 down = SvPVX(TARG) + len - 1;
3223 (void)SvPOK_only(TARG);
3232 S_mul128(pTHX_ SV *sv, U8 m)
3235 char *s = SvPV(sv, len);
3239 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3240 SV *tmpNew = newSVpvn("0000000000", 10);
3242 sv_catsv(tmpNew, sv);
3243 SvREFCNT_dec(sv); /* free old sv */
3248 while (!*t) /* trailing '\0'? */
3251 i = ((*t - '0') << 7) + m;
3252 *(t--) = '0' + (i % 10);
3258 /* Explosives and implosives. */
3260 #if 'I' == 73 && 'J' == 74
3261 /* On an ASCII/ISO kind of system */
3262 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3265 Some other sort of character set - use memchr() so we don't match
3268 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3276 I32 gimme = GIMME_V;
3280 register char *pat = SvPV(left, llen);
3281 register char *s = SvPV(right, rlen);
3282 char *strend = s + rlen;
3284 register char *patend = pat + llen;
3289 /* These must not be in registers: */
3306 register U32 culong;
3309 #ifdef PERL_NATINT_PACK
3310 int natint; /* native integer */
3311 int unatint; /* unsigned native integer */
3314 if (gimme != G_ARRAY) { /* arrange to do first one only */
3316 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3317 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3319 while (isDIGIT(*patend) || *patend == '*')
3325 while (pat < patend) {
3327 datumtype = *pat++ & 0xFF;
3328 #ifdef PERL_NATINT_PACK
3331 if (isSPACE(datumtype))
3334 char *natstr = "sSiIlL";
3336 if (strchr(natstr, datumtype)) {
3337 #ifdef PERL_NATINT_PACK
3343 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
3347 else if (*pat == '*') {
3348 len = strend - strbeg; /* long enough */
3351 else if (isDIGIT(*pat)) {
3353 while (isDIGIT(*pat)) {
3354 len = (len * 10) + (*pat++ - '0');
3356 Perl_croak(aTHX_ "Repeat count in unpack overflows");
3360 len = (datumtype != '@');
3363 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3364 case ',': /* grandfather in commas but with a warning */
3365 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3366 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3369 if (len == 1 && pat[-1] != '1')
3378 if (len > strend - strbeg)
3379 DIE(aTHX_ "@ outside of string");
3383 if (len > s - strbeg)
3384 DIE(aTHX_ "X outside of string");
3388 if (len > strend - s)
3389 DIE(aTHX_ "x outside of string");
3394 DIE(aTHX_ "# must follow a numeric type");
3395 if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
3396 DIE(aTHX_ "# must be followed by a, A or Z");
3399 pat++; /* ignore '*' for compatibility with pack */
3401 DIE(aTHX_ "# cannot take a count" );
3407 if (len > strend - s)
3410 goto uchar_checksum;
3411 sv = NEWSV(35, len);
3412 sv_setpvn(sv, s, len);
3414 if (datumtype == 'A' || datumtype == 'Z') {
3415 aptr = s; /* borrow register */
3416 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3421 else { /* 'A' strips both nulls and spaces */
3422 s = SvPVX(sv) + len - 1;
3423 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3427 SvCUR_set(sv, s - SvPVX(sv));
3428 s = aptr; /* unborrow register */
3430 XPUSHs(sv_2mortal(sv));
3434 if (pat[-1] == '*' || len > (strend - s) * 8)
3435 len = (strend - s) * 8;
3438 Newz(601, PL_bitcount, 256, char);
3439 for (bits = 1; bits < 256; bits++) {
3440 if (bits & 1) PL_bitcount[bits]++;
3441 if (bits & 2) PL_bitcount[bits]++;
3442 if (bits & 4) PL_bitcount[bits]++;
3443 if (bits & 8) PL_bitcount[bits]++;
3444 if (bits & 16) PL_bitcount[bits]++;
3445 if (bits & 32) PL_bitcount[bits]++;
3446 if (bits & 64) PL_bitcount[bits]++;
3447 if (bits & 128) PL_bitcount[bits]++;
3451 culong += PL_bitcount[*(unsigned char*)s++];
3456 if (datumtype == 'b') {
3458 if (bits & 1) culong++;
3464 if (bits & 128) culong++;
3471 sv = NEWSV(35, len + 1);
3474 aptr = pat; /* borrow register */
3476 if (datumtype == 'b') {
3478 for (len = 0; len < aint; len++) {
3479 if (len & 7) /*SUPPRESS 595*/
3483 *pat++ = '0' + (bits & 1);
3488 for (len = 0; len < aint; len++) {
3493 *pat++ = '0' + ((bits & 128) != 0);
3497 pat = aptr; /* unborrow register */
3498 XPUSHs(sv_2mortal(sv));
3502 if (pat[-1] == '*' || len > (strend - s) * 2)
3503 len = (strend - s) * 2;
3504 sv = NEWSV(35, len + 1);
3507 aptr = pat; /* borrow register */
3509 if (datumtype == 'h') {
3511 for (len = 0; len < aint; len++) {
3516 *pat++ = PL_hexdigit[bits & 15];
3521 for (len = 0; len < aint; len++) {
3526 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3530 pat = aptr; /* unborrow register */
3531 XPUSHs(sv_2mortal(sv));
3534 if (len > strend - s)
3539 if (aint >= 128) /* fake up signed chars */
3549 if (aint >= 128) /* fake up signed chars */
3552 sv_setiv(sv, (IV)aint);
3553 PUSHs(sv_2mortal(sv));
3558 if (len > strend - s)
3573 sv_setiv(sv, (IV)auint);
3574 PUSHs(sv_2mortal(sv));
3579 if (len > strend - s)
3582 while (len-- > 0 && s < strend) {
3583 auint = utf8_to_uv((U8*)s, &along);
3586 cdouble += (NV)auint;
3594 while (len-- > 0 && s < strend) {
3595 auint = utf8_to_uv((U8*)s, &along);
3598 sv_setuv(sv, (UV)auint);
3599 PUSHs(sv_2mortal(sv));
3604 #if SHORTSIZE == SIZE16
3605 along = (strend - s) / SIZE16;
3607 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3612 #if SHORTSIZE != SIZE16
3616 COPYNN(s, &ashort, sizeof(short));
3627 #if SHORTSIZE > SIZE16
3639 #if SHORTSIZE != SIZE16
3643 COPYNN(s, &ashort, sizeof(short));
3646 sv_setiv(sv, (IV)ashort);
3647 PUSHs(sv_2mortal(sv));
3655 #if SHORTSIZE > SIZE16
3661 sv_setiv(sv, (IV)ashort);
3662 PUSHs(sv_2mortal(sv));
3670 #if SHORTSIZE == SIZE16
3671 along = (strend - s) / SIZE16;
3673 unatint = natint && datumtype == 'S';
3674 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3679 #if SHORTSIZE != SIZE16
3681 unsigned short aushort;
3683 COPYNN(s, &aushort, sizeof(unsigned short));
3684 s += sizeof(unsigned short);
3692 COPY16(s, &aushort);
3695 if (datumtype == 'n')
3696 aushort = PerlSock_ntohs(aushort);
3699 if (datumtype == 'v')
3700 aushort = vtohs(aushort);
3709 #if SHORTSIZE != SIZE16
3711 unsigned short aushort;
3713 COPYNN(s, &aushort, sizeof(unsigned short));
3714 s += sizeof(unsigned short);
3716 sv_setiv(sv, (UV)aushort);
3717 PUSHs(sv_2mortal(sv));
3724 COPY16(s, &aushort);
3728 if (datumtype == 'n')
3729 aushort = PerlSock_ntohs(aushort);
3732 if (datumtype == 'v')
3733 aushort = vtohs(aushort);
3735 sv_setiv(sv, (UV)aushort);
3736 PUSHs(sv_2mortal(sv));
3742 along = (strend - s) / sizeof(int);
3747 Copy(s, &aint, 1, int);
3750 cdouble += (NV)aint;
3759 Copy(s, &aint, 1, int);
3763 /* Without the dummy below unpack("i", pack("i",-1))
3764 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3765 * cc with optimization turned on.
3767 * The bug was detected in
3768 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3769 * with optimization (-O4) turned on.
3770 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3771 * does not have this problem even with -O4.
3773 * This bug was reported as DECC_BUGS 1431
3774 * and tracked internally as GEM_BUGS 7775.
3776 * The bug is fixed in
3777 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3778 * UNIX V4.0F support: DEC C V5.9-006 or later
3779 * UNIX V4.0E support: DEC C V5.8-011 or later
3782 * See also few lines later for the same bug.
3785 sv_setiv(sv, (IV)aint) :
3787 sv_setiv(sv, (IV)aint);
3788 PUSHs(sv_2mortal(sv));
3793 along = (strend - s) / sizeof(unsigned int);
3798 Copy(s, &auint, 1, unsigned int);
3799 s += sizeof(unsigned int);
3801 cdouble += (NV)auint;
3810 Copy(s, &auint, 1, unsigned int);
3811 s += sizeof(unsigned int);
3814 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3815 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3816 * See details few lines earlier. */
3818 sv_setuv(sv, (UV)auint) :
3820 sv_setuv(sv, (UV)auint);
3821 PUSHs(sv_2mortal(sv));
3826 #if LONGSIZE == SIZE32
3827 along = (strend - s) / SIZE32;
3829 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3834 #if LONGSIZE != SIZE32
3838 COPYNN(s, &along, sizeof(long));
3841 cdouble += (NV)along;
3851 #if LONGSIZE > SIZE32
3852 if (along > 2147483647)
3853 along -= 4294967296;
3857 cdouble += (NV)along;
3866 #if LONGSIZE != SIZE32
3870 COPYNN(s, &along, sizeof(long));
3873 sv_setiv(sv, (IV)along);
3874 PUSHs(sv_2mortal(sv));
3882 #if LONGSIZE > SIZE32
3883 if (along > 2147483647)
3884 along -= 4294967296;
3888 sv_setiv(sv, (IV)along);
3889 PUSHs(sv_2mortal(sv));
3897 #if LONGSIZE == SIZE32
3898 along = (strend - s) / SIZE32;
3900 unatint = natint && datumtype == 'L';
3901 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3906 #if LONGSIZE != SIZE32
3908 unsigned long aulong;
3910 COPYNN(s, &aulong, sizeof(unsigned long));
3911 s += sizeof(unsigned long);
3913 cdouble += (NV)aulong;
3925 if (datumtype == 'N')
3926 aulong = PerlSock_ntohl(aulong);
3929 if (datumtype == 'V')
3930 aulong = vtohl(aulong);
3933 cdouble += (NV)aulong;
3942 #if LONGSIZE != SIZE32
3944 unsigned long aulong;
3946 COPYNN(s, &aulong, sizeof(unsigned long));
3947 s += sizeof(unsigned long);
3949 sv_setuv(sv, (UV)aulong);
3950 PUSHs(sv_2mortal(sv));
3960 if (datumtype == 'N')
3961 aulong = PerlSock_ntohl(aulong);
3964 if (datumtype == 'V')
3965 aulong = vtohl(aulong);
3968 sv_setuv(sv, (UV)aulong);
3969 PUSHs(sv_2mortal(sv));
3975 along = (strend - s) / sizeof(char*);
3981 if (sizeof(char*) > strend - s)
3984 Copy(s, &aptr, 1, char*);
3990 PUSHs(sv_2mortal(sv));
4000 while ((len > 0) && (s < strend)) {
4001 auv = (auv << 7) | (*s & 0x7f);
4002 if (!(*s++ & 0x80)) {
4006 PUSHs(sv_2mortal(sv));
4010 else if (++bytes >= sizeof(UV)) { /* promote to string */
4014 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4015 while (s < strend) {
4016 sv = mul128(sv, *s & 0x7f);
4017 if (!(*s++ & 0x80)) {
4026 PUSHs(sv_2mortal(sv));
4031 if ((s >= strend) && bytes)
4032 Perl_croak(aTHX_ "Unterminated compressed integer");
4037 if (sizeof(char*) > strend - s)
4040 Copy(s, &aptr, 1, char*);
4045 sv_setpvn(sv, aptr, len);
4046 PUSHs(sv_2mortal(sv));
4050 along = (strend - s) / sizeof(Quad_t);
4056 if (s + sizeof(Quad_t) > strend)
4059 Copy(s, &aquad, 1, Quad_t);
4060 s += sizeof(Quad_t);
4063 if (aquad >= IV_MIN && aquad <= IV_MAX)
4064 sv_setiv(sv, (IV)aquad);
4066 sv_setnv(sv, (NV)aquad);
4067 PUSHs(sv_2mortal(sv));
4071 along = (strend - s) / sizeof(Quad_t);
4077 if (s + sizeof(Uquad_t) > strend)
4080 Copy(s, &auquad, 1, Uquad_t);
4081 s += sizeof(Uquad_t);
4084 if (auquad <= UV_MAX)
4085 sv_setuv(sv, (UV)auquad);
4087 sv_setnv(sv, (NV)auquad);
4088 PUSHs(sv_2mortal(sv));
4092 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4095 along = (strend - s) / sizeof(float);
4100 Copy(s, &afloat, 1, float);
4109 Copy(s, &afloat, 1, float);
4112 sv_setnv(sv, (NV)afloat);
4113 PUSHs(sv_2mortal(sv));
4119 along = (strend - s) / sizeof(double);
4124 Copy(s, &adouble, 1, double);
4125 s += sizeof(double);
4133 Copy(s, &adouble, 1, double);
4134 s += sizeof(double);
4136 sv_setnv(sv, (NV)adouble);
4137 PUSHs(sv_2mortal(sv));
4143 * Initialise the decode mapping. By using a table driven
4144 * algorithm, the code will be character-set independent
4145 * (and just as fast as doing character arithmetic)
4147 if (PL_uudmap['M'] == 0) {
4150 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4151 PL_uudmap[PL_uuemap[i]] = i;
4153 * Because ' ' and '`' map to the same value,
4154 * we need to decode them both the same.
4159 along = (strend - s) * 3 / 4;
4160 sv = NEWSV(42, along);
4163 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4168 len = PL_uudmap[*s++] & 077;
4170 if (s < strend && ISUUCHAR(*s))
4171 a = PL_uudmap[*s++] & 077;
4174 if (s < strend && ISUUCHAR(*s))
4175 b = PL_uudmap[*s++] & 077;
4178 if (s < strend && ISUUCHAR(*s))
4179 c = PL_uudmap[*s++] & 077;
4182 if (s < strend && ISUUCHAR(*s))
4183 d = PL_uudmap[*s++] & 077;
4186 hunk[0] = (a << 2) | (b >> 4);
4187 hunk[1] = (b << 4) | (c >> 2);
4188 hunk[2] = (c << 6) | d;
4189 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4194 else if (s[1] == '\n') /* possible checksum byte */
4197 XPUSHs(sv_2mortal(sv));
4202 if (strchr("fFdD", datumtype) ||
4203 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4207 while (checksum >= 16) {
4211 while (checksum >= 4) {
4217 along = (1 << checksum) - 1;
4218 while (cdouble < 0.0)
4220 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4221 sv_setnv(sv, cdouble);
4224 if (checksum < 32) {
4225 aulong = (1 << checksum) - 1;
4228 sv_setuv(sv, (UV)culong);
4230 XPUSHs(sv_2mortal(sv));
4234 if (SP == oldsp && gimme == G_SCALAR)
4235 PUSHs(&PL_sv_undef);
4240 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4244 *hunk = PL_uuemap[len];
4245 sv_catpvn(sv, hunk, 1);
4248 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4249 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4250 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4251 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4252 sv_catpvn(sv, hunk, 4);
4257 char r = (len > 1 ? s[1] : '\0');
4258 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4259 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4260 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4261 hunk[3] = PL_uuemap[0];
4262 sv_catpvn(sv, hunk, 4);
4264 sv_catpvn(sv, "\n", 1);
4268 S_is_an_int(pTHX_ char *s, STRLEN l)
4271 SV *result = newSVpvn(s, l);
4272 char *result_c = SvPV(result, n_a); /* convenience */
4273 char *out = result_c;
4283 SvREFCNT_dec(result);
4306 SvREFCNT_dec(result);
4312 SvCUR_set(result, out - result_c);
4316 /* pnum must be '\0' terminated */
4318 S_div128(pTHX_ SV *pnum, bool *done)
4321 char *s = SvPV(pnum, len);
4330 i = m * 10 + (*t - '0');
4332 r = (i >> 7); /* r < 10 */
4339 SvCUR_set(pnum, (STRLEN) (t - s));
4346 djSP; dMARK; dORIGMARK; dTARGET;
4347 register SV *cat = TARG;
4350 register char *pat = SvPVx(*++MARK, fromlen);
4351 register char *patend = pat + fromlen;
4356 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4357 static char *space10 = " ";
4359 /* These must not be in registers: */
4374 #ifdef PERL_NATINT_PACK
4375 int natint; /* native integer */
4380 sv_setpvn(cat, "", 0);
4381 while (pat < patend) {
4382 SV *lengthcode = Nullsv;
4383 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4384 datumtype = *pat++ & 0xFF;
4385 #ifdef PERL_NATINT_PACK
4388 if (isSPACE(datumtype))
4391 char *natstr = "sSiIlL";
4393 if (strchr(natstr, datumtype)) {
4394 #ifdef PERL_NATINT_PACK
4400 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
4403 len = strchr("@Xxu", datumtype) ? 0 : items;
4406 else if (isDIGIT(*pat)) {
4408 while (isDIGIT(*pat)) {
4409 len = (len * 10) + (*pat++ - '0');
4411 Perl_croak(aTHX_ "Repeat count in pack overflows");
4418 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4419 DIE(aTHX_ "# must be followed by a*, A* or Z*");
4420 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4421 ? *MARK : &PL_sv_no)));
4425 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4426 case ',': /* grandfather in commas but with a warning */
4427 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4428 Perl_warner(aTHX_ WARN_UNSAFE,
4429 "Invalid type in pack: '%c'", (int)datumtype);
4432 DIE(aTHX_ "%% may only be used in unpack");
4443 if (SvCUR(cat) < len)
4444 DIE(aTHX_ "X outside of string");
4451 sv_catpvn(cat, null10, 10);
4454 sv_catpvn(cat, null10, len);
4460 aptr = SvPV(fromstr, fromlen);
4464 sv_catpvn(cat, aptr, len);
4466 sv_catpvn(cat, aptr, fromlen);
4468 if (datumtype == 'A') {
4470 sv_catpvn(cat, space10, 10);
4473 sv_catpvn(cat, space10, len);
4477 sv_catpvn(cat, null10, 10);
4480 sv_catpvn(cat, null10, len);
4487 char *savepat = pat;
4492 aptr = SvPV(fromstr, fromlen);
4497 SvCUR(cat) += (len+7)/8;
4498 SvGROW(cat, SvCUR(cat) + 1);
4499 aptr = SvPVX(cat) + aint;
4504 if (datumtype == 'B') {
4505 for (len = 0; len++ < aint;) {
4506 items |= *pat++ & 1;
4510 *aptr++ = items & 0xff;
4516 for (len = 0; len++ < aint;) {
4522 *aptr++ = items & 0xff;
4528 if (datumtype == 'B')
4529 items <<= 7 - (aint & 7);
4531 items >>= 7 - (aint & 7);
4532 *aptr++ = items & 0xff;
4534 pat = SvPVX(cat) + SvCUR(cat);
4545 char *savepat = pat;
4550 aptr = SvPV(fromstr, fromlen);
4555 SvCUR(cat) += (len+1)/2;
4556 SvGROW(cat, SvCUR(cat) + 1);
4557 aptr = SvPVX(cat) + aint;
4562 if (datumtype == 'H') {
4563 for (len = 0; len++ < aint;) {
4565 items |= ((*pat++ & 15) + 9) & 15;
4567 items |= *pat++ & 15;
4571 *aptr++ = items & 0xff;
4577 for (len = 0; len++ < aint;) {
4579 items |= (((*pat++ & 15) + 9) & 15) << 4;
4581 items |= (*pat++ & 15) << 4;
4585 *aptr++ = items & 0xff;
4591 *aptr++ = items & 0xff;
4592 pat = SvPVX(cat) + SvCUR(cat);
4604 aint = SvIV(fromstr);
4606 sv_catpvn(cat, &achar, sizeof(char));
4612 auint = SvUV(fromstr);
4613 SvGROW(cat, SvCUR(cat) + 10);
4614 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4619 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4624 afloat = (float)SvNV(fromstr);
4625 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4632 adouble = (double)SvNV(fromstr);
4633 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4639 ashort = (I16)SvIV(fromstr);
4641 ashort = PerlSock_htons(ashort);
4643 CAT16(cat, &ashort);
4649 ashort = (I16)SvIV(fromstr);
4651 ashort = htovs(ashort);
4653 CAT16(cat, &ashort);
4657 #if SHORTSIZE != SIZE16
4659 unsigned short aushort;
4663 aushort = SvUV(fromstr);
4664 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4674 aushort = (U16)SvUV(fromstr);
4675 CAT16(cat, &aushort);
4681 #if SHORTSIZE != SIZE16
4687 ashort = SvIV(fromstr);
4688 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4696 ashort = (I16)SvIV(fromstr);
4697 CAT16(cat, &ashort);
4704 auint = SvUV(fromstr);
4705 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4711 adouble = Perl_floor(SvNV(fromstr));
4714 Perl_croak(aTHX_ "Cannot compress negative numbers");
4720 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4721 adouble <= UV_MAX_cxux
4728 char buf[1 + sizeof(UV)];
4729 char *in = buf + sizeof(buf);
4730 UV auv = U_V(adouble);
4733 *--in = (auv & 0x7f) | 0x80;
4736 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4737 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4739 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4740 char *from, *result, *in;
4745 /* Copy string and check for compliance */
4746 from = SvPV(fromstr, len);
4747 if ((norm = is_an_int(from, len)) == NULL)
4748 Perl_croak(aTHX_ "can compress only unsigned integer");
4750 New('w', result, len, char);
4754 *--in = div128(norm, &done) | 0x80;
4755 result[len - 1] &= 0x7F; /* clear continue bit */
4756 sv_catpvn(cat, in, (result + len) - in);
4758 SvREFCNT_dec(norm); /* free norm */
4760 else if (SvNOKp(fromstr)) {
4761 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4762 char *in = buf + sizeof(buf);
4765 double next = floor(adouble / 128);
4766 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4767 if (--in < buf) /* this cannot happen ;-) */
4768 Perl_croak(aTHX_ "Cannot compress integer");
4770 } while (adouble > 0);
4771 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4772 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4775 Perl_croak(aTHX_ "Cannot compress non integer");
4781 aint = SvIV(fromstr);
4782 sv_catpvn(cat, (char*)&aint, sizeof(int));
4788 aulong = SvUV(fromstr);
4790 aulong = PerlSock_htonl(aulong);
4792 CAT32(cat, &aulong);
4798 aulong = SvUV(fromstr);
4800 aulong = htovl(aulong);
4802 CAT32(cat, &aulong);
4806 #if LONGSIZE != SIZE32
4808 unsigned long aulong;
4812 aulong = SvUV(fromstr);
4813 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4821 aulong = SvUV(fromstr);
4822 CAT32(cat, &aulong);
4827 #if LONGSIZE != SIZE32
4833 along = SvIV(fromstr);
4834 sv_catpvn(cat, (char *)&along, sizeof(long));
4842 along = SvIV(fromstr);
4851 auquad = (Uquad_t)SvUV(fromstr);
4852 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4858 aquad = (Quad_t)SvIV(fromstr);
4859 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4862 #endif /* HAS_QUAD */
4864 len = 1; /* assume SV is correct length */
4869 if (fromstr == &PL_sv_undef)
4873 /* XXX better yet, could spirit away the string to
4874 * a safe spot and hang on to it until the result
4875 * of pack() (and all copies of the result) are
4878 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4879 Perl_warner(aTHX_ WARN_UNSAFE,
4880 "Attempt to pack pointer to temporary value");
4881 if (SvPOK(fromstr) || SvNIOK(fromstr))
4882 aptr = SvPV(fromstr,n_a);
4884 aptr = SvPV_force(fromstr,n_a);
4886 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4891 aptr = SvPV(fromstr, fromlen);
4892 SvGROW(cat, fromlen * 4 / 3);
4897 while (fromlen > 0) {
4904 doencodes(cat, aptr, todo);
4923 register I32 limit = POPi; /* note, negative is forever */
4926 register char *s = SvPV(sv, len);
4927 char *strend = s + len;
4929 register REGEXP *rx;
4933 I32 maxiters = (strend - s) + 10;
4936 I32 origlimit = limit;
4939 AV *oldstack = PL_curstack;
4940 I32 gimme = GIMME_V;
4941 I32 oldsave = PL_savestack_ix;
4942 I32 make_mortal = 1;
4943 MAGIC *mg = (MAGIC *) NULL;
4946 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4951 DIE(aTHX_ "panic: do_split");
4952 rx = pm->op_pmregexp;
4954 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4955 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4957 if (pm->op_pmreplroot)
4958 ary = GvAVn((GV*)pm->op_pmreplroot);
4959 else if (gimme != G_ARRAY)
4961 ary = (AV*)PL_curpad[0];
4963 ary = GvAVn(PL_defgv);
4964 #endif /* USE_THREADS */
4967 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4973 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4975 XPUSHs(SvTIED_obj((SV*)ary, mg));
4980 for (i = AvFILLp(ary); i >= 0; i--)
4981 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4983 /* temporarily switch stacks */
4984 SWITCHSTACK(PL_curstack, ary);
4988 base = SP - PL_stack_base;
4990 if (pm->op_pmflags & PMf_SKIPWHITE) {
4991 if (pm->op_pmflags & PMf_LOCALE) {
4992 while (isSPACE_LC(*s))
5000 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5001 SAVEINT(PL_multiline);
5002 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5006 limit = maxiters + 2;
5007 if (pm->op_pmflags & PMf_WHITE) {
5010 while (m < strend &&
5011 !((pm->op_pmflags & PMf_LOCALE)
5012 ? isSPACE_LC(*m) : isSPACE(*m)))
5017 dstr = NEWSV(30, m-s);
5018 sv_setpvn(dstr, s, m-s);
5024 while (s < strend &&
5025 ((pm->op_pmflags & PMf_LOCALE)
5026 ? isSPACE_LC(*s) : isSPACE(*s)))
5030 else if (rx->prelen == 1 && *rx->precomp == '^') {
5031 if (!(pm->op_pmflags & PMf_MULTILINE)
5032 && !(pm->op_pmregexp->reganch & ROPT_WARNED)) {
5033 if (ckWARN(WARN_DEPRECATED))
5034 Perl_warner(aTHX_ WARN_DEPRECATED,
5035 "split /^/ better written as split /^/m");
5036 pm->op_pmregexp->reganch |= ROPT_WARNED;
5040 for (m = s; m < strend && *m != '\n'; m++) ;
5044 dstr = NEWSV(30, m-s);
5045 sv_setpvn(dstr, s, m-s);
5052 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5053 && (rx->reganch & ROPT_CHECK_ALL)
5054 && !(rx->reganch & ROPT_ANCH)) {
5055 int tail = (rx->reganch & RE_INTUIT_TAIL);
5056 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5060 if (len == 1 && !tail) {
5064 for (m = s; m < strend && *m != c; m++) ;
5067 dstr = NEWSV(30, m-s);
5068 sv_setpvn(dstr, s, m-s);
5077 while (s < strend && --limit &&
5078 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5079 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5082 dstr = NEWSV(31, m-s);
5083 sv_setpvn(dstr, s, m-s);
5087 s = m + len; /* Fake \n at the end */
5092 maxiters += (strend - s) * rx->nparens;
5093 while (s < strend && --limit
5094 /* && (!rx->check_substr
5095 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5097 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5098 1 /* minend */, sv, NULL, 0))
5100 TAINT_IF(RX_MATCH_TAINTED(rx));
5101 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5106 strend = s + (strend - m);
5108 m = rx->startp[0] + orig;
5109 dstr = NEWSV(32, m-s);
5110 sv_setpvn(dstr, s, m-s);
5115 for (i = 1; i <= rx->nparens; i++) {
5116 s = rx->startp[i] + orig;
5117 m = rx->endp[i] + orig;
5119 dstr = NEWSV(33, m-s);
5120 sv_setpvn(dstr, s, m-s);
5123 dstr = NEWSV(33, 0);
5129 s = rx->endp[0] + orig;
5133 LEAVE_SCOPE(oldsave);
5134 iters = (SP - PL_stack_base) - base;
5135 if (iters > maxiters)
5136 DIE(aTHX_ "Split loop");
5138 /* keep field after final delim? */
5139 if (s < strend || (iters && origlimit)) {
5140 dstr = NEWSV(34, strend-s);
5141 sv_setpvn(dstr, s, strend-s);
5147 else if (!origlimit) {
5148 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5154 SWITCHSTACK(ary, oldstack);
5155 if (SvSMAGICAL(ary)) {
5160 if (gimme == G_ARRAY) {
5162 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5170 call_method("PUSH",G_SCALAR|G_DISCARD);
5173 if (gimme == G_ARRAY) {
5174 /* EXTEND should not be needed - we just popped them */
5176 for (i=0; i < iters; i++) {
5177 SV **svp = av_fetch(ary, i, FALSE);
5178 PUSHs((svp) ? *svp : &PL_sv_undef);
5185 if (gimme == G_ARRAY)
5188 if (iters || !pm->op_pmreplroot) {
5198 Perl_unlock_condpair(pTHX_ void *svv)
5201 MAGIC *mg = mg_find((SV*)svv, 'm');
5204 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5205 MUTEX_LOCK(MgMUTEXP(mg));
5206 if (MgOWNER(mg) != thr)
5207 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5209 COND_SIGNAL(MgOWNERCONDP(mg));
5210 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5211 (unsigned long)thr, (unsigned long)svv);)
5212 MUTEX_UNLOCK(MgMUTEXP(mg));
5214 #endif /* USE_THREADS */
5227 mg = condpair_magic(sv);
5228 MUTEX_LOCK(MgMUTEXP(mg));
5229 if (MgOWNER(mg) == thr)
5230 MUTEX_UNLOCK(MgMUTEXP(mg));
5233 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5235 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5236 (unsigned long)thr, (unsigned long)sv);)
5237 MUTEX_UNLOCK(MgMUTEXP(mg));
5238 SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
5240 #endif /* USE_THREADS */
5241 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5242 || SvTYPE(retsv) == SVt_PVCV) {
5243 retsv = refto(retsv);
5254 if (PL_op->op_private & OPpLVAL_INTRO)
5255 PUSHs(*save_threadsv(PL_op->op_targ));
5257 PUSHs(THREADSV(PL_op->op_targ));
5260 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5261 #endif /* USE_THREADS */