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 XPUSHu(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);
2312 if (!SvPADTMP(sv)) {
2318 s = (U8*)SvPV_force(sv, slen);
2320 if (PL_op->op_private & OPpLOCALE) {
2323 *s = toUPPER_LC(*s);
2341 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2345 UV uv = utf8_to_uv(s, &ulen);
2347 if (PL_op->op_private & OPpLOCALE) {
2350 uv = toLOWER_LC_uni(uv);
2353 uv = toLOWER_utf8(s);
2355 tend = uv_to_utf8(tmpbuf, uv);
2357 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2359 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2360 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2364 s = (U8*)SvPV_force(sv, slen);
2365 Copy(tmpbuf, s, ulen, U8);
2368 if (!SvPADTMP(sv)) {
2374 s = (U8*)SvPV_force(sv, slen);
2376 if (PL_op->op_private & OPpLOCALE) {
2379 *s = toLOWER_LC(*s);
2404 s = (U8*)SvPV(sv,len);
2406 sv_setpvn(TARG, "", 0);
2409 (void)SvUPGRADE(TARG, SVt_PV);
2410 SvGROW(TARG, (len * 2) + 1);
2411 (void)SvPOK_only(TARG);
2412 d = (U8*)SvPVX(TARG);
2414 if (PL_op->op_private & OPpLOCALE) {
2418 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2424 d = uv_to_utf8(d, toUPPER_utf8( s ));
2429 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2433 if (!SvPADTMP(sv)) {
2439 s = (U8*)SvPV_force(sv, len);
2441 register U8 *send = s + len;
2443 if (PL_op->op_private & OPpLOCALE) {
2446 for (; s < send; s++)
2447 *s = toUPPER_LC(*s);
2450 for (; s < send; s++)
2473 s = (U8*)SvPV(sv,len);
2475 sv_setpvn(TARG, "", 0);
2478 (void)SvUPGRADE(TARG, SVt_PV);
2479 SvGROW(TARG, (len * 2) + 1);
2480 (void)SvPOK_only(TARG);
2481 d = (U8*)SvPVX(TARG);
2483 if (PL_op->op_private & OPpLOCALE) {
2487 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2493 d = uv_to_utf8(d, toLOWER_utf8(s));
2498 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2502 if (!SvPADTMP(sv)) {
2509 s = (U8*)SvPV_force(sv, len);
2511 register U8 *send = s + len;
2513 if (PL_op->op_private & OPpLOCALE) {
2516 for (; s < send; s++)
2517 *s = toLOWER_LC(*s);
2520 for (; s < send; s++)
2535 register char *s = SvPV(sv,len);
2539 (void)SvUPGRADE(TARG, SVt_PV);
2540 SvGROW(TARG, (len * 2) + 1);
2545 STRLEN ulen = UTF8SKIP(s);
2568 SvCUR_set(TARG, d - SvPVX(TARG));
2569 (void)SvPOK_only(TARG);
2572 sv_setpvn(TARG, s, len);
2574 if (SvSMAGICAL(TARG))
2583 djSP; dMARK; dORIGMARK;
2585 register AV* av = (AV*)POPs;
2586 register I32 lval = PL_op->op_flags & OPf_MOD;
2587 I32 arybase = PL_curcop->cop_arybase;
2590 if (SvTYPE(av) == SVt_PVAV) {
2591 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2593 for (svp = MARK + 1; svp <= SP; svp++) {
2598 if (max > AvMAX(av))
2601 while (++MARK <= SP) {
2602 elem = SvIVx(*MARK);
2606 svp = av_fetch(av, elem, lval);
2608 if (!svp || *svp == &PL_sv_undef)
2609 DIE(aTHX_ PL_no_aelem, elem);
2610 if (PL_op->op_private & OPpLVAL_INTRO)
2611 save_aelem(av, elem, svp);
2613 *MARK = svp ? *svp : &PL_sv_undef;
2616 if (GIMME != G_ARRAY) {
2624 /* Associative arrays. */
2629 HV *hash = (HV*)POPs;
2631 I32 gimme = GIMME_V;
2632 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2635 /* might clobber stack_sp */
2636 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2641 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2642 if (gimme == G_ARRAY) {
2644 /* might clobber stack_sp */
2645 sv_setsv(TARG, realhv ?
2646 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2651 else if (gimme == G_SCALAR)
2670 I32 gimme = GIMME_V;
2671 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2675 if (PL_op->op_private & OPpSLICE) {
2679 hvtype = SvTYPE(hv);
2680 while (++MARK <= SP) {
2681 if (hvtype == SVt_PVHV)
2682 sv = hv_delete_ent(hv, *MARK, discard, 0);
2684 DIE(aTHX_ "Not a HASH reference");
2685 *MARK = sv ? sv : &PL_sv_undef;
2689 else if (gimme == G_SCALAR) {
2698 if (SvTYPE(hv) == SVt_PVHV)
2699 sv = hv_delete_ent(hv, keysv, discard, 0);
2701 DIE(aTHX_ "Not a HASH reference");
2715 if (SvTYPE(hv) == SVt_PVHV) {
2716 if (hv_exists_ent(hv, tmpsv, 0))
2719 else if (SvTYPE(hv) == SVt_PVAV) {
2720 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2724 DIE(aTHX_ "Not a HASH reference");
2731 djSP; dMARK; dORIGMARK;
2732 register HV *hv = (HV*)POPs;
2733 register I32 lval = PL_op->op_flags & OPf_MOD;
2734 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2736 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2737 DIE(aTHX_ "Can't localize pseudo-hash element");
2739 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2740 while (++MARK <= SP) {
2744 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2745 svp = he ? &HeVAL(he) : 0;
2748 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2751 if (!svp || *svp == &PL_sv_undef) {
2753 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2755 if (PL_op->op_private & OPpLVAL_INTRO)
2756 save_helem(hv, keysv, svp);
2758 *MARK = svp ? *svp : &PL_sv_undef;
2761 if (GIMME != G_ARRAY) {
2769 /* List operators. */
2774 if (GIMME != G_ARRAY) {
2776 *MARK = *SP; /* unwanted list, return last item */
2778 *MARK = &PL_sv_undef;
2787 SV **lastrelem = PL_stack_sp;
2788 SV **lastlelem = PL_stack_base + POPMARK;
2789 SV **firstlelem = PL_stack_base + POPMARK + 1;
2790 register SV **firstrelem = lastlelem + 1;
2791 I32 arybase = PL_curcop->cop_arybase;
2792 I32 lval = PL_op->op_flags & OPf_MOD;
2793 I32 is_something_there = lval;
2795 register I32 max = lastrelem - lastlelem;
2796 register SV **lelem;
2799 if (GIMME != G_ARRAY) {
2800 ix = SvIVx(*lastlelem);
2805 if (ix < 0 || ix >= max)
2806 *firstlelem = &PL_sv_undef;
2808 *firstlelem = firstrelem[ix];
2814 SP = firstlelem - 1;
2818 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2824 if (ix < 0 || ix >= max)
2825 *lelem = &PL_sv_undef;
2827 is_something_there = TRUE;
2828 if (!(*lelem = firstrelem[ix]))
2829 *lelem = &PL_sv_undef;
2832 if (is_something_there)
2835 SP = firstlelem - 1;
2841 djSP; dMARK; dORIGMARK;
2842 I32 items = SP - MARK;
2843 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2844 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2851 djSP; dMARK; dORIGMARK;
2852 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2856 SV *val = NEWSV(46, 0);
2858 sv_setsv(val, *++MARK);
2859 else if (ckWARN(WARN_UNSAFE))
2860 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2861 (void)hv_store_ent(hv,key,val,0);
2870 djSP; dMARK; dORIGMARK;
2871 register AV *ary = (AV*)*++MARK;
2875 register I32 offset;
2876 register I32 length;
2883 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2884 *MARK-- = SvTIED_obj((SV*)ary, mg);
2888 call_method("SPLICE",GIMME_V);
2897 offset = i = SvIVx(*MARK);
2899 offset += AvFILLp(ary) + 1;
2901 offset -= PL_curcop->cop_arybase;
2903 DIE(aTHX_ PL_no_aelem, i);
2905 length = SvIVx(*MARK++);
2907 length += AvFILLp(ary) - offset + 1;
2913 length = AvMAX(ary) + 1; /* close enough to infinity */
2917 length = AvMAX(ary) + 1;
2919 if (offset > AvFILLp(ary) + 1)
2920 offset = AvFILLp(ary) + 1;
2921 after = AvFILLp(ary) + 1 - (offset + length);
2922 if (after < 0) { /* not that much array */
2923 length += after; /* offset+length now in array */
2929 /* At this point, MARK .. SP-1 is our new LIST */
2932 diff = newlen - length;
2933 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2936 if (diff < 0) { /* shrinking the area */
2938 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2939 Copy(MARK, tmparyval, newlen, SV*);
2942 MARK = ORIGMARK + 1;
2943 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2944 MEXTEND(MARK, length);
2945 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2947 EXTEND_MORTAL(length);
2948 for (i = length, dst = MARK; i; i--) {
2949 sv_2mortal(*dst); /* free them eventualy */
2956 *MARK = AvARRAY(ary)[offset+length-1];
2959 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2960 SvREFCNT_dec(*dst++); /* free them now */
2963 AvFILLp(ary) += diff;
2965 /* pull up or down? */
2967 if (offset < after) { /* easier to pull up */
2968 if (offset) { /* esp. if nothing to pull */
2969 src = &AvARRAY(ary)[offset-1];
2970 dst = src - diff; /* diff is negative */
2971 for (i = offset; i > 0; i--) /* can't trust Copy */
2975 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2979 if (after) { /* anything to pull down? */
2980 src = AvARRAY(ary) + offset + length;
2981 dst = src + diff; /* diff is negative */
2982 Move(src, dst, after, SV*);
2984 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2985 /* avoid later double free */
2989 dst[--i] = &PL_sv_undef;
2992 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2994 *dst = NEWSV(46, 0);
2995 sv_setsv(*dst++, *src++);
2997 Safefree(tmparyval);
3000 else { /* no, expanding (or same) */
3002 New(452, tmparyval, length, SV*); /* so remember deletion */
3003 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3006 if (diff > 0) { /* expanding */
3008 /* push up or down? */
3010 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3014 Move(src, dst, offset, SV*);
3016 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3018 AvFILLp(ary) += diff;
3021 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3022 av_extend(ary, AvFILLp(ary) + diff);
3023 AvFILLp(ary) += diff;
3026 dst = AvARRAY(ary) + AvFILLp(ary);
3028 for (i = after; i; i--) {
3035 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3036 *dst = NEWSV(46, 0);
3037 sv_setsv(*dst++, *src++);
3039 MARK = ORIGMARK + 1;
3040 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3042 Copy(tmparyval, MARK, length, SV*);
3044 EXTEND_MORTAL(length);
3045 for (i = length, dst = MARK; i; i--) {
3046 sv_2mortal(*dst); /* free them eventualy */
3050 Safefree(tmparyval);
3054 else if (length--) {
3055 *MARK = tmparyval[length];
3058 while (length-- > 0)
3059 SvREFCNT_dec(tmparyval[length]);
3061 Safefree(tmparyval);
3064 *MARK = &PL_sv_undef;
3072 djSP; dMARK; dORIGMARK; dTARGET;
3073 register AV *ary = (AV*)*++MARK;
3074 register SV *sv = &PL_sv_undef;
3077 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3078 *MARK-- = SvTIED_obj((SV*)ary, mg);
3082 call_method("PUSH",G_SCALAR|G_DISCARD);
3087 /* Why no pre-extend of ary here ? */
3088 for (++MARK; MARK <= SP; MARK++) {
3091 sv_setsv(sv, *MARK);
3096 PUSHi( AvFILL(ary) + 1 );
3104 SV *sv = av_pop(av);
3106 (void)sv_2mortal(sv);
3115 SV *sv = av_shift(av);
3120 (void)sv_2mortal(sv);
3127 djSP; dMARK; dORIGMARK; dTARGET;
3128 register AV *ary = (AV*)*++MARK;
3133 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3134 *MARK-- = SvTIED_obj((SV*)ary, mg);
3138 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3143 av_unshift(ary, SP - MARK);
3146 sv_setsv(sv, *++MARK);
3147 (void)av_store(ary, i++, sv);
3151 PUSHi( AvFILL(ary) + 1 );
3161 if (GIMME == G_ARRAY) {
3172 register char *down;
3178 do_join(TARG, &PL_sv_no, MARK, SP);
3180 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3181 up = SvPV_force(TARG, len);
3183 if (IN_UTF8) { /* first reverse each character */
3184 U8* s = (U8*)SvPVX(TARG);
3185 U8* send = (U8*)(s + len);
3194 down = (char*)(s - 1);
3195 if (s > send || !((*down & 0xc0) == 0x80)) {
3196 if (ckWARN_d(WARN_UTF8))
3197 Perl_warner(aTHX_ WARN_UTF8,
3198 "Malformed UTF-8 character");
3210 down = SvPVX(TARG) + len - 1;
3216 (void)SvPOK_only(TARG);
3225 S_mul128(pTHX_ SV *sv, U8 m)
3228 char *s = SvPV(sv, len);
3232 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3233 SV *tmpNew = newSVpvn("0000000000", 10);
3235 sv_catsv(tmpNew, sv);
3236 SvREFCNT_dec(sv); /* free old sv */
3241 while (!*t) /* trailing '\0'? */
3244 i = ((*t - '0') << 7) + m;
3245 *(t--) = '0' + (i % 10);
3251 /* Explosives and implosives. */
3253 #if 'I' == 73 && 'J' == 74
3254 /* On an ASCII/ISO kind of system */
3255 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3258 Some other sort of character set - use memchr() so we don't match
3261 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3269 I32 gimme = GIMME_V;
3273 register char *pat = SvPV(left, llen);
3274 register char *s = SvPV(right, rlen);
3275 char *strend = s + rlen;
3277 register char *patend = pat + llen;
3282 /* These must not be in registers: */
3299 register U32 culong;
3302 #ifdef PERL_NATINT_PACK
3303 int natint; /* native integer */
3304 int unatint; /* unsigned native integer */
3307 if (gimme != G_ARRAY) { /* arrange to do first one only */
3309 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3310 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3312 while (isDIGIT(*patend) || *patend == '*')
3318 while (pat < patend) {
3320 datumtype = *pat++ & 0xFF;
3321 #ifdef PERL_NATINT_PACK
3324 if (isSPACE(datumtype))
3327 char *natstr = "sSiIlL";
3329 if (strchr(natstr, datumtype)) {
3330 #ifdef PERL_NATINT_PACK
3336 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
3340 else if (*pat == '*') {
3341 len = strend - strbeg; /* long enough */
3344 else if (isDIGIT(*pat)) {
3346 while (isDIGIT(*pat))
3347 len = (len * 10) + (*pat++ - '0');
3350 len = (datumtype != '@');
3353 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3354 case ',': /* grandfather in commas but with a warning */
3355 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3356 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3359 if (len == 1 && pat[-1] != '1')
3368 if (len > strend - strbeg)
3369 DIE(aTHX_ "@ outside of string");
3373 if (len > s - strbeg)
3374 DIE(aTHX_ "X outside of string");
3378 if (len > strend - s)
3379 DIE(aTHX_ "x outside of string");
3385 if (len > strend - s)
3388 goto uchar_checksum;
3389 sv = NEWSV(35, len);
3390 sv_setpvn(sv, s, len);
3392 if (datumtype == 'A' || datumtype == 'Z') {
3393 aptr = s; /* borrow register */
3394 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3399 else { /* 'A' strips both nulls and spaces */
3400 s = SvPVX(sv) + len - 1;
3401 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3405 SvCUR_set(sv, s - SvPVX(sv));
3406 s = aptr; /* unborrow register */
3408 XPUSHs(sv_2mortal(sv));
3412 if (pat[-1] == '*' || len > (strend - s) * 8)
3413 len = (strend - s) * 8;
3416 Newz(601, PL_bitcount, 256, char);
3417 for (bits = 1; bits < 256; bits++) {
3418 if (bits & 1) PL_bitcount[bits]++;
3419 if (bits & 2) PL_bitcount[bits]++;
3420 if (bits & 4) PL_bitcount[bits]++;
3421 if (bits & 8) PL_bitcount[bits]++;
3422 if (bits & 16) PL_bitcount[bits]++;
3423 if (bits & 32) PL_bitcount[bits]++;
3424 if (bits & 64) PL_bitcount[bits]++;
3425 if (bits & 128) PL_bitcount[bits]++;
3429 culong += PL_bitcount[*(unsigned char*)s++];
3434 if (datumtype == 'b') {
3436 if (bits & 1) culong++;
3442 if (bits & 128) culong++;
3449 sv = NEWSV(35, len + 1);
3452 aptr = pat; /* borrow register */
3454 if (datumtype == 'b') {
3456 for (len = 0; len < aint; len++) {
3457 if (len & 7) /*SUPPRESS 595*/
3461 *pat++ = '0' + (bits & 1);
3466 for (len = 0; len < aint; len++) {
3471 *pat++ = '0' + ((bits & 128) != 0);
3475 pat = aptr; /* unborrow register */
3476 XPUSHs(sv_2mortal(sv));
3480 if (pat[-1] == '*' || len > (strend - s) * 2)
3481 len = (strend - s) * 2;
3482 sv = NEWSV(35, len + 1);
3485 aptr = pat; /* borrow register */
3487 if (datumtype == 'h') {
3489 for (len = 0; len < aint; len++) {
3494 *pat++ = PL_hexdigit[bits & 15];
3499 for (len = 0; len < aint; len++) {
3504 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3508 pat = aptr; /* unborrow register */
3509 XPUSHs(sv_2mortal(sv));
3512 if (len > strend - s)
3517 if (aint >= 128) /* fake up signed chars */
3527 if (aint >= 128) /* fake up signed chars */
3530 sv_setiv(sv, (IV)aint);
3531 PUSHs(sv_2mortal(sv));
3536 if (len > strend - s)
3551 sv_setiv(sv, (IV)auint);
3552 PUSHs(sv_2mortal(sv));
3557 if (len > strend - s)
3560 while (len-- > 0 && s < strend) {
3561 auint = utf8_to_uv((U8*)s, &along);
3564 cdouble += (NV)auint;
3572 while (len-- > 0 && s < strend) {
3573 auint = utf8_to_uv((U8*)s, &along);
3576 sv_setuv(sv, (UV)auint);
3577 PUSHs(sv_2mortal(sv));
3582 #if SHORTSIZE == SIZE16
3583 along = (strend - s) / SIZE16;
3585 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3590 #if SHORTSIZE != SIZE16
3593 COPYNN(s, &ashort, sizeof(short));
3604 #if SHORTSIZE > SIZE16
3616 #if SHORTSIZE != SIZE16
3619 COPYNN(s, &ashort, sizeof(short));
3622 sv_setiv(sv, (IV)ashort);
3623 PUSHs(sv_2mortal(sv));
3631 #if SHORTSIZE > SIZE16
3637 sv_setiv(sv, (IV)ashort);
3638 PUSHs(sv_2mortal(sv));
3646 #if SHORTSIZE == SIZE16
3647 along = (strend - s) / SIZE16;
3649 unatint = natint && datumtype == 'S';
3650 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3655 #if SHORTSIZE != SIZE16
3658 COPYNN(s, &aushort, sizeof(unsigned short));
3659 s += sizeof(unsigned short);
3667 COPY16(s, &aushort);
3670 if (datumtype == 'n')
3671 aushort = PerlSock_ntohs(aushort);
3674 if (datumtype == 'v')
3675 aushort = vtohs(aushort);
3684 #if SHORTSIZE != SIZE16
3687 COPYNN(s, &aushort, sizeof(unsigned short));
3688 s += sizeof(unsigned short);
3690 sv_setiv(sv, (UV)aushort);
3691 PUSHs(sv_2mortal(sv));
3698 COPY16(s, &aushort);
3702 if (datumtype == 'n')
3703 aushort = PerlSock_ntohs(aushort);
3706 if (datumtype == 'v')
3707 aushort = vtohs(aushort);
3709 sv_setiv(sv, (UV)aushort);
3710 PUSHs(sv_2mortal(sv));
3716 along = (strend - s) / sizeof(int);
3721 Copy(s, &aint, 1, int);
3724 cdouble += (NV)aint;
3733 Copy(s, &aint, 1, int);
3737 /* Without the dummy below unpack("i", pack("i",-1))
3738 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3739 * cc with optimization turned on.
3741 * The bug was detected in
3742 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3743 * with optimization (-O4) turned on.
3744 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3745 * does not have this problem even with -O4.
3747 * This bug was reported as DECC_BUGS 1431
3748 * and tracked internally as GEM_BUGS 7775.
3750 * The bug is fixed in
3751 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3752 * UNIX V4.0F support: DEC C V5.9-006 or later
3753 * UNIX V4.0E support: DEC C V5.8-011 or later
3756 * See also few lines later for the same bug.
3759 sv_setiv(sv, (IV)aint) :
3761 sv_setiv(sv, (IV)aint);
3762 PUSHs(sv_2mortal(sv));
3767 along = (strend - s) / sizeof(unsigned int);
3772 Copy(s, &auint, 1, unsigned int);
3773 s += sizeof(unsigned int);
3775 cdouble += (NV)auint;
3784 Copy(s, &auint, 1, unsigned int);
3785 s += sizeof(unsigned int);
3788 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3789 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3790 * See details few lines earlier. */
3792 sv_setuv(sv, (UV)auint) :
3794 sv_setuv(sv, (UV)auint);
3795 PUSHs(sv_2mortal(sv));
3800 #if LONGSIZE == SIZE32
3801 along = (strend - s) / SIZE32;
3803 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3808 #if LONGSIZE != SIZE32
3811 COPYNN(s, &along, sizeof(long));
3814 cdouble += (NV)along;
3824 #if LONGSIZE > SIZE32
3825 if (along > 2147483647)
3826 along -= 4294967296;
3830 cdouble += (NV)along;
3839 #if LONGSIZE != SIZE32
3842 COPYNN(s, &along, sizeof(long));
3845 sv_setiv(sv, (IV)along);
3846 PUSHs(sv_2mortal(sv));
3854 #if LONGSIZE > SIZE32
3855 if (along > 2147483647)
3856 along -= 4294967296;
3860 sv_setiv(sv, (IV)along);
3861 PUSHs(sv_2mortal(sv));
3869 #if LONGSIZE == SIZE32
3870 along = (strend - s) / SIZE32;
3872 unatint = natint && datumtype == 'L';
3873 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3878 #if LONGSIZE != SIZE32
3881 COPYNN(s, &aulong, sizeof(unsigned long));
3882 s += sizeof(unsigned long);
3884 cdouble += (NV)aulong;
3896 if (datumtype == 'N')
3897 aulong = PerlSock_ntohl(aulong);
3900 if (datumtype == 'V')
3901 aulong = vtohl(aulong);
3904 cdouble += (NV)aulong;
3913 #if LONGSIZE != SIZE32
3916 COPYNN(s, &aulong, sizeof(unsigned long));
3917 s += sizeof(unsigned long);
3919 sv_setuv(sv, (UV)aulong);
3920 PUSHs(sv_2mortal(sv));
3930 if (datumtype == 'N')
3931 aulong = PerlSock_ntohl(aulong);
3934 if (datumtype == 'V')
3935 aulong = vtohl(aulong);
3938 sv_setuv(sv, (UV)aulong);
3939 PUSHs(sv_2mortal(sv));
3945 along = (strend - s) / sizeof(char*);
3951 if (sizeof(char*) > strend - s)
3954 Copy(s, &aptr, 1, char*);
3960 PUSHs(sv_2mortal(sv));
3970 while ((len > 0) && (s < strend)) {
3971 auv = (auv << 7) | (*s & 0x7f);
3972 if (!(*s++ & 0x80)) {
3976 PUSHs(sv_2mortal(sv));
3980 else if (++bytes >= sizeof(UV)) { /* promote to string */
3984 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3985 while (s < strend) {
3986 sv = mul128(sv, *s & 0x7f);
3987 if (!(*s++ & 0x80)) {
3996 PUSHs(sv_2mortal(sv));
4001 if ((s >= strend) && bytes)
4002 Perl_croak(aTHX_ "Unterminated compressed integer");
4007 if (sizeof(char*) > strend - s)
4010 Copy(s, &aptr, 1, char*);
4015 sv_setpvn(sv, aptr, len);
4016 PUSHs(sv_2mortal(sv));
4020 along = (strend - s) / sizeof(Quad_t);
4026 if (s + sizeof(Quad_t) > strend)
4029 Copy(s, &aquad, 1, Quad_t);
4030 s += sizeof(Quad_t);
4033 if (aquad >= IV_MIN && aquad <= IV_MAX)
4034 sv_setiv(sv, (IV)aquad);
4036 sv_setnv(sv, (NV)aquad);
4037 PUSHs(sv_2mortal(sv));
4041 along = (strend - s) / sizeof(Quad_t);
4047 if (s + sizeof(Uquad_t) > strend)
4050 Copy(s, &auquad, 1, Uquad_t);
4051 s += sizeof(Uquad_t);
4054 if (auquad <= UV_MAX)
4055 sv_setuv(sv, (UV)auquad);
4057 sv_setnv(sv, (NV)auquad);
4058 PUSHs(sv_2mortal(sv));
4062 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4065 along = (strend - s) / sizeof(float);
4070 Copy(s, &afloat, 1, float);
4079 Copy(s, &afloat, 1, float);
4082 sv_setnv(sv, (NV)afloat);
4083 PUSHs(sv_2mortal(sv));
4089 along = (strend - s) / sizeof(double);
4094 Copy(s, &adouble, 1, double);
4095 s += sizeof(double);
4103 Copy(s, &adouble, 1, double);
4104 s += sizeof(double);
4106 sv_setnv(sv, (NV)adouble);
4107 PUSHs(sv_2mortal(sv));
4113 * Initialise the decode mapping. By using a table driven
4114 * algorithm, the code will be character-set independent
4115 * (and just as fast as doing character arithmetic)
4117 if (PL_uudmap['M'] == 0) {
4120 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4121 PL_uudmap[PL_uuemap[i]] = i;
4123 * Because ' ' and '`' map to the same value,
4124 * we need to decode them both the same.
4129 along = (strend - s) * 3 / 4;
4130 sv = NEWSV(42, along);
4133 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4138 len = PL_uudmap[*s++] & 077;
4140 if (s < strend && ISUUCHAR(*s))
4141 a = PL_uudmap[*s++] & 077;
4144 if (s < strend && ISUUCHAR(*s))
4145 b = PL_uudmap[*s++] & 077;
4148 if (s < strend && ISUUCHAR(*s))
4149 c = PL_uudmap[*s++] & 077;
4152 if (s < strend && ISUUCHAR(*s))
4153 d = PL_uudmap[*s++] & 077;
4156 hunk[0] = (a << 2) | (b >> 4);
4157 hunk[1] = (b << 4) | (c >> 2);
4158 hunk[2] = (c << 6) | d;
4159 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4164 else if (s[1] == '\n') /* possible checksum byte */
4167 XPUSHs(sv_2mortal(sv));
4172 if (strchr("fFdD", datumtype) ||
4173 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4177 while (checksum >= 16) {
4181 while (checksum >= 4) {
4187 along = (1 << checksum) - 1;
4188 while (cdouble < 0.0)
4190 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4191 sv_setnv(sv, cdouble);
4194 if (checksum < 32) {
4195 aulong = (1 << checksum) - 1;
4198 sv_setuv(sv, (UV)culong);
4200 XPUSHs(sv_2mortal(sv));
4204 if (SP == oldsp && gimme == G_SCALAR)
4205 PUSHs(&PL_sv_undef);
4210 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4214 *hunk = PL_uuemap[len];
4215 sv_catpvn(sv, hunk, 1);
4218 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4219 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4220 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4221 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4222 sv_catpvn(sv, hunk, 4);
4227 char r = (len > 1 ? s[1] : '\0');
4228 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4229 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4230 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4231 hunk[3] = PL_uuemap[0];
4232 sv_catpvn(sv, hunk, 4);
4234 sv_catpvn(sv, "\n", 1);
4238 S_is_an_int(pTHX_ char *s, STRLEN l)
4241 SV *result = newSVpvn(s, l);
4242 char *result_c = SvPV(result, n_a); /* convenience */
4243 char *out = result_c;
4253 SvREFCNT_dec(result);
4276 SvREFCNT_dec(result);
4282 SvCUR_set(result, out - result_c);
4286 /* pnum must be '\0' terminated */
4288 S_div128(pTHX_ SV *pnum, bool *done)
4291 char *s = SvPV(pnum, len);
4300 i = m * 10 + (*t - '0');
4302 r = (i >> 7); /* r < 10 */
4309 SvCUR_set(pnum, (STRLEN) (t - s));
4316 djSP; dMARK; dORIGMARK; dTARGET;
4317 register SV *cat = TARG;
4320 register char *pat = SvPVx(*++MARK, fromlen);
4321 register char *patend = pat + fromlen;
4326 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4327 static char *space10 = " ";
4329 /* These must not be in registers: */
4344 #ifdef PERL_NATINT_PACK
4345 int natint; /* native integer */
4350 sv_setpvn(cat, "", 0);
4351 while (pat < patend) {
4352 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4353 datumtype = *pat++ & 0xFF;
4354 #ifdef PERL_NATINT_PACK
4357 if (isSPACE(datumtype))
4360 char *natstr = "sSiIlL";
4362 if (strchr(natstr, datumtype)) {
4363 #ifdef PERL_NATINT_PACK
4369 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
4372 len = strchr("@Xxu", datumtype) ? 0 : items;
4375 else if (isDIGIT(*pat)) {
4377 while (isDIGIT(*pat))
4378 len = (len * 10) + (*pat++ - '0');
4384 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4385 case ',': /* grandfather in commas but with a warning */
4386 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4387 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4390 DIE(aTHX_ "%% may only be used in unpack");
4401 if (SvCUR(cat) < len)
4402 DIE(aTHX_ "X outside of string");
4409 sv_catpvn(cat, null10, 10);
4412 sv_catpvn(cat, null10, len);
4418 aptr = SvPV(fromstr, fromlen);
4422 sv_catpvn(cat, aptr, len);
4424 sv_catpvn(cat, aptr, fromlen);
4426 if (datumtype == 'A') {
4428 sv_catpvn(cat, space10, 10);
4431 sv_catpvn(cat, space10, len);
4435 sv_catpvn(cat, null10, 10);
4438 sv_catpvn(cat, null10, len);
4445 char *savepat = pat;
4450 aptr = SvPV(fromstr, fromlen);
4455 SvCUR(cat) += (len+7)/8;
4456 SvGROW(cat, SvCUR(cat) + 1);
4457 aptr = SvPVX(cat) + aint;
4462 if (datumtype == 'B') {
4463 for (len = 0; len++ < aint;) {
4464 items |= *pat++ & 1;
4468 *aptr++ = items & 0xff;
4474 for (len = 0; len++ < aint;) {
4480 *aptr++ = items & 0xff;
4486 if (datumtype == 'B')
4487 items <<= 7 - (aint & 7);
4489 items >>= 7 - (aint & 7);
4490 *aptr++ = items & 0xff;
4492 pat = SvPVX(cat) + SvCUR(cat);
4503 char *savepat = pat;
4508 aptr = SvPV(fromstr, fromlen);
4513 SvCUR(cat) += (len+1)/2;
4514 SvGROW(cat, SvCUR(cat) + 1);
4515 aptr = SvPVX(cat) + aint;
4520 if (datumtype == 'H') {
4521 for (len = 0; len++ < aint;) {
4523 items |= ((*pat++ & 15) + 9) & 15;
4525 items |= *pat++ & 15;
4529 *aptr++ = items & 0xff;
4535 for (len = 0; len++ < aint;) {
4537 items |= (((*pat++ & 15) + 9) & 15) << 4;
4539 items |= (*pat++ & 15) << 4;
4543 *aptr++ = items & 0xff;
4549 *aptr++ = items & 0xff;
4550 pat = SvPVX(cat) + SvCUR(cat);
4562 aint = SvIV(fromstr);
4564 sv_catpvn(cat, &achar, sizeof(char));
4570 auint = SvUV(fromstr);
4571 SvGROW(cat, SvCUR(cat) + 10);
4572 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4577 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4582 afloat = (float)SvNV(fromstr);
4583 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4590 adouble = (double)SvNV(fromstr);
4591 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4597 ashort = (I16)SvIV(fromstr);
4599 ashort = PerlSock_htons(ashort);
4601 CAT16(cat, &ashort);
4607 ashort = (I16)SvIV(fromstr);
4609 ashort = htovs(ashort);
4611 CAT16(cat, &ashort);
4615 #if SHORTSIZE != SIZE16
4617 unsigned short aushort;
4621 aushort = SvUV(fromstr);
4622 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4632 aushort = (U16)SvUV(fromstr);
4633 CAT16(cat, &aushort);
4639 #if SHORTSIZE != SIZE16
4643 ashort = SvIV(fromstr);
4644 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4652 ashort = (I16)SvIV(fromstr);
4653 CAT16(cat, &ashort);
4660 auint = SvUV(fromstr);
4661 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4667 adouble = Perl_floor(SvNV(fromstr));
4670 Perl_croak(aTHX_ "Cannot compress negative numbers");
4676 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4677 adouble <= UV_MAX_cxux
4684 char buf[1 + sizeof(UV)];
4685 char *in = buf + sizeof(buf);
4686 UV auv = U_V(adouble);
4689 *--in = (auv & 0x7f) | 0x80;
4692 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4693 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4695 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4696 char *from, *result, *in;
4701 /* Copy string and check for compliance */
4702 from = SvPV(fromstr, len);
4703 if ((norm = is_an_int(from, len)) == NULL)
4704 Perl_croak(aTHX_ "can compress only unsigned integer");
4706 New('w', result, len, char);
4710 *--in = div128(norm, &done) | 0x80;
4711 result[len - 1] &= 0x7F; /* clear continue bit */
4712 sv_catpvn(cat, in, (result + len) - in);
4714 SvREFCNT_dec(norm); /* free norm */
4716 else if (SvNOKp(fromstr)) {
4717 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4718 char *in = buf + sizeof(buf);
4721 double next = floor(adouble / 128);
4722 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4723 if (--in < buf) /* this cannot happen ;-) */
4724 Perl_croak(aTHX_ "Cannot compress integer");
4726 } while (adouble > 0);
4727 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4728 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4731 Perl_croak(aTHX_ "Cannot compress non integer");
4737 aint = SvIV(fromstr);
4738 sv_catpvn(cat, (char*)&aint, sizeof(int));
4744 aulong = SvUV(fromstr);
4746 aulong = PerlSock_htonl(aulong);
4748 CAT32(cat, &aulong);
4754 aulong = SvUV(fromstr);
4756 aulong = htovl(aulong);
4758 CAT32(cat, &aulong);
4762 #if LONGSIZE != SIZE32
4766 aulong = SvUV(fromstr);
4767 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4775 aulong = SvUV(fromstr);
4776 CAT32(cat, &aulong);
4781 #if LONGSIZE != SIZE32
4785 along = SvIV(fromstr);
4786 sv_catpvn(cat, (char *)&along, sizeof(long));
4794 along = SvIV(fromstr);
4803 auquad = (Uquad_t)SvIV(fromstr);
4804 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4810 aquad = (Quad_t)SvIV(fromstr);
4811 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4814 #endif /* HAS_QUAD */
4816 len = 1; /* assume SV is correct length */
4821 if (fromstr == &PL_sv_undef)
4825 /* XXX better yet, could spirit away the string to
4826 * a safe spot and hang on to it until the result
4827 * of pack() (and all copies of the result) are
4830 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4831 Perl_warner(aTHX_ WARN_UNSAFE,
4832 "Attempt to pack pointer to temporary value");
4833 if (SvPOK(fromstr) || SvNIOK(fromstr))
4834 aptr = SvPV(fromstr,n_a);
4836 aptr = SvPV_force(fromstr,n_a);
4838 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4843 aptr = SvPV(fromstr, fromlen);
4844 SvGROW(cat, fromlen * 4 / 3);
4849 while (fromlen > 0) {
4856 doencodes(cat, aptr, todo);
4875 register I32 limit = POPi; /* note, negative is forever */
4878 register char *s = SvPV(sv, len);
4879 char *strend = s + len;
4881 register REGEXP *rx;
4885 I32 maxiters = (strend - s) + 10;
4888 I32 origlimit = limit;
4891 AV *oldstack = PL_curstack;
4892 I32 gimme = GIMME_V;
4893 I32 oldsave = PL_savestack_ix;
4894 I32 make_mortal = 1;
4895 MAGIC *mg = (MAGIC *) NULL;
4898 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4903 DIE(aTHX_ "panic: do_split");
4904 rx = pm->op_pmregexp;
4906 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4907 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4909 if (pm->op_pmreplroot)
4910 ary = GvAVn((GV*)pm->op_pmreplroot);
4911 else if (gimme != G_ARRAY)
4913 ary = (AV*)PL_curpad[0];
4915 ary = GvAVn(PL_defgv);
4916 #endif /* USE_THREADS */
4919 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4925 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4927 XPUSHs(SvTIED_obj((SV*)ary, mg));
4932 for (i = AvFILLp(ary); i >= 0; i--)
4933 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4935 /* temporarily switch stacks */
4936 SWITCHSTACK(PL_curstack, ary);
4940 base = SP - PL_stack_base;
4942 if (pm->op_pmflags & PMf_SKIPWHITE) {
4943 if (pm->op_pmflags & PMf_LOCALE) {
4944 while (isSPACE_LC(*s))
4952 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4953 SAVEINT(PL_multiline);
4954 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4958 limit = maxiters + 2;
4959 if (pm->op_pmflags & PMf_WHITE) {
4962 while (m < strend &&
4963 !((pm->op_pmflags & PMf_LOCALE)
4964 ? isSPACE_LC(*m) : isSPACE(*m)))
4969 dstr = NEWSV(30, m-s);
4970 sv_setpvn(dstr, s, m-s);
4976 while (s < strend &&
4977 ((pm->op_pmflags & PMf_LOCALE)
4978 ? isSPACE_LC(*s) : isSPACE(*s)))
4982 else if (strEQ("^", rx->precomp)) {
4985 for (m = s; m < strend && *m != '\n'; m++) ;
4989 dstr = NEWSV(30, m-s);
4990 sv_setpvn(dstr, s, m-s);
4997 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
4998 && (rx->reganch & ROPT_CHECK_ALL)
4999 && !(rx->reganch & ROPT_ANCH)) {
5000 int tail = (rx->reganch & RE_INTUIT_TAIL);
5001 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5005 if (len == 1 && !tail) {
5009 for (m = s; m < strend && *m != c; m++) ;
5012 dstr = NEWSV(30, m-s);
5013 sv_setpvn(dstr, s, m-s);
5022 while (s < strend && --limit &&
5023 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5024 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5027 dstr = NEWSV(31, m-s);
5028 sv_setpvn(dstr, s, m-s);
5032 s = m + len; /* Fake \n at the end */
5037 maxiters += (strend - s) * rx->nparens;
5038 while (s < strend && --limit
5039 /* && (!rx->check_substr
5040 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5042 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5043 1 /* minend */, sv, NULL, 0))
5045 TAINT_IF(RX_MATCH_TAINTED(rx));
5046 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5051 strend = s + (strend - m);
5053 m = rx->startp[0] + orig;
5054 dstr = NEWSV(32, m-s);
5055 sv_setpvn(dstr, s, m-s);
5060 for (i = 1; i <= rx->nparens; i++) {
5061 s = rx->startp[i] + orig;
5062 m = rx->endp[i] + orig;
5064 dstr = NEWSV(33, m-s);
5065 sv_setpvn(dstr, s, m-s);
5068 dstr = NEWSV(33, 0);
5074 s = rx->endp[0] + orig;
5078 LEAVE_SCOPE(oldsave);
5079 iters = (SP - PL_stack_base) - base;
5080 if (iters > maxiters)
5081 DIE(aTHX_ "Split loop");
5083 /* keep field after final delim? */
5084 if (s < strend || (iters && origlimit)) {
5085 dstr = NEWSV(34, strend-s);
5086 sv_setpvn(dstr, s, strend-s);
5092 else if (!origlimit) {
5093 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5099 SWITCHSTACK(ary, oldstack);
5100 if (SvSMAGICAL(ary)) {
5105 if (gimme == G_ARRAY) {
5107 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5115 call_method("PUSH",G_SCALAR|G_DISCARD);
5118 if (gimme == G_ARRAY) {
5119 /* EXTEND should not be needed - we just popped them */
5121 for (i=0; i < iters; i++) {
5122 SV **svp = av_fetch(ary, i, FALSE);
5123 PUSHs((svp) ? *svp : &PL_sv_undef);
5130 if (gimme == G_ARRAY)
5133 if (iters || !pm->op_pmreplroot) {
5143 Perl_unlock_condpair(pTHX_ void *svv)
5146 MAGIC *mg = mg_find((SV*)svv, 'm');
5149 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5150 MUTEX_LOCK(MgMUTEXP(mg));
5151 if (MgOWNER(mg) != thr)
5152 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5154 COND_SIGNAL(MgOWNERCONDP(mg));
5155 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5156 (unsigned long)thr, (unsigned long)svv);)
5157 MUTEX_UNLOCK(MgMUTEXP(mg));
5159 #endif /* USE_THREADS */
5172 mg = condpair_magic(sv);
5173 MUTEX_LOCK(MgMUTEXP(mg));
5174 if (MgOWNER(mg) == thr)
5175 MUTEX_UNLOCK(MgMUTEXP(mg));
5178 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5180 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5181 (unsigned long)thr, (unsigned long)sv);)
5182 MUTEX_UNLOCK(MgMUTEXP(mg));
5183 SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
5185 #endif /* USE_THREADS */
5186 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5187 || SvTYPE(retsv) == SVt_PVCV) {
5188 retsv = refto(retsv);
5199 if (PL_op->op_private & OPpLVAL_INTRO)
5200 PUSHs(*save_threadsv(PL_op->op_targ));
5202 PUSHs(THREADSV(PL_op->op_targ));
5205 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5206 #endif /* USE_THREADS */