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 ((double)I_V(left) == left &&
954 (double)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 = 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, -(double)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(atan2(left, right));
1634 djSP; dTARGET; tryAMAGICun(sin);
1646 djSP; dTARGET; tryAMAGICun(cos);
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);
1800 djSP; dTARGET; tryAMAGICun(log);
1805 RESTORE_NUMERIC_STANDARD();
1806 DIE(aTHX_ "Can't take log of %g", value);
1816 djSP; dTARGET; tryAMAGICun(sqrt);
1821 RESTORE_NUMERIC_STANDARD();
1822 DIE(aTHX_ "Can't take sqrt of %g", value);
1824 value = sqrt(value);
1834 double value = TOPn;
1837 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1843 (void)modf(value, &value);
1845 (void)modf(-value, &value);
1860 djSP; dTARGET; tryAMAGICun(abs);
1862 double value = TOPn;
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);
2314 if (!SvPADTMP(sv)) {
2320 s = (U8*)SvPV_force(sv, slen);
2322 if (PL_op->op_private & OPpLOCALE) {
2325 *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);
2370 if (!SvPADTMP(sv)) {
2376 s = (U8*)SvPV_force(sv, slen);
2378 if (PL_op->op_private & OPpLOCALE) {
2381 *s = toLOWER_LC(*s);
2404 s = (U8*)SvPV(sv,len);
2406 sv_setpvn(TARG, "", 0);
2411 (void)SvUPGRADE(TARG, SVt_PV);
2412 SvGROW(TARG, (len * 2) + 1);
2413 (void)SvPOK_only(TARG);
2414 d = (U8*)SvPVX(TARG);
2416 if (PL_op->op_private & OPpLOCALE) {
2420 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2426 d = uv_to_utf8(d, toUPPER_utf8( s ));
2431 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2436 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++)
2474 s = (U8*)SvPV(sv,len);
2476 sv_setpvn(TARG, "", 0);
2481 (void)SvUPGRADE(TARG, SVt_PV);
2482 SvGROW(TARG, (len * 2) + 1);
2483 (void)SvPOK_only(TARG);
2484 d = (U8*)SvPVX(TARG);
2486 if (PL_op->op_private & OPpLOCALE) {
2490 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2496 d = uv_to_utf8(d, toLOWER_utf8(s));
2501 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2506 if (!SvPADTMP(sv)) {
2513 s = (U8*)SvPV_force(sv, len);
2515 register U8 *send = s + len;
2517 if (PL_op->op_private & OPpLOCALE) {
2520 for (; s < send; s++)
2521 *s = toLOWER_LC(*s);
2524 for (; s < send; s++)
2536 register char *s = SvPV(sv,len);
2540 (void)SvUPGRADE(TARG, SVt_PV);
2541 SvGROW(TARG, (len * 2) + 1);
2546 STRLEN ulen = UTF8SKIP(s);
2569 SvCUR_set(TARG, d - SvPVX(TARG));
2570 (void)SvPOK_only(TARG);
2573 sv_setpvn(TARG, s, len);
2582 djSP; dMARK; dORIGMARK;
2584 register AV* av = (AV*)POPs;
2585 register I32 lval = PL_op->op_flags & OPf_MOD;
2586 I32 arybase = PL_curcop->cop_arybase;
2589 if (SvTYPE(av) == SVt_PVAV) {
2590 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2592 for (svp = MARK + 1; svp <= SP; svp++) {
2597 if (max > AvMAX(av))
2600 while (++MARK <= SP) {
2601 elem = SvIVx(*MARK);
2605 svp = av_fetch(av, elem, lval);
2607 if (!svp || *svp == &PL_sv_undef)
2608 DIE(aTHX_ PL_no_aelem, elem);
2609 if (PL_op->op_private & OPpLVAL_INTRO)
2610 save_aelem(av, elem, svp);
2612 *MARK = svp ? *svp : &PL_sv_undef;
2615 if (GIMME != G_ARRAY) {
2623 /* Associative arrays. */
2628 HV *hash = (HV*)POPs;
2630 I32 gimme = GIMME_V;
2631 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2634 /* might clobber stack_sp */
2635 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2640 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2641 if (gimme == G_ARRAY) {
2643 /* might clobber stack_sp */
2644 sv_setsv(TARG, realhv ?
2645 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2650 else if (gimme == G_SCALAR)
2669 I32 gimme = GIMME_V;
2670 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2674 if (PL_op->op_private & OPpSLICE) {
2678 hvtype = SvTYPE(hv);
2679 while (++MARK <= SP) {
2680 if (hvtype == SVt_PVHV)
2681 sv = hv_delete_ent(hv, *MARK, discard, 0);
2683 DIE(aTHX_ "Not a HASH reference");
2684 *MARK = sv ? sv : &PL_sv_undef;
2688 else if (gimme == G_SCALAR) {
2697 if (SvTYPE(hv) == SVt_PVHV)
2698 sv = hv_delete_ent(hv, keysv, discard, 0);
2700 DIE(aTHX_ "Not a HASH reference");
2714 if (SvTYPE(hv) == SVt_PVHV) {
2715 if (hv_exists_ent(hv, tmpsv, 0))
2718 else if (SvTYPE(hv) == SVt_PVAV) {
2719 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2723 DIE(aTHX_ "Not a HASH reference");
2730 djSP; dMARK; dORIGMARK;
2731 register HV *hv = (HV*)POPs;
2732 register I32 lval = PL_op->op_flags & OPf_MOD;
2733 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2735 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2736 DIE(aTHX_ "Can't localize pseudo-hash element");
2738 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2739 while (++MARK <= SP) {
2743 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2744 svp = he ? &HeVAL(he) : 0;
2747 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2750 if (!svp || *svp == &PL_sv_undef) {
2752 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2754 if (PL_op->op_private & OPpLVAL_INTRO)
2755 save_helem(hv, keysv, svp);
2757 *MARK = svp ? *svp : &PL_sv_undef;
2760 if (GIMME != G_ARRAY) {
2768 /* List operators. */
2773 if (GIMME != G_ARRAY) {
2775 *MARK = *SP; /* unwanted list, return last item */
2777 *MARK = &PL_sv_undef;
2786 SV **lastrelem = PL_stack_sp;
2787 SV **lastlelem = PL_stack_base + POPMARK;
2788 SV **firstlelem = PL_stack_base + POPMARK + 1;
2789 register SV **firstrelem = lastlelem + 1;
2790 I32 arybase = PL_curcop->cop_arybase;
2791 I32 lval = PL_op->op_flags & OPf_MOD;
2792 I32 is_something_there = lval;
2794 register I32 max = lastrelem - lastlelem;
2795 register SV **lelem;
2798 if (GIMME != G_ARRAY) {
2799 ix = SvIVx(*lastlelem);
2804 if (ix < 0 || ix >= max)
2805 *firstlelem = &PL_sv_undef;
2807 *firstlelem = firstrelem[ix];
2813 SP = firstlelem - 1;
2817 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2823 if (ix < 0 || ix >= max)
2824 *lelem = &PL_sv_undef;
2826 is_something_there = TRUE;
2827 if (!(*lelem = firstrelem[ix]))
2828 *lelem = &PL_sv_undef;
2831 if (is_something_there)
2834 SP = firstlelem - 1;
2840 djSP; dMARK; dORIGMARK;
2841 I32 items = SP - MARK;
2842 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2843 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2850 djSP; dMARK; dORIGMARK;
2851 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2855 SV *val = NEWSV(46, 0);
2857 sv_setsv(val, *++MARK);
2858 else if (ckWARN(WARN_UNSAFE))
2859 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2860 (void)hv_store_ent(hv,key,val,0);
2869 djSP; dMARK; dORIGMARK;
2870 register AV *ary = (AV*)*++MARK;
2874 register I32 offset;
2875 register I32 length;
2882 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2883 *MARK-- = SvTIED_obj((SV*)ary, mg);
2887 call_method("SPLICE",GIMME_V);
2896 offset = i = SvIVx(*MARK);
2898 offset += AvFILLp(ary) + 1;
2900 offset -= PL_curcop->cop_arybase;
2902 DIE(aTHX_ PL_no_aelem, i);
2904 length = SvIVx(*MARK++);
2906 length += AvFILLp(ary) - offset + 1;
2912 length = AvMAX(ary) + 1; /* close enough to infinity */
2916 length = AvMAX(ary) + 1;
2918 if (offset > AvFILLp(ary) + 1)
2919 offset = AvFILLp(ary) + 1;
2920 after = AvFILLp(ary) + 1 - (offset + length);
2921 if (after < 0) { /* not that much array */
2922 length += after; /* offset+length now in array */
2928 /* At this point, MARK .. SP-1 is our new LIST */
2931 diff = newlen - length;
2932 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2935 if (diff < 0) { /* shrinking the area */
2937 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2938 Copy(MARK, tmparyval, newlen, SV*);
2941 MARK = ORIGMARK + 1;
2942 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2943 MEXTEND(MARK, length);
2944 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2946 EXTEND_MORTAL(length);
2947 for (i = length, dst = MARK; i; i--) {
2948 sv_2mortal(*dst); /* free them eventualy */
2955 *MARK = AvARRAY(ary)[offset+length-1];
2958 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2959 SvREFCNT_dec(*dst++); /* free them now */
2962 AvFILLp(ary) += diff;
2964 /* pull up or down? */
2966 if (offset < after) { /* easier to pull up */
2967 if (offset) { /* esp. if nothing to pull */
2968 src = &AvARRAY(ary)[offset-1];
2969 dst = src - diff; /* diff is negative */
2970 for (i = offset; i > 0; i--) /* can't trust Copy */
2974 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2978 if (after) { /* anything to pull down? */
2979 src = AvARRAY(ary) + offset + length;
2980 dst = src + diff; /* diff is negative */
2981 Move(src, dst, after, SV*);
2983 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2984 /* avoid later double free */
2988 dst[--i] = &PL_sv_undef;
2991 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2993 *dst = NEWSV(46, 0);
2994 sv_setsv(*dst++, *src++);
2996 Safefree(tmparyval);
2999 else { /* no, expanding (or same) */
3001 New(452, tmparyval, length, SV*); /* so remember deletion */
3002 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3005 if (diff > 0) { /* expanding */
3007 /* push up or down? */
3009 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3013 Move(src, dst, offset, SV*);
3015 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3017 AvFILLp(ary) += diff;
3020 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3021 av_extend(ary, AvFILLp(ary) + diff);
3022 AvFILLp(ary) += diff;
3025 dst = AvARRAY(ary) + AvFILLp(ary);
3027 for (i = after; i; i--) {
3034 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3035 *dst = NEWSV(46, 0);
3036 sv_setsv(*dst++, *src++);
3038 MARK = ORIGMARK + 1;
3039 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3041 Copy(tmparyval, MARK, length, SV*);
3043 EXTEND_MORTAL(length);
3044 for (i = length, dst = MARK; i; i--) {
3045 sv_2mortal(*dst); /* free them eventualy */
3049 Safefree(tmparyval);
3053 else if (length--) {
3054 *MARK = tmparyval[length];
3057 while (length-- > 0)
3058 SvREFCNT_dec(tmparyval[length]);
3060 Safefree(tmparyval);
3063 *MARK = &PL_sv_undef;
3071 djSP; dMARK; dORIGMARK; dTARGET;
3072 register AV *ary = (AV*)*++MARK;
3073 register SV *sv = &PL_sv_undef;
3076 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3077 *MARK-- = SvTIED_obj((SV*)ary, mg);
3081 call_method("PUSH",G_SCALAR|G_DISCARD);
3086 /* Why no pre-extend of ary here ? */
3087 for (++MARK; MARK <= SP; MARK++) {
3090 sv_setsv(sv, *MARK);
3095 PUSHi( AvFILL(ary) + 1 );
3103 SV *sv = av_pop(av);
3105 (void)sv_2mortal(sv);
3114 SV *sv = av_shift(av);
3119 (void)sv_2mortal(sv);
3126 djSP; dMARK; dORIGMARK; dTARGET;
3127 register AV *ary = (AV*)*++MARK;
3132 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3133 *MARK-- = SvTIED_obj((SV*)ary, mg);
3137 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3142 av_unshift(ary, SP - MARK);
3145 sv_setsv(sv, *++MARK);
3146 (void)av_store(ary, i++, sv);
3150 PUSHi( AvFILL(ary) + 1 );
3160 if (GIMME == G_ARRAY) {
3171 register char *down;
3177 do_join(TARG, &PL_sv_no, MARK, SP);
3179 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3180 up = SvPV_force(TARG, len);
3182 if (IN_UTF8) { /* first reverse each character */
3183 U8* s = (U8*)SvPVX(TARG);
3184 U8* send = (U8*)(s + len);
3193 down = (char*)(s - 1);
3194 if (s > send || !((*down & 0xc0) == 0x80)) {
3195 Perl_warn(aTHX_ "Malformed UTF-8 character");
3207 down = SvPVX(TARG) + len - 1;
3213 (void)SvPOK_only(TARG);
3222 S_mul128(pTHX_ SV *sv, U8 m)
3225 char *s = SvPV(sv, len);
3229 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3230 SV *tmpNew = newSVpvn("0000000000", 10);
3232 sv_catsv(tmpNew, sv);
3233 SvREFCNT_dec(sv); /* free old sv */
3238 while (!*t) /* trailing '\0'? */
3241 i = ((*t - '0') << 7) + m;
3242 *(t--) = '0' + (i % 10);
3248 /* Explosives and implosives. */
3250 #if 'I' == 73 && 'J' == 74
3251 /* On an ASCII/ISO kind of system */
3252 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3255 Some other sort of character set - use memchr() so we don't match
3258 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3266 I32 gimme = GIMME_V;
3270 register char *pat = SvPV(left, llen);
3271 register char *s = SvPV(right, rlen);
3272 char *strend = s + rlen;
3274 register char *patend = pat + llen;
3279 /* These must not be in registers: */
3296 register U32 culong;
3299 #ifdef PERL_NATINT_PACK
3300 int natint; /* native integer */
3301 int unatint; /* unsigned native integer */
3304 if (gimme != G_ARRAY) { /* arrange to do first one only */
3306 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3307 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3309 while (isDIGIT(*patend) || *patend == '*')
3315 while (pat < patend) {
3317 datumtype = *pat++ & 0xFF;
3318 #ifdef PERL_NATINT_PACK
3321 if (isSPACE(datumtype))
3324 char *natstr = "sSiIlL";
3326 if (strchr(natstr, datumtype)) {
3327 #ifdef PERL_NATINT_PACK
3333 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
3337 else if (*pat == '*') {
3338 len = strend - strbeg; /* long enough */
3341 else if (isDIGIT(*pat)) {
3343 while (isDIGIT(*pat))
3344 len = (len * 10) + (*pat++ - '0');
3347 len = (datumtype != '@');
3350 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3351 case ',': /* grandfather in commas but with a warning */
3352 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3353 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3356 if (len == 1 && pat[-1] != '1')
3365 if (len > strend - strbeg)
3366 DIE(aTHX_ "@ outside of string");
3370 if (len > s - strbeg)
3371 DIE(aTHX_ "X outside of string");
3375 if (len > strend - s)
3376 DIE(aTHX_ "x outside of string");
3382 if (len > strend - s)
3385 goto uchar_checksum;
3386 sv = NEWSV(35, len);
3387 sv_setpvn(sv, s, len);
3389 if (datumtype == 'A' || datumtype == 'Z') {
3390 aptr = s; /* borrow register */
3391 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3396 else { /* 'A' strips both nulls and spaces */
3397 s = SvPVX(sv) + len - 1;
3398 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3402 SvCUR_set(sv, s - SvPVX(sv));
3403 s = aptr; /* unborrow register */
3405 XPUSHs(sv_2mortal(sv));
3409 if (pat[-1] == '*' || len > (strend - s) * 8)
3410 len = (strend - s) * 8;
3413 Newz(601, PL_bitcount, 256, char);
3414 for (bits = 1; bits < 256; bits++) {
3415 if (bits & 1) PL_bitcount[bits]++;
3416 if (bits & 2) PL_bitcount[bits]++;
3417 if (bits & 4) PL_bitcount[bits]++;
3418 if (bits & 8) PL_bitcount[bits]++;
3419 if (bits & 16) PL_bitcount[bits]++;
3420 if (bits & 32) PL_bitcount[bits]++;
3421 if (bits & 64) PL_bitcount[bits]++;
3422 if (bits & 128) PL_bitcount[bits]++;
3426 culong += PL_bitcount[*(unsigned char*)s++];
3431 if (datumtype == 'b') {
3433 if (bits & 1) culong++;
3439 if (bits & 128) culong++;
3446 sv = NEWSV(35, len + 1);
3449 aptr = pat; /* borrow register */
3451 if (datumtype == 'b') {
3453 for (len = 0; len < aint; len++) {
3454 if (len & 7) /*SUPPRESS 595*/
3458 *pat++ = '0' + (bits & 1);
3463 for (len = 0; len < aint; len++) {
3468 *pat++ = '0' + ((bits & 128) != 0);
3472 pat = aptr; /* unborrow register */
3473 XPUSHs(sv_2mortal(sv));
3477 if (pat[-1] == '*' || len > (strend - s) * 2)
3478 len = (strend - s) * 2;
3479 sv = NEWSV(35, len + 1);
3482 aptr = pat; /* borrow register */
3484 if (datumtype == 'h') {
3486 for (len = 0; len < aint; len++) {
3491 *pat++ = PL_hexdigit[bits & 15];
3496 for (len = 0; len < aint; len++) {
3501 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3505 pat = aptr; /* unborrow register */
3506 XPUSHs(sv_2mortal(sv));
3509 if (len > strend - s)
3514 if (aint >= 128) /* fake up signed chars */
3524 if (aint >= 128) /* fake up signed chars */
3527 sv_setiv(sv, (IV)aint);
3528 PUSHs(sv_2mortal(sv));
3533 if (len > strend - s)
3548 sv_setiv(sv, (IV)auint);
3549 PUSHs(sv_2mortal(sv));
3554 if (len > strend - s)
3557 while (len-- > 0 && s < strend) {
3558 auint = utf8_to_uv((U8*)s, &along);
3561 cdouble += (double)auint;
3569 while (len-- > 0 && s < strend) {
3570 auint = utf8_to_uv((U8*)s, &along);
3573 sv_setuv(sv, (UV)auint);
3574 PUSHs(sv_2mortal(sv));
3579 #if SHORTSIZE == SIZE16
3580 along = (strend - s) / SIZE16;
3582 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3587 #if SHORTSIZE != SIZE16
3590 COPYNN(s, &ashort, sizeof(short));
3601 #if SHORTSIZE > SIZE16
3613 #if SHORTSIZE != SIZE16
3616 COPYNN(s, &ashort, sizeof(short));
3619 sv_setiv(sv, (IV)ashort);
3620 PUSHs(sv_2mortal(sv));
3628 #if SHORTSIZE > SIZE16
3634 sv_setiv(sv, (IV)ashort);
3635 PUSHs(sv_2mortal(sv));
3643 #if SHORTSIZE == SIZE16
3644 along = (strend - s) / SIZE16;
3646 unatint = natint && datumtype == 'S';
3647 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3652 #if SHORTSIZE != SIZE16
3655 COPYNN(s, &aushort, sizeof(unsigned short));
3656 s += sizeof(unsigned short);
3664 COPY16(s, &aushort);
3667 if (datumtype == 'n')
3668 aushort = PerlSock_ntohs(aushort);
3671 if (datumtype == 'v')
3672 aushort = vtohs(aushort);
3681 #if SHORTSIZE != SIZE16
3684 COPYNN(s, &aushort, sizeof(unsigned short));
3685 s += sizeof(unsigned short);
3687 sv_setiv(sv, (UV)aushort);
3688 PUSHs(sv_2mortal(sv));
3695 COPY16(s, &aushort);
3699 if (datumtype == 'n')
3700 aushort = PerlSock_ntohs(aushort);
3703 if (datumtype == 'v')
3704 aushort = vtohs(aushort);
3706 sv_setiv(sv, (UV)aushort);
3707 PUSHs(sv_2mortal(sv));
3713 along = (strend - s) / sizeof(int);
3718 Copy(s, &aint, 1, int);
3721 cdouble += (double)aint;
3730 Copy(s, &aint, 1, int);
3734 /* Without the dummy below unpack("i", pack("i",-1))
3735 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3736 * cc with optimization turned on.
3738 * The bug was detected in
3739 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3740 * with optimization (-O4) turned on.
3741 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3742 * does not have this problem even with -O4.
3744 * This bug was reported as DECC_BUGS 1431
3745 * and tracked internally as GEM_BUGS 7775.
3747 * The bug is fixed in
3748 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3749 * UNIX V4.0F support: DEC C V5.9-006 or later
3750 * UNIX V4.0E support: DEC C V5.8-011 or later
3753 * See also few lines later for the same bug.
3756 sv_setiv(sv, (IV)aint) :
3758 sv_setiv(sv, (IV)aint);
3759 PUSHs(sv_2mortal(sv));
3764 along = (strend - s) / sizeof(unsigned int);
3769 Copy(s, &auint, 1, unsigned int);
3770 s += sizeof(unsigned int);
3772 cdouble += (double)auint;
3781 Copy(s, &auint, 1, unsigned int);
3782 s += sizeof(unsigned int);
3785 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3786 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3787 * See details few lines earlier. */
3789 sv_setuv(sv, (UV)auint) :
3791 sv_setuv(sv, (UV)auint);
3792 PUSHs(sv_2mortal(sv));
3797 #if LONGSIZE == SIZE32
3798 along = (strend - s) / SIZE32;
3800 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3805 #if LONGSIZE != SIZE32
3808 COPYNN(s, &along, sizeof(long));
3811 cdouble += (double)along;
3821 #if LONGSIZE > SIZE32
3822 if (along > 2147483647)
3823 along -= 4294967296;
3827 cdouble += (double)along;
3836 #if LONGSIZE != SIZE32
3839 COPYNN(s, &along, sizeof(long));
3842 sv_setiv(sv, (IV)along);
3843 PUSHs(sv_2mortal(sv));
3851 #if LONGSIZE > SIZE32
3852 if (along > 2147483647)
3853 along -= 4294967296;
3857 sv_setiv(sv, (IV)along);
3858 PUSHs(sv_2mortal(sv));
3866 #if LONGSIZE == SIZE32
3867 along = (strend - s) / SIZE32;
3869 unatint = natint && datumtype == 'L';
3870 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3875 #if LONGSIZE != SIZE32
3878 COPYNN(s, &aulong, sizeof(unsigned long));
3879 s += sizeof(unsigned long);
3881 cdouble += (double)aulong;
3893 if (datumtype == 'N')
3894 aulong = PerlSock_ntohl(aulong);
3897 if (datumtype == 'V')
3898 aulong = vtohl(aulong);
3901 cdouble += (double)aulong;
3910 #if LONGSIZE != SIZE32
3913 COPYNN(s, &aulong, sizeof(unsigned long));
3914 s += sizeof(unsigned long);
3916 sv_setuv(sv, (UV)aulong);
3917 PUSHs(sv_2mortal(sv));
3927 if (datumtype == 'N')
3928 aulong = PerlSock_ntohl(aulong);
3931 if (datumtype == 'V')
3932 aulong = vtohl(aulong);
3935 sv_setuv(sv, (UV)aulong);
3936 PUSHs(sv_2mortal(sv));
3942 along = (strend - s) / sizeof(char*);
3948 if (sizeof(char*) > strend - s)
3951 Copy(s, &aptr, 1, char*);
3957 PUSHs(sv_2mortal(sv));
3967 while ((len > 0) && (s < strend)) {
3968 auv = (auv << 7) | (*s & 0x7f);
3969 if (!(*s++ & 0x80)) {
3973 PUSHs(sv_2mortal(sv));
3977 else if (++bytes >= sizeof(UV)) { /* promote to string */
3981 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3982 while (s < strend) {
3983 sv = mul128(sv, *s & 0x7f);
3984 if (!(*s++ & 0x80)) {
3993 PUSHs(sv_2mortal(sv));
3998 if ((s >= strend) && bytes)
3999 Perl_croak(aTHX_ "Unterminated compressed integer");
4004 if (sizeof(char*) > strend - s)
4007 Copy(s, &aptr, 1, char*);
4012 sv_setpvn(sv, aptr, len);
4013 PUSHs(sv_2mortal(sv));
4017 along = (strend - s) / sizeof(Quad_t);
4023 if (s + sizeof(Quad_t) > strend)
4026 Copy(s, &aquad, 1, Quad_t);
4027 s += sizeof(Quad_t);
4030 if (aquad >= IV_MIN && aquad <= IV_MAX)
4031 sv_setiv(sv, (IV)aquad);
4033 sv_setnv(sv, (double)aquad);
4034 PUSHs(sv_2mortal(sv));
4038 along = (strend - s) / sizeof(Quad_t);
4044 if (s + sizeof(Uquad_t) > strend)
4047 Copy(s, &auquad, 1, Uquad_t);
4048 s += sizeof(Uquad_t);
4051 if (auquad <= UV_MAX)
4052 sv_setuv(sv, (UV)auquad);
4054 sv_setnv(sv, (double)auquad);
4055 PUSHs(sv_2mortal(sv));
4059 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4062 along = (strend - s) / sizeof(float);
4067 Copy(s, &afloat, 1, float);
4076 Copy(s, &afloat, 1, float);
4079 sv_setnv(sv, (double)afloat);
4080 PUSHs(sv_2mortal(sv));
4086 along = (strend - s) / sizeof(double);
4091 Copy(s, &adouble, 1, double);
4092 s += sizeof(double);
4100 Copy(s, &adouble, 1, double);
4101 s += sizeof(double);
4103 sv_setnv(sv, (double)adouble);
4104 PUSHs(sv_2mortal(sv));
4110 * Initialise the decode mapping. By using a table driven
4111 * algorithm, the code will be character-set independent
4112 * (and just as fast as doing character arithmetic)
4114 if (PL_uudmap['M'] == 0) {
4117 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4118 PL_uudmap[PL_uuemap[i]] = i;
4120 * Because ' ' and '`' map to the same value,
4121 * we need to decode them both the same.
4126 along = (strend - s) * 3 / 4;
4127 sv = NEWSV(42, along);
4130 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4135 len = PL_uudmap[*s++] & 077;
4137 if (s < strend && ISUUCHAR(*s))
4138 a = PL_uudmap[*s++] & 077;
4141 if (s < strend && ISUUCHAR(*s))
4142 b = PL_uudmap[*s++] & 077;
4145 if (s < strend && ISUUCHAR(*s))
4146 c = PL_uudmap[*s++] & 077;
4149 if (s < strend && ISUUCHAR(*s))
4150 d = PL_uudmap[*s++] & 077;
4153 hunk[0] = (a << 2) | (b >> 4);
4154 hunk[1] = (b << 4) | (c >> 2);
4155 hunk[2] = (c << 6) | d;
4156 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4161 else if (s[1] == '\n') /* possible checksum byte */
4164 XPUSHs(sv_2mortal(sv));
4169 if (strchr("fFdD", datumtype) ||
4170 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4174 while (checksum >= 16) {
4178 while (checksum >= 4) {
4184 along = (1 << checksum) - 1;
4185 while (cdouble < 0.0)
4187 cdouble = modf(cdouble / adouble, &trouble) * adouble;
4188 sv_setnv(sv, cdouble);
4191 if (checksum < 32) {
4192 aulong = (1 << checksum) - 1;
4195 sv_setuv(sv, (UV)culong);
4197 XPUSHs(sv_2mortal(sv));
4201 if (SP == oldsp && gimme == G_SCALAR)
4202 PUSHs(&PL_sv_undef);
4207 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4211 *hunk = PL_uuemap[len];
4212 sv_catpvn(sv, hunk, 1);
4215 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4216 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4217 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4218 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4219 sv_catpvn(sv, hunk, 4);
4224 char r = (len > 1 ? s[1] : '\0');
4225 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4226 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4227 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4228 hunk[3] = PL_uuemap[0];
4229 sv_catpvn(sv, hunk, 4);
4231 sv_catpvn(sv, "\n", 1);
4235 S_is_an_int(pTHX_ char *s, STRLEN l)
4238 SV *result = newSVpvn(s, l);
4239 char *result_c = SvPV(result, n_a); /* convenience */
4240 char *out = result_c;
4250 SvREFCNT_dec(result);
4273 SvREFCNT_dec(result);
4279 SvCUR_set(result, out - result_c);
4283 /* pnum must be '\0' terminated */
4285 S_div128(pTHX_ SV *pnum, bool *done)
4288 char *s = SvPV(pnum, len);
4297 i = m * 10 + (*t - '0');
4299 r = (i >> 7); /* r < 10 */
4306 SvCUR_set(pnum, (STRLEN) (t - s));
4313 djSP; dMARK; dORIGMARK; dTARGET;
4314 register SV *cat = TARG;
4317 register char *pat = SvPVx(*++MARK, fromlen);
4318 register char *patend = pat + fromlen;
4323 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4324 static char *space10 = " ";
4326 /* These must not be in registers: */
4341 #ifdef PERL_NATINT_PACK
4342 int natint; /* native integer */
4347 sv_setpvn(cat, "", 0);
4348 while (pat < patend) {
4349 #define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
4350 datumtype = *pat++ & 0xFF;
4351 #ifdef PERL_NATINT_PACK
4354 if (isSPACE(datumtype))
4357 char *natstr = "sSiIlL";
4359 if (strchr(natstr, datumtype)) {
4360 #ifdef PERL_NATINT_PACK
4366 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
4369 len = strchr("@Xxu", datumtype) ? 0 : items;
4372 else if (isDIGIT(*pat)) {
4374 while (isDIGIT(*pat))
4375 len = (len * 10) + (*pat++ - '0');
4381 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4382 case ',': /* grandfather in commas but with a warning */
4383 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4384 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
4387 DIE(aTHX_ "%% may only be used in unpack");
4398 if (SvCUR(cat) < len)
4399 DIE(aTHX_ "X outside of string");
4406 sv_catpvn(cat, null10, 10);
4409 sv_catpvn(cat, null10, len);
4415 aptr = SvPV(fromstr, fromlen);
4419 sv_catpvn(cat, aptr, len);
4421 sv_catpvn(cat, aptr, fromlen);
4423 if (datumtype == 'A') {
4425 sv_catpvn(cat, space10, 10);
4428 sv_catpvn(cat, space10, len);
4432 sv_catpvn(cat, null10, 10);
4435 sv_catpvn(cat, null10, len);
4442 char *savepat = pat;
4447 aptr = SvPV(fromstr, fromlen);
4452 SvCUR(cat) += (len+7)/8;
4453 SvGROW(cat, SvCUR(cat) + 1);
4454 aptr = SvPVX(cat) + aint;
4459 if (datumtype == 'B') {
4460 for (len = 0; len++ < aint;) {
4461 items |= *pat++ & 1;
4465 *aptr++ = items & 0xff;
4471 for (len = 0; len++ < aint;) {
4477 *aptr++ = items & 0xff;
4483 if (datumtype == 'B')
4484 items <<= 7 - (aint & 7);
4486 items >>= 7 - (aint & 7);
4487 *aptr++ = items & 0xff;
4489 pat = SvPVX(cat) + SvCUR(cat);
4500 char *savepat = pat;
4505 aptr = SvPV(fromstr, fromlen);
4510 SvCUR(cat) += (len+1)/2;
4511 SvGROW(cat, SvCUR(cat) + 1);
4512 aptr = SvPVX(cat) + aint;
4517 if (datumtype == 'H') {
4518 for (len = 0; len++ < aint;) {
4520 items |= ((*pat++ & 15) + 9) & 15;
4522 items |= *pat++ & 15;
4526 *aptr++ = items & 0xff;
4532 for (len = 0; len++ < aint;) {
4534 items |= (((*pat++ & 15) + 9) & 15) << 4;
4536 items |= (*pat++ & 15) << 4;
4540 *aptr++ = items & 0xff;
4546 *aptr++ = items & 0xff;
4547 pat = SvPVX(cat) + SvCUR(cat);
4559 aint = SvIV(fromstr);
4561 sv_catpvn(cat, &achar, sizeof(char));
4567 auint = SvUV(fromstr);
4568 SvGROW(cat, SvCUR(cat) + 10);
4569 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4574 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4579 afloat = (float)SvNV(fromstr);
4580 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4587 adouble = (double)SvNV(fromstr);
4588 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4594 ashort = (I16)SvIV(fromstr);
4596 ashort = PerlSock_htons(ashort);
4598 CAT16(cat, &ashort);
4604 ashort = (I16)SvIV(fromstr);
4606 ashort = htovs(ashort);
4608 CAT16(cat, &ashort);
4612 #if SHORTSIZE != SIZE16
4614 unsigned short aushort;
4618 aushort = SvUV(fromstr);
4619 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4629 aushort = (U16)SvUV(fromstr);
4630 CAT16(cat, &aushort);
4636 #if SHORTSIZE != SIZE16
4640 ashort = SvIV(fromstr);
4641 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4649 ashort = (I16)SvIV(fromstr);
4650 CAT16(cat, &ashort);
4657 auint = SvUV(fromstr);
4658 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4664 adouble = floor(SvNV(fromstr));
4667 Perl_croak(aTHX_ "Cannot compress negative numbers");
4673 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4674 adouble <= UV_MAX_cxux
4681 char buf[1 + sizeof(UV)];
4682 char *in = buf + sizeof(buf);
4683 UV auv = U_V(adouble);
4686 *--in = (auv & 0x7f) | 0x80;
4689 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4690 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4692 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4693 char *from, *result, *in;
4698 /* Copy string and check for compliance */
4699 from = SvPV(fromstr, len);
4700 if ((norm = is_an_int(from, len)) == NULL)
4701 Perl_croak(aTHX_ "can compress only unsigned integer");
4703 New('w', result, len, char);
4707 *--in = div128(norm, &done) | 0x80;
4708 result[len - 1] &= 0x7F; /* clear continue bit */
4709 sv_catpvn(cat, in, (result + len) - in);
4711 SvREFCNT_dec(norm); /* free norm */
4713 else if (SvNOKp(fromstr)) {
4714 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4715 char *in = buf + sizeof(buf);
4718 double next = floor(adouble / 128);
4719 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4720 if (--in < buf) /* this cannot happen ;-) */
4721 Perl_croak(aTHX_ "Cannot compress integer");
4723 } while (adouble > 0);
4724 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4725 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4728 Perl_croak(aTHX_ "Cannot compress non integer");
4734 aint = SvIV(fromstr);
4735 sv_catpvn(cat, (char*)&aint, sizeof(int));
4741 aulong = SvUV(fromstr);
4743 aulong = PerlSock_htonl(aulong);
4745 CAT32(cat, &aulong);
4751 aulong = SvUV(fromstr);
4753 aulong = htovl(aulong);
4755 CAT32(cat, &aulong);
4759 #if LONGSIZE != SIZE32
4763 aulong = SvUV(fromstr);
4764 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4772 aulong = SvUV(fromstr);
4773 CAT32(cat, &aulong);
4778 #if LONGSIZE != SIZE32
4782 along = SvIV(fromstr);
4783 sv_catpvn(cat, (char *)&along, sizeof(long));
4791 along = SvIV(fromstr);
4800 auquad = (Uquad_t)SvIV(fromstr);
4801 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4807 aquad = (Quad_t)SvIV(fromstr);
4808 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4811 #endif /* HAS_QUAD */
4813 len = 1; /* assume SV is correct length */
4818 if (fromstr == &PL_sv_undef)
4822 /* XXX better yet, could spirit away the string to
4823 * a safe spot and hang on to it until the result
4824 * of pack() (and all copies of the result) are
4827 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4828 Perl_warner(aTHX_ WARN_UNSAFE,
4829 "Attempt to pack pointer to temporary value");
4830 if (SvPOK(fromstr) || SvNIOK(fromstr))
4831 aptr = SvPV(fromstr,n_a);
4833 aptr = SvPV_force(fromstr,n_a);
4835 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4840 aptr = SvPV(fromstr, fromlen);
4841 SvGROW(cat, fromlen * 4 / 3);
4846 while (fromlen > 0) {
4853 doencodes(cat, aptr, todo);
4872 register I32 limit = POPi; /* note, negative is forever */
4875 register char *s = SvPV(sv, len);
4876 char *strend = s + len;
4878 register REGEXP *rx;
4882 I32 maxiters = (strend - s) + 10;
4885 I32 origlimit = limit;
4888 AV *oldstack = PL_curstack;
4889 I32 gimme = GIMME_V;
4890 I32 oldsave = PL_savestack_ix;
4891 I32 make_mortal = 1;
4892 MAGIC *mg = (MAGIC *) NULL;
4895 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4900 DIE(aTHX_ "panic: do_split");
4901 rx = pm->op_pmregexp;
4903 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4904 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4906 if (pm->op_pmreplroot)
4907 ary = GvAVn((GV*)pm->op_pmreplroot);
4908 else if (gimme != G_ARRAY)
4910 ary = (AV*)PL_curpad[0];
4912 ary = GvAVn(PL_defgv);
4913 #endif /* USE_THREADS */
4916 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4922 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4924 XPUSHs(SvTIED_obj((SV*)ary, mg));
4929 for (i = AvFILLp(ary); i >= 0; i--)
4930 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4932 /* temporarily switch stacks */
4933 SWITCHSTACK(PL_curstack, ary);
4937 base = SP - PL_stack_base;
4939 if (pm->op_pmflags & PMf_SKIPWHITE) {
4940 if (pm->op_pmflags & PMf_LOCALE) {
4941 while (isSPACE_LC(*s))
4949 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4950 SAVEINT(PL_multiline);
4951 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4955 limit = maxiters + 2;
4956 if (pm->op_pmflags & PMf_WHITE) {
4959 while (m < strend &&
4960 !((pm->op_pmflags & PMf_LOCALE)
4961 ? isSPACE_LC(*m) : isSPACE(*m)))
4966 dstr = NEWSV(30, m-s);
4967 sv_setpvn(dstr, s, m-s);
4973 while (s < strend &&
4974 ((pm->op_pmflags & PMf_LOCALE)
4975 ? isSPACE_LC(*s) : isSPACE(*s)))
4979 else if (strEQ("^", rx->precomp)) {
4982 for (m = s; m < strend && *m != '\n'; m++) ;
4986 dstr = NEWSV(30, m-s);
4987 sv_setpvn(dstr, s, m-s);
4994 else if (rx->check_substr && !rx->nparens
4995 && (rx->reganch & ROPT_CHECK_ALL)
4996 && !(rx->reganch & ROPT_ANCH)) {
4997 int tail = SvTAIL(rx->check_substr) != 0;
4999 i = SvCUR(rx->check_substr);
5000 if (i == 1 && !tail) {
5001 i = *SvPVX(rx->check_substr);
5004 for (m = s; m < strend && *m != i; m++) ;
5007 dstr = NEWSV(30, m-s);
5008 sv_setpvn(dstr, s, m-s);
5017 while (s < strend && --limit &&
5018 (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
5019 rx->check_substr, PL_multiline ? FBMrf_MULTILINE : 0)) )
5022 dstr = NEWSV(31, m-s);
5023 sv_setpvn(dstr, s, m-s);
5027 s = m + i - tail; /* Fake \n at the end */
5032 maxiters += (strend - s) * rx->nparens;
5033 while (s < strend && --limit &&
5034 CALLREGEXEC(aTHX_ rx, s, strend, orig, 1, sv, NULL, 0))
5036 TAINT_IF(RX_MATCH_TAINTED(rx));
5037 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5042 strend = s + (strend - m);
5044 m = rx->startp[0] + orig;
5045 dstr = NEWSV(32, m-s);
5046 sv_setpvn(dstr, s, m-s);
5051 for (i = 1; i <= rx->nparens; i++) {
5052 s = rx->startp[i] + orig;
5053 m = rx->endp[i] + orig;
5055 dstr = NEWSV(33, m-s);
5056 sv_setpvn(dstr, s, m-s);
5059 dstr = NEWSV(33, 0);
5065 s = rx->endp[0] + orig;
5069 LEAVE_SCOPE(oldsave);
5070 iters = (SP - PL_stack_base) - base;
5071 if (iters > maxiters)
5072 DIE(aTHX_ "Split loop");
5074 /* keep field after final delim? */
5075 if (s < strend || (iters && origlimit)) {
5076 dstr = NEWSV(34, strend-s);
5077 sv_setpvn(dstr, s, strend-s);
5083 else if (!origlimit) {
5084 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5090 SWITCHSTACK(ary, oldstack);
5091 if (SvSMAGICAL(ary)) {
5096 if (gimme == G_ARRAY) {
5098 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5106 call_method("PUSH",G_SCALAR|G_DISCARD);
5109 if (gimme == G_ARRAY) {
5110 /* EXTEND should not be needed - we just popped them */
5112 for (i=0; i < iters; i++) {
5113 SV **svp = av_fetch(ary, i, FALSE);
5114 PUSHs((svp) ? *svp : &PL_sv_undef);
5121 if (gimme == G_ARRAY)
5124 if (iters || !pm->op_pmreplroot) {
5134 Perl_unlock_condpair(pTHX_ void *svv)
5137 MAGIC *mg = mg_find((SV*)svv, 'm');
5140 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5141 MUTEX_LOCK(MgMUTEXP(mg));
5142 if (MgOWNER(mg) != thr)
5143 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5145 COND_SIGNAL(MgOWNERCONDP(mg));
5146 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5147 (unsigned long)thr, (unsigned long)svv);)
5148 MUTEX_UNLOCK(MgMUTEXP(mg));
5150 #endif /* USE_THREADS */
5163 mg = condpair_magic(sv);
5164 MUTEX_LOCK(MgMUTEXP(mg));
5165 if (MgOWNER(mg) == thr)
5166 MUTEX_UNLOCK(MgMUTEXP(mg));
5169 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5171 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5172 (unsigned long)thr, (unsigned long)sv);)
5173 MUTEX_UNLOCK(MgMUTEXP(mg));
5174 save_destructor(Perl_unlock_condpair, sv);
5176 #endif /* USE_THREADS */
5177 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5178 || SvTYPE(retsv) == SVt_PVCV) {
5179 retsv = refto(retsv);
5190 if (PL_op->op_private & OPpLVAL_INTRO)
5191 PUSHs(*save_threadsv(PL_op->op_targ));
5193 PUSHs(THREADSV(PL_op->op_targ));
5196 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5197 #endif /* USE_THREADS */