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));
409 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
410 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
413 cv = (CV*)&PL_sv_undef;
427 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
428 char *s = SvPVX(TOPs);
429 if (strnEQ(s, "CORE::", 6)) {
432 code = keyword(s + 6, SvCUR(TOPs) - 6);
433 if (code < 0) { /* Overridable. */
434 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
435 int i = 0, n = 0, seen_question = 0;
437 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
439 while (i < MAXO) { /* The slow way. */
440 if (strEQ(s + 6, PL_op_name[i])
441 || strEQ(s + 6, PL_op_desc[i]))
447 goto nonesuch; /* Should not happen... */
449 oa = PL_opargs[i] >> OASHIFT;
451 if (oa & OA_OPTIONAL) {
455 else if (seen_question)
456 goto set; /* XXXX system, exec */
457 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
458 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
461 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
462 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
466 ret = sv_2mortal(newSVpvn(str, n - 1));
468 else if (code) /* Non-Overridable */
470 else { /* None such */
472 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
476 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
478 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
487 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
489 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
505 if (GIMME != G_ARRAY) {
509 *MARK = &PL_sv_undef;
510 *MARK = refto(*MARK);
514 EXTEND_MORTAL(SP - MARK);
516 *MARK = refto(*MARK);
521 S_refto(pTHX_ SV *sv)
525 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
528 if (!(sv = LvTARG(sv)))
531 (void)SvREFCNT_inc(sv);
533 else if (SvTYPE(sv) == SVt_PVAV) {
534 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
537 (void)SvREFCNT_inc(sv);
539 else if (SvPADTMP(sv))
543 (void)SvREFCNT_inc(sv);
546 sv_upgrade(rv, SVt_RV);
560 if (sv && SvGMAGICAL(sv))
563 if (!sv || !SvROK(sv))
567 pv = sv_reftype(sv,TRUE);
568 PUSHp(pv, strlen(pv));
578 stash = PL_curcop->cop_stash;
582 char *ptr = SvPV(ssv,len);
583 if (ckWARN(WARN_UNSAFE) && len == 0)
584 Perl_warner(aTHX_ WARN_UNSAFE,
585 "Explicit blessing to '' (assuming package main)");
586 stash = gv_stashpvn(ptr, len, TRUE);
589 (void)sv_bless(TOPs, stash);
603 elem = SvPV(sv, n_a);
607 switch (elem ? *elem : '\0')
610 if (strEQ(elem, "ARRAY"))
611 tmpRef = (SV*)GvAV(gv);
614 if (strEQ(elem, "CODE"))
615 tmpRef = (SV*)GvCVu(gv);
618 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
619 tmpRef = (SV*)GvIOp(gv);
622 if (strEQ(elem, "GLOB"))
626 if (strEQ(elem, "HASH"))
627 tmpRef = (SV*)GvHV(gv);
630 if (strEQ(elem, "IO"))
631 tmpRef = (SV*)GvIOp(gv);
634 if (strEQ(elem, "NAME"))
635 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
638 if (strEQ(elem, "PACKAGE"))
639 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
642 if (strEQ(elem, "SCALAR"))
656 /* Pattern matching */
661 register unsigned char *s;
664 register I32 *sfirst;
668 if (sv == PL_lastscream) {
674 SvSCREAM_off(PL_lastscream);
675 SvREFCNT_dec(PL_lastscream);
677 PL_lastscream = SvREFCNT_inc(sv);
680 s = (unsigned char*)(SvPV(sv, len));
684 if (pos > PL_maxscream) {
685 if (PL_maxscream < 0) {
686 PL_maxscream = pos + 80;
687 New(301, PL_screamfirst, 256, I32);
688 New(302, PL_screamnext, PL_maxscream, I32);
691 PL_maxscream = pos + pos / 4;
692 Renew(PL_screamnext, PL_maxscream, I32);
696 sfirst = PL_screamfirst;
697 snext = PL_screamnext;
699 if (!sfirst || !snext)
700 DIE(aTHX_ "do_study: out of memory");
702 for (ch = 256; ch; --ch)
709 snext[pos] = sfirst[ch] - pos;
716 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
725 if (PL_op->op_flags & OPf_STACKED)
731 TARG = sv_newmortal();
736 /* Lvalue operators. */
748 djSP; dMARK; dTARGET;
758 SETi(do_chomp(TOPs));
764 djSP; dMARK; dTARGET;
765 register I32 count = 0;
768 count += do_chomp(POPs);
779 if (!sv || !SvANY(sv))
781 switch (SvTYPE(sv)) {
783 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
787 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
791 if (CvROOT(sv) || CvXSUB(sv))
808 if (!PL_op->op_private) {
817 if (SvTHINKFIRST(sv))
820 switch (SvTYPE(sv)) {
830 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
831 Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
832 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
836 /* let user-undef'd sub keep its identity */
837 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
844 SvSetMagicSV(sv, &PL_sv_undef);
848 Newz(602, gp, 1, GP);
849 GvGP(sv) = gp_ref(gp);
850 GvSV(sv) = NEWSV(72,0);
851 GvLINE(sv) = PL_curcop->cop_line;
857 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
860 SvPV_set(sv, Nullch);
873 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
874 DIE(aTHX_ PL_no_modify);
875 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
876 SvIVX(TOPs) != IV_MIN)
879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
890 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
891 DIE(aTHX_ PL_no_modify);
892 sv_setsv(TARG, TOPs);
893 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
894 SvIVX(TOPs) != IV_MAX)
897 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
911 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
912 DIE(aTHX_ PL_no_modify);
913 sv_setsv(TARG, TOPs);
914 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
915 SvIVX(TOPs) != IV_MIN)
918 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
927 /* Ordinary operators. */
931 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
934 SETn( pow( left, right) );
941 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
944 SETn( left * right );
951 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
956 DIE(aTHX_ "Illegal division by zero");
958 /* insure that 20./5. == 4. */
961 if ((NV)I_V(left) == left &&
962 (NV)I_V(right) == right &&
963 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
967 value = left / right;
971 value = left / right;
980 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
990 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
992 right = (right_neg = (i < 0)) ? -i : i;
997 right_neg = dright < 0;
1002 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1004 left = (left_neg = (i < 0)) ? -i : i;
1012 left_neg = dleft < 0;
1021 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1023 # define CAST_D2UV(d) U_V(d)
1025 # define CAST_D2UV(d) ((UV)(d))
1027 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1028 * or, in other words, precision of UV more than of NV.
1029 * But in fact the approach below turned out to be an
1030 * optimization - floor() may be slow */
1031 if (dright <= UV_MAX && dleft <= UV_MAX) {
1032 right = CAST_D2UV(dright);
1033 left = CAST_D2UV(dleft);
1038 /* Backward-compatibility clause: */
1039 dright = floor(dright + 0.5);
1040 dleft = floor(dleft + 0.5);
1043 DIE(aTHX_ "Illegal modulus zero");
1045 dans = Perl_fmod(dleft, dright);
1046 if ((left_neg != right_neg) && dans)
1047 dans = dright - dans;
1050 sv_setnv(TARG, dans);
1057 DIE(aTHX_ "Illegal modulus zero");
1060 if ((left_neg != right_neg) && ans)
1063 /* XXX may warn: unary minus operator applied to unsigned type */
1064 /* could change -foo to be (~foo)+1 instead */
1065 if (ans <= ~((UV)IV_MAX)+1)
1066 sv_setiv(TARG, ~ans+1);
1068 sv_setnv(TARG, -(NV)ans);
1071 sv_setuv(TARG, ans);
1080 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1082 register I32 count = POPi;
1083 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1085 I32 items = SP - MARK;
1088 max = items * count;
1097 repeatcpy((char*)(MARK + items), (char*)MARK,
1098 items * sizeof(SV*), count - 1);
1101 else if (count <= 0)
1104 else { /* Note: mark already snarfed by pp_list */
1109 SvSetSV(TARG, tmpstr);
1110 SvPV_force(TARG, len);
1115 SvGROW(TARG, (count * len) + 1);
1116 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1117 SvCUR(TARG) *= count;
1119 *SvEND(TARG) = '\0';
1121 (void)SvPOK_only(TARG);
1130 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1133 SETn( left - right );
1140 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1143 if (PL_op->op_private & HINT_INTEGER) {
1145 i = BWi(i) << shift;
1159 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1162 if (PL_op->op_private & HINT_INTEGER) {
1164 i = BWi(i) >> shift;
1178 djSP; tryAMAGICbinSET(lt,0);
1181 SETs(boolSV(TOPn < value));
1188 djSP; tryAMAGICbinSET(gt,0);
1191 SETs(boolSV(TOPn > value));
1198 djSP; tryAMAGICbinSET(le,0);
1201 SETs(boolSV(TOPn <= value));
1208 djSP; tryAMAGICbinSET(ge,0);
1211 SETs(boolSV(TOPn >= value));
1218 djSP; tryAMAGICbinSET(ne,0);
1221 SETs(boolSV(TOPn != value));
1228 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1235 else if (left < right)
1237 else if (left > right)
1250 djSP; tryAMAGICbinSET(slt,0);
1253 int cmp = ((PL_op->op_private & OPpLOCALE)
1254 ? sv_cmp_locale(left, right)
1255 : sv_cmp(left, right));
1256 SETs(boolSV(cmp < 0));
1263 djSP; tryAMAGICbinSET(sgt,0);
1266 int cmp = ((PL_op->op_private & OPpLOCALE)
1267 ? sv_cmp_locale(left, right)
1268 : sv_cmp(left, right));
1269 SETs(boolSV(cmp > 0));
1276 djSP; tryAMAGICbinSET(sle,0);
1279 int cmp = ((PL_op->op_private & OPpLOCALE)
1280 ? sv_cmp_locale(left, right)
1281 : sv_cmp(left, right));
1282 SETs(boolSV(cmp <= 0));
1289 djSP; tryAMAGICbinSET(sge,0);
1292 int cmp = ((PL_op->op_private & OPpLOCALE)
1293 ? sv_cmp_locale(left, right)
1294 : sv_cmp(left, right));
1295 SETs(boolSV(cmp >= 0));
1302 djSP; tryAMAGICbinSET(seq,0);
1305 SETs(boolSV(sv_eq(left, right)));
1312 djSP; tryAMAGICbinSET(sne,0);
1315 SETs(boolSV(!sv_eq(left, right)));
1322 djSP; dTARGET; tryAMAGICbin(scmp,0);
1325 int cmp = ((PL_op->op_private & OPpLOCALE)
1326 ? sv_cmp_locale(left, right)
1327 : sv_cmp(left, right));
1335 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1338 if (SvNIOKp(left) || SvNIOKp(right)) {
1339 if (PL_op->op_private & HINT_INTEGER) {
1340 IBW value = SvIV(left) & SvIV(right);
1344 UBW value = SvUV(left) & SvUV(right);
1349 do_vop(PL_op->op_type, TARG, left, right);
1358 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1361 if (SvNIOKp(left) || SvNIOKp(right)) {
1362 if (PL_op->op_private & HINT_INTEGER) {
1363 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1367 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1372 do_vop(PL_op->op_type, TARG, left, right);
1381 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1384 if (SvNIOKp(left) || SvNIOKp(right)) {
1385 if (PL_op->op_private & HINT_INTEGER) {
1386 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1390 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1395 do_vop(PL_op->op_type, TARG, left, right);
1404 djSP; dTARGET; tryAMAGICun(neg);
1409 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1411 else if (SvNIOKp(sv))
1413 else if (SvPOKp(sv)) {
1415 char *s = SvPV(sv, len);
1416 if (isIDFIRST(*s)) {
1417 sv_setpvn(TARG, "-", 1);
1420 else if (*s == '+' || *s == '-') {
1422 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1424 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1425 sv_setpvn(TARG, "-", 1);
1429 sv_setnv(TARG, -SvNV(sv));
1440 djSP; tryAMAGICunSET(not);
1441 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1447 djSP; dTARGET; tryAMAGICun(compl);
1451 if (PL_op->op_private & HINT_INTEGER) {
1452 IBW value = ~SvIV(sv);
1456 UBW value = ~SvUV(sv);
1461 register char *tmps;
1462 register long *tmpl;
1467 tmps = SvPV_force(TARG, len);
1470 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1473 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1477 for ( ; anum > 0; anum--, tmps++)
1486 /* integer versions of some of the above */
1490 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1493 SETi( left * right );
1500 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1504 DIE(aTHX_ "Illegal division by zero");
1505 value = POPi / value;
1513 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1517 DIE(aTHX_ "Illegal modulus zero");
1518 SETi( left % right );
1525 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1528 SETi( left + right );
1535 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1538 SETi( left - right );
1545 djSP; tryAMAGICbinSET(lt,0);
1548 SETs(boolSV(left < right));
1555 djSP; tryAMAGICbinSET(gt,0);
1558 SETs(boolSV(left > right));
1565 djSP; tryAMAGICbinSET(le,0);
1568 SETs(boolSV(left <= right));
1575 djSP; tryAMAGICbinSET(ge,0);
1578 SETs(boolSV(left >= right));
1585 djSP; tryAMAGICbinSET(eq,0);
1588 SETs(boolSV(left == right));
1595 djSP; tryAMAGICbinSET(ne,0);
1598 SETs(boolSV(left != right));
1605 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1612 else if (left < right)
1623 djSP; dTARGET; tryAMAGICun(neg);
1628 /* High falutin' math. */
1632 djSP; dTARGET; tryAMAGICbin(atan2,0);
1635 SETn(Perl_atan2(left, right));
1642 djSP; dTARGET; tryAMAGICun(sin);
1646 value = Perl_sin(value);
1654 djSP; dTARGET; tryAMAGICun(cos);
1658 value = Perl_cos(value);
1664 /* Support Configure command-line overrides for rand() functions.
1665 After 5.005, perhaps we should replace this by Configure support
1666 for drand48(), random(), or rand(). For 5.005, though, maintain
1667 compatibility by calling rand() but allow the user to override it.
1668 See INSTALL for details. --Andy Dougherty 15 July 1998
1670 /* Now it's after 5.005, and Configure supports drand48() and random(),
1671 in addition to rand(). So the overrides should not be needed any more.
1672 --Jarkko Hietaniemi 27 September 1998
1675 #ifndef HAS_DRAND48_PROTO
1676 extern double drand48 (void);
1689 if (!PL_srand_called) {
1690 (void)seedDrand01((Rand_seed_t)seed());
1691 PL_srand_called = TRUE;
1706 (void)seedDrand01((Rand_seed_t)anum);
1707 PL_srand_called = TRUE;
1716 * This is really just a quick hack which grabs various garbage
1717 * values. It really should be a real hash algorithm which
1718 * spreads the effect of every input bit onto every output bit,
1719 * if someone who knows about such things would bother to write it.
1720 * Might be a good idea to add that function to CORE as well.
1721 * No numbers below come from careful analysis or anything here,
1722 * except they are primes and SEED_C1 > 1E6 to get a full-width
1723 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1724 * probably be bigger too.
1727 # define SEED_C1 1000003
1728 #define SEED_C4 73819
1730 # define SEED_C1 25747
1731 #define SEED_C4 20639
1735 #define SEED_C5 26107
1738 #ifndef PERL_NO_DEV_RANDOM
1743 # include <starlet.h>
1744 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1745 * in 100-ns units, typically incremented ever 10 ms. */
1746 unsigned int when[2];
1748 # ifdef HAS_GETTIMEOFDAY
1749 struct timeval when;
1755 /* This test is an escape hatch, this symbol isn't set by Configure. */
1756 #ifndef PERL_NO_DEV_RANDOM
1757 #ifndef PERL_RANDOM_DEVICE
1758 /* /dev/random isn't used by default because reads from it will block
1759 * if there isn't enough entropy available. You can compile with
1760 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1761 * is enough real entropy to fill the seed. */
1762 # define PERL_RANDOM_DEVICE "/dev/urandom"
1764 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1766 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1775 _ckvmssts(sys$gettim(when));
1776 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1778 # ifdef HAS_GETTIMEOFDAY
1779 gettimeofday(&when,(struct timezone *) 0);
1780 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1783 u = (U32)SEED_C1 * when;
1786 u += SEED_C3 * (U32)getpid();
1787 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1788 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1789 u += SEED_C5 * (U32)PTR2UV(&when);
1796 djSP; dTARGET; tryAMAGICun(exp);
1800 value = Perl_exp(value);
1808 djSP; dTARGET; tryAMAGICun(log);
1813 RESTORE_NUMERIC_STANDARD();
1814 DIE(aTHX_ "Can't take log of %g", value);
1816 value = Perl_log(value);
1824 djSP; dTARGET; tryAMAGICun(sqrt);
1829 RESTORE_NUMERIC_STANDARD();
1830 DIE(aTHX_ "Can't take sqrt of %g", value);
1832 value = Perl_sqrt(value);
1845 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1851 (void)Perl_modf(value, &value);
1853 (void)Perl_modf(-value, &value);
1868 djSP; dTARGET; tryAMAGICun(abs);
1873 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1874 (iv = SvIVX(TOPs)) != IV_MIN) {
1896 XPUSHn(scan_hex(tmps, 99, &argtype));
1909 while (*tmps && isSPACE(*tmps))
1914 value = scan_hex(++tmps, 99, &argtype);
1915 else if (*tmps == 'b')
1916 value = scan_bin(++tmps, 99, &argtype);
1918 value = scan_oct(tmps, 99, &argtype);
1930 SETi( sv_len_utf8(TOPs) );
1934 SETi( sv_len(TOPs) );
1948 I32 lvalue = PL_op->op_flags & OPf_MOD;
1950 I32 arybase = PL_curcop->cop_arybase;
1954 SvTAINTED_off(TARG); /* decontaminate */
1958 repl = SvPV(sv, repl_len);
1965 tmps = SvPV(sv, curlen);
1967 utfcurlen = sv_len_utf8(sv);
1968 if (utfcurlen == curlen)
1976 if (pos >= arybase) {
1994 else if (len >= 0) {
1996 if (rem > (I32)curlen)
2010 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2011 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2016 sv_pos_u2b(sv, &pos, &rem);
2018 sv_setpvn(TARG, tmps, rem);
2019 if (lvalue) { /* it's an lvalue! */
2020 if (!SvGMAGICAL(sv)) {
2024 if (ckWARN(WARN_SUBSTR))
2025 Perl_warner(aTHX_ WARN_SUBSTR,
2026 "Attempt to use reference as lvalue in substr");
2028 if (SvOK(sv)) /* is it defined ? */
2029 (void)SvPOK_only(sv);
2031 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2034 if (SvTYPE(TARG) < SVt_PVLV) {
2035 sv_upgrade(TARG, SVt_PVLV);
2036 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2040 if (LvTARG(TARG) != sv) {
2042 SvREFCNT_dec(LvTARG(TARG));
2043 LvTARG(TARG) = SvREFCNT_inc(sv);
2045 LvTARGOFF(TARG) = pos;
2046 LvTARGLEN(TARG) = rem;
2049 sv_insert(sv, pos, rem, repl, repl_len);
2052 PUSHs(TARG); /* avoid SvSETMAGIC here */
2059 register I32 size = POPi;
2060 register I32 offset = POPi;
2061 register SV *src = POPs;
2062 I32 lvalue = PL_op->op_flags & OPf_MOD;
2064 SvTAINTED_off(TARG); /* decontaminate */
2065 if (lvalue) { /* it's an lvalue! */
2066 if (SvTYPE(TARG) < SVt_PVLV) {
2067 sv_upgrade(TARG, SVt_PVLV);
2068 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2071 if (LvTARG(TARG) != src) {
2073 SvREFCNT_dec(LvTARG(TARG));
2074 LvTARG(TARG) = SvREFCNT_inc(src);
2076 LvTARGOFF(TARG) = offset;
2077 LvTARGLEN(TARG) = size;
2080 sv_setuv(TARG, do_vecget(src, offset, size));
2095 I32 arybase = PL_curcop->cop_arybase;
2100 offset = POPi - arybase;
2103 tmps = SvPV(big, biglen);
2104 if (IN_UTF8 && offset > 0)
2105 sv_pos_u2b(big, &offset, 0);
2108 else if (offset > biglen)
2110 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2111 (unsigned char*)tmps + biglen, little, 0)))
2114 retval = tmps2 - tmps;
2115 if (IN_UTF8 && retval > 0)
2116 sv_pos_b2u(big, &retval);
2117 PUSHi(retval + arybase);
2132 I32 arybase = PL_curcop->cop_arybase;
2138 tmps2 = SvPV(little, llen);
2139 tmps = SvPV(big, blen);
2143 if (IN_UTF8 && offset > 0)
2144 sv_pos_u2b(big, &offset, 0);
2145 offset = offset - arybase + llen;
2149 else if (offset > blen)
2151 if (!(tmps2 = rninstr(tmps, tmps + offset,
2152 tmps2, tmps2 + llen)))
2155 retval = tmps2 - tmps;
2156 if (IN_UTF8 && retval > 0)
2157 sv_pos_b2u(big, &retval);
2158 PUSHi(retval + arybase);
2164 djSP; dMARK; dORIGMARK; dTARGET;
2165 do_sprintf(TARG, SP-MARK, MARK+1);
2166 TAINT_IF(SvTAINTED(TARG));
2177 U8 *tmps = (U8*)POPpx;
2180 if (IN_UTF8 && (*tmps & 0x80))
2181 value = utf8_to_uv(tmps, &retlen);
2183 value = (UV)(*tmps & 255);
2194 (void)SvUPGRADE(TARG,SVt_PV);
2196 if (IN_UTF8 && value >= 128) {
2199 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2200 SvCUR_set(TARG, tmps - SvPVX(TARG));
2202 (void)SvPOK_only(TARG);
2212 (void)SvPOK_only(TARG);
2219 djSP; dTARGET; dPOPTOPssrl;
2222 char *tmps = SvPV(left, n_a);
2224 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2226 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2230 "The crypt() function is unimplemented due to excessive paranoia.");
2243 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2247 UV uv = utf8_to_uv(s, &ulen);
2249 if (PL_op->op_private & OPpLOCALE) {
2252 uv = toTITLE_LC_uni(uv);
2255 uv = toTITLE_utf8(s);
2257 tend = uv_to_utf8(tmpbuf, uv);
2259 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2261 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2262 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2266 s = (U8*)SvPV_force(sv, slen);
2267 Copy(tmpbuf, s, ulen, U8);
2271 if (!SvPADTMP(sv)) {
2277 s = (U8*)SvPV_force(sv, slen);
2279 if (PL_op->op_private & OPpLOCALE) {
2282 *s = toUPPER_LC(*s);
2300 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2304 UV uv = utf8_to_uv(s, &ulen);
2306 if (PL_op->op_private & OPpLOCALE) {
2309 uv = toLOWER_LC_uni(uv);
2312 uv = toLOWER_utf8(s);
2314 tend = uv_to_utf8(tmpbuf, uv);
2316 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2318 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2319 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2323 s = (U8*)SvPV_force(sv, slen);
2324 Copy(tmpbuf, s, ulen, U8);
2328 if (!SvPADTMP(sv)) {
2334 s = (U8*)SvPV_force(sv, slen);
2336 if (PL_op->op_private & OPpLOCALE) {
2339 *s = toLOWER_LC(*s);
2364 s = (U8*)SvPV(sv,len);
2366 sv_setpvn(TARG, "", 0);
2370 (void)SvUPGRADE(TARG, SVt_PV);
2371 SvGROW(TARG, (len * 2) + 1);
2372 (void)SvPOK_only(TARG);
2373 d = (U8*)SvPVX(TARG);
2375 if (PL_op->op_private & OPpLOCALE) {
2379 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2385 d = uv_to_utf8(d, toUPPER_utf8( s ));
2390 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2395 if (!SvPADTMP(sv)) {
2401 s = (U8*)SvPV_force(sv, len);
2403 register U8 *send = s + len;
2405 if (PL_op->op_private & OPpLOCALE) {
2408 for (; s < send; s++)
2409 *s = toUPPER_LC(*s);
2412 for (; s < send; s++)
2435 s = (U8*)SvPV(sv,len);
2437 sv_setpvn(TARG, "", 0);
2441 (void)SvUPGRADE(TARG, SVt_PV);
2442 SvGROW(TARG, (len * 2) + 1);
2443 (void)SvPOK_only(TARG);
2444 d = (U8*)SvPVX(TARG);
2446 if (PL_op->op_private & OPpLOCALE) {
2450 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2456 d = uv_to_utf8(d, toLOWER_utf8(s));
2461 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2466 if (!SvPADTMP(sv)) {
2473 s = (U8*)SvPV_force(sv, len);
2475 register U8 *send = s + len;
2477 if (PL_op->op_private & OPpLOCALE) {
2480 for (; s < send; s++)
2481 *s = toLOWER_LC(*s);
2484 for (; s < send; s++)
2499 register char *s = SvPV(sv,len);
2503 (void)SvUPGRADE(TARG, SVt_PV);
2504 SvGROW(TARG, (len * 2) + 1);
2509 STRLEN ulen = UTF8SKIP(s);
2532 SvCUR_set(TARG, d - SvPVX(TARG));
2533 (void)SvPOK_only(TARG);
2536 sv_setpvn(TARG, s, len);
2538 if (SvSMAGICAL(TARG))
2547 djSP; dMARK; dORIGMARK;
2549 register AV* av = (AV*)POPs;
2550 register I32 lval = PL_op->op_flags & OPf_MOD;
2551 I32 arybase = PL_curcop->cop_arybase;
2554 if (SvTYPE(av) == SVt_PVAV) {
2555 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2557 for (svp = MARK + 1; svp <= SP; svp++) {
2562 if (max > AvMAX(av))
2565 while (++MARK <= SP) {
2566 elem = SvIVx(*MARK);
2570 svp = av_fetch(av, elem, lval);
2572 if (!svp || *svp == &PL_sv_undef)
2573 DIE(aTHX_ PL_no_aelem, elem);
2574 if (PL_op->op_private & OPpLVAL_INTRO)
2575 save_aelem(av, elem, svp);
2577 *MARK = svp ? *svp : &PL_sv_undef;
2580 if (GIMME != G_ARRAY) {
2588 /* Associative arrays. */
2593 HV *hash = (HV*)POPs;
2595 I32 gimme = GIMME_V;
2596 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2599 /* might clobber stack_sp */
2600 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2605 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2606 if (gimme == G_ARRAY) {
2609 /* might clobber stack_sp */
2611 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2616 else if (gimme == G_SCALAR)
2635 I32 gimme = GIMME_V;
2636 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2640 if (PL_op->op_private & OPpSLICE) {
2644 hvtype = SvTYPE(hv);
2645 while (++MARK <= SP) {
2646 if (hvtype == SVt_PVHV)
2647 sv = hv_delete_ent(hv, *MARK, discard, 0);
2649 DIE(aTHX_ "Not a HASH reference");
2650 *MARK = sv ? sv : &PL_sv_undef;
2654 else if (gimme == G_SCALAR) {
2663 if (SvTYPE(hv) == SVt_PVHV)
2664 sv = hv_delete_ent(hv, keysv, discard, 0);
2666 DIE(aTHX_ "Not a HASH reference");
2680 if (SvTYPE(hv) == SVt_PVHV) {
2681 if (hv_exists_ent(hv, tmpsv, 0))
2684 else if (SvTYPE(hv) == SVt_PVAV) {
2685 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2689 DIE(aTHX_ "Not a HASH reference");
2696 djSP; dMARK; dORIGMARK;
2697 register HV *hv = (HV*)POPs;
2698 register I32 lval = PL_op->op_flags & OPf_MOD;
2699 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2701 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2702 DIE(aTHX_ "Can't localize pseudo-hash element");
2704 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2705 while (++MARK <= SP) {
2709 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2710 svp = he ? &HeVAL(he) : 0;
2713 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2716 if (!svp || *svp == &PL_sv_undef) {
2718 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2720 if (PL_op->op_private & OPpLVAL_INTRO)
2721 save_helem(hv, keysv, svp);
2723 *MARK = svp ? *svp : &PL_sv_undef;
2726 if (GIMME != G_ARRAY) {
2734 /* List operators. */
2739 if (GIMME != G_ARRAY) {
2741 *MARK = *SP; /* unwanted list, return last item */
2743 *MARK = &PL_sv_undef;
2752 SV **lastrelem = PL_stack_sp;
2753 SV **lastlelem = PL_stack_base + POPMARK;
2754 SV **firstlelem = PL_stack_base + POPMARK + 1;
2755 register SV **firstrelem = lastlelem + 1;
2756 I32 arybase = PL_curcop->cop_arybase;
2757 I32 lval = PL_op->op_flags & OPf_MOD;
2758 I32 is_something_there = lval;
2760 register I32 max = lastrelem - lastlelem;
2761 register SV **lelem;
2764 if (GIMME != G_ARRAY) {
2765 ix = SvIVx(*lastlelem);
2770 if (ix < 0 || ix >= max)
2771 *firstlelem = &PL_sv_undef;
2773 *firstlelem = firstrelem[ix];
2779 SP = firstlelem - 1;
2783 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2789 if (ix < 0 || ix >= max)
2790 *lelem = &PL_sv_undef;
2792 is_something_there = TRUE;
2793 if (!(*lelem = firstrelem[ix]))
2794 *lelem = &PL_sv_undef;
2797 if (is_something_there)
2800 SP = firstlelem - 1;
2806 djSP; dMARK; dORIGMARK;
2807 I32 items = SP - MARK;
2808 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2809 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2816 djSP; dMARK; dORIGMARK;
2817 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2821 SV *val = NEWSV(46, 0);
2823 sv_setsv(val, *++MARK);
2824 else if (ckWARN(WARN_UNSAFE))
2825 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2826 (void)hv_store_ent(hv,key,val,0);
2835 djSP; dMARK; dORIGMARK;
2836 register AV *ary = (AV*)*++MARK;
2840 register I32 offset;
2841 register I32 length;
2848 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2849 *MARK-- = SvTIED_obj((SV*)ary, mg);
2853 call_method("SPLICE",GIMME_V);
2862 offset = i = SvIVx(*MARK);
2864 offset += AvFILLp(ary) + 1;
2866 offset -= PL_curcop->cop_arybase;
2868 DIE(aTHX_ PL_no_aelem, i);
2870 length = SvIVx(*MARK++);
2872 length += AvFILLp(ary) - offset + 1;
2878 length = AvMAX(ary) + 1; /* close enough to infinity */
2882 length = AvMAX(ary) + 1;
2884 if (offset > AvFILLp(ary) + 1)
2885 offset = AvFILLp(ary) + 1;
2886 after = AvFILLp(ary) + 1 - (offset + length);
2887 if (after < 0) { /* not that much array */
2888 length += after; /* offset+length now in array */
2894 /* At this point, MARK .. SP-1 is our new LIST */
2897 diff = newlen - length;
2898 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2901 if (diff < 0) { /* shrinking the area */
2903 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2904 Copy(MARK, tmparyval, newlen, SV*);
2907 MARK = ORIGMARK + 1;
2908 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2909 MEXTEND(MARK, length);
2910 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2912 EXTEND_MORTAL(length);
2913 for (i = length, dst = MARK; i; i--) {
2914 sv_2mortal(*dst); /* free them eventualy */
2921 *MARK = AvARRAY(ary)[offset+length-1];
2924 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2925 SvREFCNT_dec(*dst++); /* free them now */
2928 AvFILLp(ary) += diff;
2930 /* pull up or down? */
2932 if (offset < after) { /* easier to pull up */
2933 if (offset) { /* esp. if nothing to pull */
2934 src = &AvARRAY(ary)[offset-1];
2935 dst = src - diff; /* diff is negative */
2936 for (i = offset; i > 0; i--) /* can't trust Copy */
2940 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2944 if (after) { /* anything to pull down? */
2945 src = AvARRAY(ary) + offset + length;
2946 dst = src + diff; /* diff is negative */
2947 Move(src, dst, after, SV*);
2949 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2950 /* avoid later double free */
2954 dst[--i] = &PL_sv_undef;
2957 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2959 *dst = NEWSV(46, 0);
2960 sv_setsv(*dst++, *src++);
2962 Safefree(tmparyval);
2965 else { /* no, expanding (or same) */
2967 New(452, tmparyval, length, SV*); /* so remember deletion */
2968 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2971 if (diff > 0) { /* expanding */
2973 /* push up or down? */
2975 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2979 Move(src, dst, offset, SV*);
2981 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2983 AvFILLp(ary) += diff;
2986 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2987 av_extend(ary, AvFILLp(ary) + diff);
2988 AvFILLp(ary) += diff;
2991 dst = AvARRAY(ary) + AvFILLp(ary);
2993 for (i = after; i; i--) {
3000 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3001 *dst = NEWSV(46, 0);
3002 sv_setsv(*dst++, *src++);
3004 MARK = ORIGMARK + 1;
3005 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3007 Copy(tmparyval, MARK, length, SV*);
3009 EXTEND_MORTAL(length);
3010 for (i = length, dst = MARK; i; i--) {
3011 sv_2mortal(*dst); /* free them eventualy */
3015 Safefree(tmparyval);
3019 else if (length--) {
3020 *MARK = tmparyval[length];
3023 while (length-- > 0)
3024 SvREFCNT_dec(tmparyval[length]);
3026 Safefree(tmparyval);
3029 *MARK = &PL_sv_undef;
3037 djSP; dMARK; dORIGMARK; dTARGET;
3038 register AV *ary = (AV*)*++MARK;
3039 register SV *sv = &PL_sv_undef;
3042 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3043 *MARK-- = SvTIED_obj((SV*)ary, mg);
3047 call_method("PUSH",G_SCALAR|G_DISCARD);
3052 /* Why no pre-extend of ary here ? */
3053 for (++MARK; MARK <= SP; MARK++) {
3056 sv_setsv(sv, *MARK);
3061 PUSHi( AvFILL(ary) + 1 );
3069 SV *sv = av_pop(av);
3071 (void)sv_2mortal(sv);
3080 SV *sv = av_shift(av);
3085 (void)sv_2mortal(sv);
3092 djSP; dMARK; dORIGMARK; dTARGET;
3093 register AV *ary = (AV*)*++MARK;
3098 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3099 *MARK-- = SvTIED_obj((SV*)ary, mg);
3103 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3108 av_unshift(ary, SP - MARK);
3111 sv_setsv(sv, *++MARK);
3112 (void)av_store(ary, i++, sv);
3116 PUSHi( AvFILL(ary) + 1 );
3126 if (GIMME == G_ARRAY) {
3137 register char *down;
3143 do_join(TARG, &PL_sv_no, MARK, SP);
3145 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3146 up = SvPV_force(TARG, len);
3148 if (IN_UTF8) { /* first reverse each character */
3149 U8* s = (U8*)SvPVX(TARG);
3150 U8* send = (U8*)(s + len);
3159 down = (char*)(s - 1);
3160 if (s > send || !((*down & 0xc0) == 0x80)) {
3161 if (ckWARN_d(WARN_UTF8))
3162 Perl_warner(aTHX_ WARN_UTF8,
3163 "Malformed UTF-8 character");
3175 down = SvPVX(TARG) + len - 1;
3181 (void)SvPOK_only(TARG);
3190 S_mul128(pTHX_ SV *sv, U8 m)
3193 char *s = SvPV(sv, len);
3197 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3198 SV *tmpNew = newSVpvn("0000000000", 10);
3200 sv_catsv(tmpNew, sv);
3201 SvREFCNT_dec(sv); /* free old sv */
3206 while (!*t) /* trailing '\0'? */
3209 i = ((*t - '0') << 7) + m;
3210 *(t--) = '0' + (i % 10);
3216 /* Explosives and implosives. */
3218 #if 'I' == 73 && 'J' == 74
3219 /* On an ASCII/ISO kind of system */
3220 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3223 Some other sort of character set - use memchr() so we don't match
3226 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3234 I32 gimme = GIMME_V;
3238 register char *pat = SvPV(left, llen);
3239 register char *s = SvPV(right, rlen);
3240 char *strend = s + rlen;
3242 register char *patend = pat + llen;
3247 /* These must not be in registers: */
3264 register U32 culong;
3267 #ifdef PERL_NATINT_PACK
3268 int natint; /* native integer */
3269 int unatint; /* unsigned native integer */
3272 if (gimme != G_ARRAY) { /* arrange to do first one only */
3274 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3275 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3277 while (isDIGIT(*patend) || *patend == '*')
3283 while (pat < patend) {
3285 datumtype = *pat++ & 0xFF;
3286 #ifdef PERL_NATINT_PACK
3289 if (isSPACE(datumtype))
3291 if (datumtype == '#') {
3292 while (pat < patend && *pat != '\n')
3297 char *natstr = "sSiIlL";
3299 if (strchr(natstr, datumtype)) {
3300 #ifdef PERL_NATINT_PACK
3306 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3310 else if (*pat == '*') {
3311 len = strend - strbeg; /* long enough */
3314 else if (isDIGIT(*pat)) {
3316 while (isDIGIT(*pat)) {
3317 len = (len * 10) + (*pat++ - '0');
3319 DIE(aTHX_ "Repeat count in unpack overflows");
3323 len = (datumtype != '@');
3326 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3327 case ',': /* grandfather in commas but with a warning */
3328 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3329 Perl_warner(aTHX_ WARN_UNSAFE,
3330 "Invalid type in unpack: '%c'", (int)datumtype);
3333 if (len == 1 && pat[-1] != '1')
3342 if (len > strend - strbeg)
3343 DIE(aTHX_ "@ outside of string");
3347 if (len > s - strbeg)
3348 DIE(aTHX_ "X outside of string");
3352 if (len > strend - s)
3353 DIE(aTHX_ "x outside of string");
3358 DIE(aTHX_ "/ must follow a numeric type");
3359 if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
3360 DIE(aTHX_ "/ must be followed by a, A or Z");
3363 pat++; /* ignore '*' for compatibility with pack */
3365 DIE(aTHX_ "/ cannot take a count" );
3371 if (len > strend - s)
3374 goto uchar_checksum;
3375 sv = NEWSV(35, len);
3376 sv_setpvn(sv, s, len);
3378 if (datumtype == 'A' || datumtype == 'Z') {
3379 aptr = s; /* borrow register */
3380 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3385 else { /* 'A' strips both nulls and spaces */
3386 s = SvPVX(sv) + len - 1;
3387 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3391 SvCUR_set(sv, s - SvPVX(sv));
3392 s = aptr; /* unborrow register */
3394 XPUSHs(sv_2mortal(sv));
3398 if (pat[-1] == '*' || len > (strend - s) * 8)
3399 len = (strend - s) * 8;
3402 Newz(601, PL_bitcount, 256, char);
3403 for (bits = 1; bits < 256; bits++) {
3404 if (bits & 1) PL_bitcount[bits]++;
3405 if (bits & 2) PL_bitcount[bits]++;
3406 if (bits & 4) PL_bitcount[bits]++;
3407 if (bits & 8) PL_bitcount[bits]++;
3408 if (bits & 16) PL_bitcount[bits]++;
3409 if (bits & 32) PL_bitcount[bits]++;
3410 if (bits & 64) PL_bitcount[bits]++;
3411 if (bits & 128) PL_bitcount[bits]++;
3415 culong += PL_bitcount[*(unsigned char*)s++];
3420 if (datumtype == 'b') {
3422 if (bits & 1) culong++;
3428 if (bits & 128) culong++;
3435 sv = NEWSV(35, len + 1);
3438 aptr = pat; /* borrow register */
3440 if (datumtype == 'b') {
3442 for (len = 0; len < aint; len++) {
3443 if (len & 7) /*SUPPRESS 595*/
3447 *pat++ = '0' + (bits & 1);
3452 for (len = 0; len < aint; len++) {
3457 *pat++ = '0' + ((bits & 128) != 0);
3461 pat = aptr; /* unborrow register */
3462 XPUSHs(sv_2mortal(sv));
3466 if (pat[-1] == '*' || len > (strend - s) * 2)
3467 len = (strend - s) * 2;
3468 sv = NEWSV(35, len + 1);
3471 aptr = pat; /* borrow register */
3473 if (datumtype == 'h') {
3475 for (len = 0; len < aint; len++) {
3480 *pat++ = PL_hexdigit[bits & 15];
3485 for (len = 0; len < aint; len++) {
3490 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3494 pat = aptr; /* unborrow register */
3495 XPUSHs(sv_2mortal(sv));
3498 if (len > strend - s)
3503 if (aint >= 128) /* fake up signed chars */
3513 if (aint >= 128) /* fake up signed chars */
3516 sv_setiv(sv, (IV)aint);
3517 PUSHs(sv_2mortal(sv));
3522 if (len > strend - s)
3537 sv_setiv(sv, (IV)auint);
3538 PUSHs(sv_2mortal(sv));
3543 if (len > strend - s)
3546 while (len-- > 0 && s < strend) {
3547 auint = utf8_to_uv((U8*)s, &along);
3550 cdouble += (NV)auint;
3558 while (len-- > 0 && s < strend) {
3559 auint = utf8_to_uv((U8*)s, &along);
3562 sv_setuv(sv, (UV)auint);
3563 PUSHs(sv_2mortal(sv));
3568 #if SHORTSIZE == SIZE16
3569 along = (strend - s) / SIZE16;
3571 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3576 #if SHORTSIZE != SIZE16
3580 COPYNN(s, &ashort, sizeof(short));
3591 #if SHORTSIZE > SIZE16
3603 #if SHORTSIZE != SIZE16
3607 COPYNN(s, &ashort, sizeof(short));
3610 sv_setiv(sv, (IV)ashort);
3611 PUSHs(sv_2mortal(sv));
3619 #if SHORTSIZE > SIZE16
3625 sv_setiv(sv, (IV)ashort);
3626 PUSHs(sv_2mortal(sv));
3634 #if SHORTSIZE == SIZE16
3635 along = (strend - s) / SIZE16;
3637 unatint = natint && datumtype == 'S';
3638 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3643 #if SHORTSIZE != SIZE16
3645 unsigned short aushort;
3647 COPYNN(s, &aushort, sizeof(unsigned short));
3648 s += sizeof(unsigned short);
3656 COPY16(s, &aushort);
3659 if (datumtype == 'n')
3660 aushort = PerlSock_ntohs(aushort);
3663 if (datumtype == 'v')
3664 aushort = vtohs(aushort);
3673 #if SHORTSIZE != SIZE16
3675 unsigned short aushort;
3677 COPYNN(s, &aushort, sizeof(unsigned short));
3678 s += sizeof(unsigned short);
3680 sv_setiv(sv, (UV)aushort);
3681 PUSHs(sv_2mortal(sv));
3688 COPY16(s, &aushort);
3692 if (datumtype == 'n')
3693 aushort = PerlSock_ntohs(aushort);
3696 if (datumtype == 'v')
3697 aushort = vtohs(aushort);
3699 sv_setiv(sv, (UV)aushort);
3700 PUSHs(sv_2mortal(sv));
3706 along = (strend - s) / sizeof(int);
3711 Copy(s, &aint, 1, int);
3714 cdouble += (NV)aint;
3723 Copy(s, &aint, 1, int);
3727 /* Without the dummy below unpack("i", pack("i",-1))
3728 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3729 * cc with optimization turned on.
3731 * The bug was detected in
3732 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3733 * with optimization (-O4) turned on.
3734 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3735 * does not have this problem even with -O4.
3737 * This bug was reported as DECC_BUGS 1431
3738 * and tracked internally as GEM_BUGS 7775.
3740 * The bug is fixed in
3741 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3742 * UNIX V4.0F support: DEC C V5.9-006 or later
3743 * UNIX V4.0E support: DEC C V5.8-011 or later
3746 * See also few lines later for the same bug.
3749 sv_setiv(sv, (IV)aint) :
3751 sv_setiv(sv, (IV)aint);
3752 PUSHs(sv_2mortal(sv));
3757 along = (strend - s) / sizeof(unsigned int);
3762 Copy(s, &auint, 1, unsigned int);
3763 s += sizeof(unsigned int);
3765 cdouble += (NV)auint;
3774 Copy(s, &auint, 1, unsigned int);
3775 s += sizeof(unsigned int);
3778 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3779 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3780 * See details few lines earlier. */
3782 sv_setuv(sv, (UV)auint) :
3784 sv_setuv(sv, (UV)auint);
3785 PUSHs(sv_2mortal(sv));
3790 #if LONGSIZE == SIZE32
3791 along = (strend - s) / SIZE32;
3793 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3798 #if LONGSIZE != SIZE32
3802 COPYNN(s, &along, sizeof(long));
3805 cdouble += (NV)along;
3815 #if LONGSIZE > SIZE32
3816 if (along > 2147483647)
3817 along -= 4294967296;
3821 cdouble += (NV)along;
3830 #if LONGSIZE != SIZE32
3834 COPYNN(s, &along, sizeof(long));
3837 sv_setiv(sv, (IV)along);
3838 PUSHs(sv_2mortal(sv));
3846 #if LONGSIZE > SIZE32
3847 if (along > 2147483647)
3848 along -= 4294967296;
3852 sv_setiv(sv, (IV)along);
3853 PUSHs(sv_2mortal(sv));
3861 #if LONGSIZE == SIZE32
3862 along = (strend - s) / SIZE32;
3864 unatint = natint && datumtype == 'L';
3865 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3870 #if LONGSIZE != SIZE32
3872 unsigned long aulong;
3874 COPYNN(s, &aulong, sizeof(unsigned long));
3875 s += sizeof(unsigned long);
3877 cdouble += (NV)aulong;
3889 if (datumtype == 'N')
3890 aulong = PerlSock_ntohl(aulong);
3893 if (datumtype == 'V')
3894 aulong = vtohl(aulong);
3897 cdouble += (NV)aulong;
3906 #if LONGSIZE != SIZE32
3908 unsigned long aulong;
3910 COPYNN(s, &aulong, sizeof(unsigned long));
3911 s += sizeof(unsigned long);
3913 sv_setuv(sv, (UV)aulong);
3914 PUSHs(sv_2mortal(sv));
3924 if (datumtype == 'N')
3925 aulong = PerlSock_ntohl(aulong);
3928 if (datumtype == 'V')
3929 aulong = vtohl(aulong);
3932 sv_setuv(sv, (UV)aulong);
3933 PUSHs(sv_2mortal(sv));
3939 along = (strend - s) / sizeof(char*);
3945 if (sizeof(char*) > strend - s)
3948 Copy(s, &aptr, 1, char*);
3954 PUSHs(sv_2mortal(sv));
3964 while ((len > 0) && (s < strend)) {
3965 auv = (auv << 7) | (*s & 0x7f);
3966 if (!(*s++ & 0x80)) {
3970 PUSHs(sv_2mortal(sv));
3974 else if (++bytes >= sizeof(UV)) { /* promote to string */
3978 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3979 while (s < strend) {
3980 sv = mul128(sv, *s & 0x7f);
3981 if (!(*s++ & 0x80)) {
3990 PUSHs(sv_2mortal(sv));
3995 if ((s >= strend) && bytes)
3996 DIE(aTHX_ "Unterminated compressed integer");
4001 if (sizeof(char*) > strend - s)
4004 Copy(s, &aptr, 1, char*);
4009 sv_setpvn(sv, aptr, len);
4010 PUSHs(sv_2mortal(sv));
4014 along = (strend - s) / sizeof(Quad_t);
4020 if (s + sizeof(Quad_t) > strend)
4023 Copy(s, &aquad, 1, Quad_t);
4024 s += sizeof(Quad_t);
4027 if (aquad >= IV_MIN && aquad <= IV_MAX)
4028 sv_setiv(sv, (IV)aquad);
4030 sv_setnv(sv, (NV)aquad);
4031 PUSHs(sv_2mortal(sv));
4035 along = (strend - s) / sizeof(Quad_t);
4041 if (s + sizeof(Uquad_t) > strend)
4044 Copy(s, &auquad, 1, Uquad_t);
4045 s += sizeof(Uquad_t);
4048 if (auquad <= UV_MAX)
4049 sv_setuv(sv, (UV)auquad);
4051 sv_setnv(sv, (NV)auquad);
4052 PUSHs(sv_2mortal(sv));
4056 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4059 along = (strend - s) / sizeof(float);
4064 Copy(s, &afloat, 1, float);
4073 Copy(s, &afloat, 1, float);
4076 sv_setnv(sv, (NV)afloat);
4077 PUSHs(sv_2mortal(sv));
4083 along = (strend - s) / sizeof(double);
4088 Copy(s, &adouble, 1, double);
4089 s += sizeof(double);
4097 Copy(s, &adouble, 1, double);
4098 s += sizeof(double);
4100 sv_setnv(sv, (NV)adouble);
4101 PUSHs(sv_2mortal(sv));
4107 * Initialise the decode mapping. By using a table driven
4108 * algorithm, the code will be character-set independent
4109 * (and just as fast as doing character arithmetic)
4111 if (PL_uudmap['M'] == 0) {
4114 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4115 PL_uudmap[PL_uuemap[i]] = i;
4117 * Because ' ' and '`' map to the same value,
4118 * we need to decode them both the same.
4123 along = (strend - s) * 3 / 4;
4124 sv = NEWSV(42, along);
4127 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4132 len = PL_uudmap[*s++] & 077;
4134 if (s < strend && ISUUCHAR(*s))
4135 a = PL_uudmap[*s++] & 077;
4138 if (s < strend && ISUUCHAR(*s))
4139 b = PL_uudmap[*s++] & 077;
4142 if (s < strend && ISUUCHAR(*s))
4143 c = PL_uudmap[*s++] & 077;
4146 if (s < strend && ISUUCHAR(*s))
4147 d = PL_uudmap[*s++] & 077;
4150 hunk[0] = (a << 2) | (b >> 4);
4151 hunk[1] = (b << 4) | (c >> 2);
4152 hunk[2] = (c << 6) | d;
4153 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4158 else if (s[1] == '\n') /* possible checksum byte */
4161 XPUSHs(sv_2mortal(sv));
4166 if (strchr("fFdD", datumtype) ||
4167 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4171 while (checksum >= 16) {
4175 while (checksum >= 4) {
4181 along = (1 << checksum) - 1;
4182 while (cdouble < 0.0)
4184 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4185 sv_setnv(sv, cdouble);
4188 if (checksum < 32) {
4189 aulong = (1 << checksum) - 1;
4192 sv_setuv(sv, (UV)culong);
4194 XPUSHs(sv_2mortal(sv));
4198 if (SP == oldsp && gimme == G_SCALAR)
4199 PUSHs(&PL_sv_undef);
4204 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4208 *hunk = PL_uuemap[len];
4209 sv_catpvn(sv, hunk, 1);
4212 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4213 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4214 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4215 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4216 sv_catpvn(sv, hunk, 4);
4221 char r = (len > 1 ? s[1] : '\0');
4222 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4223 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4224 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4225 hunk[3] = PL_uuemap[0];
4226 sv_catpvn(sv, hunk, 4);
4228 sv_catpvn(sv, "\n", 1);
4232 S_is_an_int(pTHX_ char *s, STRLEN l)
4235 SV *result = newSVpvn(s, l);
4236 char *result_c = SvPV(result, n_a); /* convenience */
4237 char *out = result_c;
4247 SvREFCNT_dec(result);
4270 SvREFCNT_dec(result);
4276 SvCUR_set(result, out - result_c);
4280 /* pnum must be '\0' terminated */
4282 S_div128(pTHX_ SV *pnum, bool *done)
4285 char *s = SvPV(pnum, len);
4294 i = m * 10 + (*t - '0');
4296 r = (i >> 7); /* r < 10 */
4303 SvCUR_set(pnum, (STRLEN) (t - s));
4310 djSP; dMARK; dORIGMARK; dTARGET;
4311 register SV *cat = TARG;
4314 register char *pat = SvPVx(*++MARK, fromlen);
4315 register char *patend = pat + fromlen;
4320 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4321 static char *space10 = " ";
4323 /* These must not be in registers: */
4338 #ifdef PERL_NATINT_PACK
4339 int natint; /* native integer */
4344 sv_setpvn(cat, "", 0);
4345 while (pat < patend) {
4346 SV *lengthcode = Nullsv;
4347 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4348 datumtype = *pat++ & 0xFF;
4349 #ifdef PERL_NATINT_PACK
4352 if (isSPACE(datumtype))
4354 if (datumtype == '#') {
4355 while (pat < patend && *pat != '\n')
4360 char *natstr = "sSiIlL";
4362 if (strchr(natstr, datumtype)) {
4363 #ifdef PERL_NATINT_PACK
4369 DIE(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');
4380 DIE(aTHX_ "Repeat count in pack overflows");
4387 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4388 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4389 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4390 ? *MARK : &PL_sv_no)));
4394 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4395 case ',': /* grandfather in commas but with a warning */
4396 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4397 Perl_warner(aTHX_ WARN_UNSAFE,
4398 "Invalid type in pack: '%c'", (int)datumtype);
4401 DIE(aTHX_ "%% may only be used in unpack");
4412 if (SvCUR(cat) < len)
4413 DIE(aTHX_ "X outside of string");
4420 sv_catpvn(cat, null10, 10);
4423 sv_catpvn(cat, null10, len);
4429 aptr = SvPV(fromstr, fromlen);
4433 sv_catpvn(cat, aptr, len);
4435 sv_catpvn(cat, aptr, fromlen);
4437 if (datumtype == 'A') {
4439 sv_catpvn(cat, space10, 10);
4442 sv_catpvn(cat, space10, len);
4446 sv_catpvn(cat, null10, 10);
4449 sv_catpvn(cat, null10, len);
4456 char *savepat = pat;
4461 aptr = SvPV(fromstr, fromlen);
4466 SvCUR(cat) += (len+7)/8;
4467 SvGROW(cat, SvCUR(cat) + 1);
4468 aptr = SvPVX(cat) + aint;
4473 if (datumtype == 'B') {
4474 for (len = 0; len++ < aint;) {
4475 items |= *pat++ & 1;
4479 *aptr++ = items & 0xff;
4485 for (len = 0; len++ < aint;) {
4491 *aptr++ = items & 0xff;
4497 if (datumtype == 'B')
4498 items <<= 7 - (aint & 7);
4500 items >>= 7 - (aint & 7);
4501 *aptr++ = items & 0xff;
4503 pat = SvPVX(cat) + SvCUR(cat);
4514 char *savepat = pat;
4519 aptr = SvPV(fromstr, fromlen);
4524 SvCUR(cat) += (len+1)/2;
4525 SvGROW(cat, SvCUR(cat) + 1);
4526 aptr = SvPVX(cat) + aint;
4531 if (datumtype == 'H') {
4532 for (len = 0; len++ < aint;) {
4534 items |= ((*pat++ & 15) + 9) & 15;
4536 items |= *pat++ & 15;
4540 *aptr++ = items & 0xff;
4546 for (len = 0; len++ < aint;) {
4548 items |= (((*pat++ & 15) + 9) & 15) << 4;
4550 items |= (*pat++ & 15) << 4;
4554 *aptr++ = items & 0xff;
4560 *aptr++ = items & 0xff;
4561 pat = SvPVX(cat) + SvCUR(cat);
4573 aint = SvIV(fromstr);
4575 sv_catpvn(cat, &achar, sizeof(char));
4581 auint = SvUV(fromstr);
4582 SvGROW(cat, SvCUR(cat) + 10);
4583 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4588 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4593 afloat = (float)SvNV(fromstr);
4594 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4601 adouble = (double)SvNV(fromstr);
4602 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4608 ashort = (I16)SvIV(fromstr);
4610 ashort = PerlSock_htons(ashort);
4612 CAT16(cat, &ashort);
4618 ashort = (I16)SvIV(fromstr);
4620 ashort = htovs(ashort);
4622 CAT16(cat, &ashort);
4626 #if SHORTSIZE != SIZE16
4628 unsigned short aushort;
4632 aushort = SvUV(fromstr);
4633 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4643 aushort = (U16)SvUV(fromstr);
4644 CAT16(cat, &aushort);
4650 #if SHORTSIZE != SIZE16
4656 ashort = SvIV(fromstr);
4657 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4665 ashort = (I16)SvIV(fromstr);
4666 CAT16(cat, &ashort);
4673 auint = SvUV(fromstr);
4674 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4680 adouble = Perl_floor(SvNV(fromstr));
4683 DIE(aTHX_ "Cannot compress negative numbers");
4689 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4690 adouble <= UV_MAX_cxux
4697 char buf[1 + sizeof(UV)];
4698 char *in = buf + sizeof(buf);
4699 UV auv = U_V(adouble);
4702 *--in = (auv & 0x7f) | 0x80;
4705 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4706 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4708 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4709 char *from, *result, *in;
4714 /* Copy string and check for compliance */
4715 from = SvPV(fromstr, len);
4716 if ((norm = is_an_int(from, len)) == NULL)
4717 DIE(aTHX_ "can compress only unsigned integer");
4719 New('w', result, len, char);
4723 *--in = div128(norm, &done) | 0x80;
4724 result[len - 1] &= 0x7F; /* clear continue bit */
4725 sv_catpvn(cat, in, (result + len) - in);
4727 SvREFCNT_dec(norm); /* free norm */
4729 else if (SvNOKp(fromstr)) {
4730 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4731 char *in = buf + sizeof(buf);
4734 double next = floor(adouble / 128);
4735 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4736 if (--in < buf) /* this cannot happen ;-) */
4737 DIE(aTHX_ "Cannot compress integer");
4739 } while (adouble > 0);
4740 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4741 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4744 DIE(aTHX_ "Cannot compress non integer");
4750 aint = SvIV(fromstr);
4751 sv_catpvn(cat, (char*)&aint, sizeof(int));
4757 aulong = SvUV(fromstr);
4759 aulong = PerlSock_htonl(aulong);
4761 CAT32(cat, &aulong);
4767 aulong = SvUV(fromstr);
4769 aulong = htovl(aulong);
4771 CAT32(cat, &aulong);
4775 #if LONGSIZE != SIZE32
4777 unsigned long aulong;
4781 aulong = SvUV(fromstr);
4782 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4790 aulong = SvUV(fromstr);
4791 CAT32(cat, &aulong);
4796 #if LONGSIZE != SIZE32
4802 along = SvIV(fromstr);
4803 sv_catpvn(cat, (char *)&along, sizeof(long));
4811 along = SvIV(fromstr);
4820 auquad = (Uquad_t)SvUV(fromstr);
4821 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4827 aquad = (Quad_t)SvIV(fromstr);
4828 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4831 #endif /* HAS_QUAD */
4833 len = 1; /* assume SV is correct length */
4838 if (fromstr == &PL_sv_undef)
4842 /* XXX better yet, could spirit away the string to
4843 * a safe spot and hang on to it until the result
4844 * of pack() (and all copies of the result) are
4847 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4848 Perl_warner(aTHX_ WARN_UNSAFE,
4849 "Attempt to pack pointer to temporary value");
4850 if (SvPOK(fromstr) || SvNIOK(fromstr))
4851 aptr = SvPV(fromstr,n_a);
4853 aptr = SvPV_force(fromstr,n_a);
4855 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4860 aptr = SvPV(fromstr, fromlen);
4861 SvGROW(cat, fromlen * 4 / 3);
4866 while (fromlen > 0) {
4873 doencodes(cat, aptr, todo);
4892 register I32 limit = POPi; /* note, negative is forever */
4895 register char *s = SvPV(sv, len);
4896 char *strend = s + len;
4898 register REGEXP *rx;
4902 I32 maxiters = (strend - s) + 10;
4905 I32 origlimit = limit;
4908 AV *oldstack = PL_curstack;
4909 I32 gimme = GIMME_V;
4910 I32 oldsave = PL_savestack_ix;
4911 I32 make_mortal = 1;
4912 MAGIC *mg = (MAGIC *) NULL;
4915 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4920 DIE(aTHX_ "panic: do_split");
4921 rx = pm->op_pmregexp;
4923 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4924 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4926 if (pm->op_pmreplroot)
4927 ary = GvAVn((GV*)pm->op_pmreplroot);
4928 else if (gimme != G_ARRAY)
4930 ary = (AV*)PL_curpad[0];
4932 ary = GvAVn(PL_defgv);
4933 #endif /* USE_THREADS */
4936 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4942 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4944 XPUSHs(SvTIED_obj((SV*)ary, mg));
4950 for (i = AvFILLp(ary); i >= 0; i--)
4951 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4953 /* temporarily switch stacks */
4954 SWITCHSTACK(PL_curstack, ary);
4958 base = SP - PL_stack_base;
4960 if (pm->op_pmflags & PMf_SKIPWHITE) {
4961 if (pm->op_pmflags & PMf_LOCALE) {
4962 while (isSPACE_LC(*s))
4970 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4971 SAVEINT(PL_multiline);
4972 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4976 limit = maxiters + 2;
4977 if (pm->op_pmflags & PMf_WHITE) {
4980 while (m < strend &&
4981 !((pm->op_pmflags & PMf_LOCALE)
4982 ? isSPACE_LC(*m) : isSPACE(*m)))
4987 dstr = NEWSV(30, m-s);
4988 sv_setpvn(dstr, s, m-s);
4994 while (s < strend &&
4995 ((pm->op_pmflags & PMf_LOCALE)
4996 ? isSPACE_LC(*s) : isSPACE(*s)))
5000 else if (strEQ("^", rx->precomp)) {
5003 for (m = s; m < strend && *m != '\n'; m++) ;
5007 dstr = NEWSV(30, m-s);
5008 sv_setpvn(dstr, s, m-s);
5015 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5016 && (rx->reganch & ROPT_CHECK_ALL)
5017 && !(rx->reganch & ROPT_ANCH)) {
5018 int tail = (rx->reganch & RE_INTUIT_TAIL);
5019 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5023 if (len == 1 && !tail) {
5027 for (m = s; m < strend && *m != c; m++) ;
5030 dstr = NEWSV(30, m-s);
5031 sv_setpvn(dstr, s, m-s);
5040 while (s < strend && --limit &&
5041 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5042 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5045 dstr = NEWSV(31, m-s);
5046 sv_setpvn(dstr, s, m-s);
5050 s = m + len; /* Fake \n at the end */
5055 maxiters += (strend - s) * rx->nparens;
5056 while (s < strend && --limit
5057 /* && (!rx->check_substr
5058 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5060 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5061 1 /* minend */, sv, NULL, 0))
5063 TAINT_IF(RX_MATCH_TAINTED(rx));
5064 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5069 strend = s + (strend - m);
5071 m = rx->startp[0] + orig;
5072 dstr = NEWSV(32, m-s);
5073 sv_setpvn(dstr, s, m-s);
5078 for (i = 1; i <= rx->nparens; i++) {
5079 s = rx->startp[i] + orig;
5080 m = rx->endp[i] + orig;
5082 dstr = NEWSV(33, m-s);
5083 sv_setpvn(dstr, s, m-s);
5086 dstr = NEWSV(33, 0);
5092 s = rx->endp[0] + orig;
5096 LEAVE_SCOPE(oldsave);
5097 iters = (SP - PL_stack_base) - base;
5098 if (iters > maxiters)
5099 DIE(aTHX_ "Split loop");
5101 /* keep field after final delim? */
5102 if (s < strend || (iters && origlimit)) {
5103 dstr = NEWSV(34, strend-s);
5104 sv_setpvn(dstr, s, strend-s);
5110 else if (!origlimit) {
5111 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5117 SWITCHSTACK(ary, oldstack);
5118 if (SvSMAGICAL(ary)) {
5123 if (gimme == G_ARRAY) {
5125 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5133 call_method("PUSH",G_SCALAR|G_DISCARD);
5136 if (gimme == G_ARRAY) {
5137 /* EXTEND should not be needed - we just popped them */
5139 for (i=0; i < iters; i++) {
5140 SV **svp = av_fetch(ary, i, FALSE);
5141 PUSHs((svp) ? *svp : &PL_sv_undef);
5148 if (gimme == G_ARRAY)
5151 if (iters || !pm->op_pmreplroot) {
5161 Perl_unlock_condpair(pTHX_ void *svv)
5164 MAGIC *mg = mg_find((SV*)svv, 'm');
5167 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5168 MUTEX_LOCK(MgMUTEXP(mg));
5169 if (MgOWNER(mg) != thr)
5170 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5172 COND_SIGNAL(MgOWNERCONDP(mg));
5173 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: unlock 0x%lx\n",
5174 (unsigned long)thr, (unsigned long)svv);)
5175 MUTEX_UNLOCK(MgMUTEXP(mg));
5177 #endif /* USE_THREADS */
5190 mg = condpair_magic(sv);
5191 MUTEX_LOCK(MgMUTEXP(mg));
5192 if (MgOWNER(mg) == thr)
5193 MUTEX_UNLOCK(MgMUTEXP(mg));
5196 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5198 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: pp_lock lock 0x%lx\n",
5199 (unsigned long)thr, (unsigned long)sv);)
5200 MUTEX_UNLOCK(MgMUTEXP(mg));
5201 SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
5203 #endif /* USE_THREADS */
5204 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5205 || SvTYPE(retsv) == SVt_PVCV) {
5206 retsv = refto(retsv);
5217 if (PL_op->op_private & OPpLVAL_INTRO)
5218 PUSHs(*save_threadsv(PL_op->op_targ));
5220 PUSHs(THREADSV(PL_op->op_targ));
5223 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5224 #endif /* USE_THREADS */