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;
3268 #ifdef PERL_NATINT_PACK
3269 int natint; /* native integer */
3270 int unatint; /* unsigned native integer */
3273 if (gimme != G_ARRAY) { /* arrange to do first one only */
3275 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3276 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3278 while (isDIGIT(*patend) || *patend == '*')
3284 while (pat < patend) {
3286 datumtype = *pat++ & 0xFF;
3287 #ifdef PERL_NATINT_PACK
3290 if (isSPACE(datumtype))
3292 if (datumtype == '#') {
3293 while (pat < patend && *pat != '\n')
3298 char *natstr = "sSiIlL";
3300 if (strchr(natstr, datumtype)) {
3301 #ifdef PERL_NATINT_PACK
3307 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3312 else if (*pat == '*') {
3313 len = strend - strbeg; /* long enough */
3317 else if (isDIGIT(*pat)) {
3319 while (isDIGIT(*pat)) {
3320 len = (len * 10) + (*pat++ - '0');
3322 DIE(aTHX_ "Repeat count in unpack overflows");
3326 len = (datumtype != '@');
3330 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3331 case ',': /* grandfather in commas but with a warning */
3332 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3333 Perl_warner(aTHX_ WARN_UNSAFE,
3334 "Invalid type in unpack: '%c'", (int)datumtype);
3337 if (len == 1 && pat[-1] != '1')
3346 if (len > strend - strbeg)
3347 DIE(aTHX_ "@ outside of string");
3351 if (len > s - strbeg)
3352 DIE(aTHX_ "X outside of string");
3356 if (len > strend - s)
3357 DIE(aTHX_ "x outside of string");
3362 DIE(aTHX_ "/ must follow a numeric type");
3365 pat++; /* ignore '*' for compatibility with pack */
3367 DIE(aTHX_ "/ cannot take a count" );
3374 if (len > strend - s)
3377 goto uchar_checksum;
3378 sv = NEWSV(35, len);
3379 sv_setpvn(sv, s, len);
3381 if (datumtype == 'A' || datumtype == 'Z') {
3382 aptr = s; /* borrow register */
3383 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3388 else { /* 'A' strips both nulls and spaces */
3389 s = SvPVX(sv) + len - 1;
3390 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3394 SvCUR_set(sv, s - SvPVX(sv));
3395 s = aptr; /* unborrow register */
3397 XPUSHs(sv_2mortal(sv));
3401 if (star || len > (strend - s) * 8)
3402 len = (strend - s) * 8;
3405 Newz(601, PL_bitcount, 256, char);
3406 for (bits = 1; bits < 256; bits++) {
3407 if (bits & 1) PL_bitcount[bits]++;
3408 if (bits & 2) PL_bitcount[bits]++;
3409 if (bits & 4) PL_bitcount[bits]++;
3410 if (bits & 8) PL_bitcount[bits]++;
3411 if (bits & 16) PL_bitcount[bits]++;
3412 if (bits & 32) PL_bitcount[bits]++;
3413 if (bits & 64) PL_bitcount[bits]++;
3414 if (bits & 128) PL_bitcount[bits]++;
3418 culong += PL_bitcount[*(unsigned char*)s++];
3423 if (datumtype == 'b') {
3425 if (bits & 1) culong++;
3431 if (bits & 128) culong++;
3438 sv = NEWSV(35, len + 1);
3441 aptr = pat; /* borrow register */
3443 if (datumtype == 'b') {
3445 for (len = 0; len < aint; len++) {
3446 if (len & 7) /*SUPPRESS 595*/
3450 *pat++ = '0' + (bits & 1);
3455 for (len = 0; len < aint; len++) {
3460 *pat++ = '0' + ((bits & 128) != 0);
3464 pat = aptr; /* unborrow register */
3465 XPUSHs(sv_2mortal(sv));
3469 if (star || len > (strend - s) * 2)
3470 len = (strend - s) * 2;
3471 sv = NEWSV(35, len + 1);
3474 aptr = pat; /* borrow register */
3476 if (datumtype == 'h') {
3478 for (len = 0; len < aint; len++) {
3483 *pat++ = PL_hexdigit[bits & 15];
3488 for (len = 0; len < aint; len++) {
3493 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3497 pat = aptr; /* unborrow register */
3498 XPUSHs(sv_2mortal(sv));
3501 if (len > strend - s)
3506 if (aint >= 128) /* fake up signed chars */
3516 if (aint >= 128) /* fake up signed chars */
3519 sv_setiv(sv, (IV)aint);
3520 PUSHs(sv_2mortal(sv));
3525 if (len > strend - s)
3540 sv_setiv(sv, (IV)auint);
3541 PUSHs(sv_2mortal(sv));
3546 if (len > strend - s)
3549 while (len-- > 0 && s < strend) {
3550 auint = utf8_to_uv((U8*)s, &along);
3553 cdouble += (NV)auint;
3561 while (len-- > 0 && s < strend) {
3562 auint = utf8_to_uv((U8*)s, &along);
3565 sv_setuv(sv, (UV)auint);
3566 PUSHs(sv_2mortal(sv));
3571 #if SHORTSIZE == SIZE16
3572 along = (strend - s) / SIZE16;
3574 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3579 #if SHORTSIZE != SIZE16
3583 COPYNN(s, &ashort, sizeof(short));
3594 #if SHORTSIZE > SIZE16
3606 #if SHORTSIZE != SIZE16
3610 COPYNN(s, &ashort, sizeof(short));
3613 sv_setiv(sv, (IV)ashort);
3614 PUSHs(sv_2mortal(sv));
3622 #if SHORTSIZE > SIZE16
3628 sv_setiv(sv, (IV)ashort);
3629 PUSHs(sv_2mortal(sv));
3637 #if SHORTSIZE == SIZE16
3638 along = (strend - s) / SIZE16;
3640 unatint = natint && datumtype == 'S';
3641 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3646 #if SHORTSIZE != SIZE16
3648 unsigned short aushort;
3650 COPYNN(s, &aushort, sizeof(unsigned short));
3651 s += sizeof(unsigned short);
3659 COPY16(s, &aushort);
3662 if (datumtype == 'n')
3663 aushort = PerlSock_ntohs(aushort);
3666 if (datumtype == 'v')
3667 aushort = vtohs(aushort);
3676 #if SHORTSIZE != SIZE16
3678 unsigned short aushort;
3680 COPYNN(s, &aushort, sizeof(unsigned short));
3681 s += sizeof(unsigned short);
3683 sv_setiv(sv, (UV)aushort);
3684 PUSHs(sv_2mortal(sv));
3691 COPY16(s, &aushort);
3695 if (datumtype == 'n')
3696 aushort = PerlSock_ntohs(aushort);
3699 if (datumtype == 'v')
3700 aushort = vtohs(aushort);
3702 sv_setiv(sv, (UV)aushort);
3703 PUSHs(sv_2mortal(sv));
3709 along = (strend - s) / sizeof(int);
3714 Copy(s, &aint, 1, int);
3717 cdouble += (NV)aint;
3726 Copy(s, &aint, 1, int);
3730 /* Without the dummy below unpack("i", pack("i",-1))
3731 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3732 * cc with optimization turned on.
3734 * The bug was detected in
3735 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3736 * with optimization (-O4) turned on.
3737 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3738 * does not have this problem even with -O4.
3740 * This bug was reported as DECC_BUGS 1431
3741 * and tracked internally as GEM_BUGS 7775.
3743 * The bug is fixed in
3744 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3745 * UNIX V4.0F support: DEC C V5.9-006 or later
3746 * UNIX V4.0E support: DEC C V5.8-011 or later
3749 * See also few lines later for the same bug.
3752 sv_setiv(sv, (IV)aint) :
3754 sv_setiv(sv, (IV)aint);
3755 PUSHs(sv_2mortal(sv));
3760 along = (strend - s) / sizeof(unsigned int);
3765 Copy(s, &auint, 1, unsigned int);
3766 s += sizeof(unsigned int);
3768 cdouble += (NV)auint;
3777 Copy(s, &auint, 1, unsigned int);
3778 s += sizeof(unsigned int);
3781 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3782 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3783 * See details few lines earlier. */
3785 sv_setuv(sv, (UV)auint) :
3787 sv_setuv(sv, (UV)auint);
3788 PUSHs(sv_2mortal(sv));
3793 #if LONGSIZE == SIZE32
3794 along = (strend - s) / SIZE32;
3796 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3801 #if LONGSIZE != SIZE32
3805 COPYNN(s, &along, sizeof(long));
3808 cdouble += (NV)along;
3818 #if LONGSIZE > SIZE32
3819 if (along > 2147483647)
3820 along -= 4294967296;
3824 cdouble += (NV)along;
3833 #if LONGSIZE != SIZE32
3837 COPYNN(s, &along, sizeof(long));
3840 sv_setiv(sv, (IV)along);
3841 PUSHs(sv_2mortal(sv));
3849 #if LONGSIZE > SIZE32
3850 if (along > 2147483647)
3851 along -= 4294967296;
3855 sv_setiv(sv, (IV)along);
3856 PUSHs(sv_2mortal(sv));
3864 #if LONGSIZE == SIZE32
3865 along = (strend - s) / SIZE32;
3867 unatint = natint && datumtype == 'L';
3868 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3873 #if LONGSIZE != SIZE32
3875 unsigned long aulong;
3877 COPYNN(s, &aulong, sizeof(unsigned long));
3878 s += sizeof(unsigned long);
3880 cdouble += (NV)aulong;
3892 if (datumtype == 'N')
3893 aulong = PerlSock_ntohl(aulong);
3896 if (datumtype == 'V')
3897 aulong = vtohl(aulong);
3900 cdouble += (NV)aulong;
3909 #if LONGSIZE != SIZE32
3911 unsigned long aulong;
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 DIE(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, (NV)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, (NV)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, (NV)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, (NV)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 = Perl_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 SV *lengthcode = Nullsv;
4350 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4351 datumtype = *pat++ & 0xFF;
4352 #ifdef PERL_NATINT_PACK
4355 if (isSPACE(datumtype))
4357 if (datumtype == '#') {
4358 while (pat < patend && *pat != '\n')
4363 char *natstr = "sSiIlL";
4365 if (strchr(natstr, datumtype)) {
4366 #ifdef PERL_NATINT_PACK
4372 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4375 len = strchr("@Xxu", datumtype) ? 0 : items;
4378 else if (isDIGIT(*pat)) {
4380 while (isDIGIT(*pat)) {
4381 len = (len * 10) + (*pat++ - '0');
4383 DIE(aTHX_ "Repeat count in pack overflows");
4390 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4391 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4392 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4393 ? *MARK : &PL_sv_no)));
4397 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4398 case ',': /* grandfather in commas but with a warning */
4399 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4400 Perl_warner(aTHX_ WARN_UNSAFE,
4401 "Invalid type in pack: '%c'", (int)datumtype);
4404 DIE(aTHX_ "%% may only be used in unpack");
4415 if (SvCUR(cat) < len)
4416 DIE(aTHX_ "X outside of string");
4423 sv_catpvn(cat, null10, 10);
4426 sv_catpvn(cat, null10, len);
4432 aptr = SvPV(fromstr, fromlen);
4433 if (pat[-1] == '*') {
4435 if (datumtype == 'Z')
4438 if (fromlen >= len) {
4439 sv_catpvn(cat, aptr, len);
4440 if (datumtype == 'Z')
4441 *(SvEND(cat)-1) = '\0';
4444 sv_catpvn(cat, aptr, fromlen);
4446 if (datumtype == 'A') {
4448 sv_catpvn(cat, space10, 10);
4451 sv_catpvn(cat, space10, len);
4455 sv_catpvn(cat, null10, 10);
4458 sv_catpvn(cat, null10, len);
4465 char *savepat = pat;
4470 aptr = SvPV(fromstr, fromlen);
4475 SvCUR(cat) += (len+7)/8;
4476 SvGROW(cat, SvCUR(cat) + 1);
4477 aptr = SvPVX(cat) + aint;
4482 if (datumtype == 'B') {
4483 for (len = 0; len++ < aint;) {
4484 items |= *pat++ & 1;
4488 *aptr++ = items & 0xff;
4494 for (len = 0; len++ < aint;) {
4500 *aptr++ = items & 0xff;
4506 if (datumtype == 'B')
4507 items <<= 7 - (aint & 7);
4509 items >>= 7 - (aint & 7);
4510 *aptr++ = items & 0xff;
4512 pat = SvPVX(cat) + SvCUR(cat);
4523 char *savepat = pat;
4528 aptr = SvPV(fromstr, fromlen);
4533 SvCUR(cat) += (len+1)/2;
4534 SvGROW(cat, SvCUR(cat) + 1);
4535 aptr = SvPVX(cat) + aint;
4540 if (datumtype == 'H') {
4541 for (len = 0; len++ < aint;) {
4543 items |= ((*pat++ & 15) + 9) & 15;
4545 items |= *pat++ & 15;
4549 *aptr++ = items & 0xff;
4555 for (len = 0; len++ < aint;) {
4557 items |= (((*pat++ & 15) + 9) & 15) << 4;
4559 items |= (*pat++ & 15) << 4;
4563 *aptr++ = items & 0xff;
4569 *aptr++ = items & 0xff;
4570 pat = SvPVX(cat) + SvCUR(cat);
4582 aint = SvIV(fromstr);
4584 sv_catpvn(cat, &achar, sizeof(char));
4590 auint = SvUV(fromstr);
4591 SvGROW(cat, SvCUR(cat) + 10);
4592 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4597 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4602 afloat = (float)SvNV(fromstr);
4603 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4610 adouble = (double)SvNV(fromstr);
4611 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4617 ashort = (I16)SvIV(fromstr);
4619 ashort = PerlSock_htons(ashort);
4621 CAT16(cat, &ashort);
4627 ashort = (I16)SvIV(fromstr);
4629 ashort = htovs(ashort);
4631 CAT16(cat, &ashort);
4635 #if SHORTSIZE != SIZE16
4637 unsigned short aushort;
4641 aushort = SvUV(fromstr);
4642 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4652 aushort = (U16)SvUV(fromstr);
4653 CAT16(cat, &aushort);
4659 #if SHORTSIZE != SIZE16
4665 ashort = SvIV(fromstr);
4666 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4674 ashort = (I16)SvIV(fromstr);
4675 CAT16(cat, &ashort);
4682 auint = SvUV(fromstr);
4683 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4689 adouble = Perl_floor(SvNV(fromstr));
4692 DIE(aTHX_ "Cannot compress negative numbers");
4698 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4699 adouble <= UV_MAX_cxux
4706 char buf[1 + sizeof(UV)];
4707 char *in = buf + sizeof(buf);
4708 UV auv = U_V(adouble);
4711 *--in = (auv & 0x7f) | 0x80;
4714 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4715 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4717 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4718 char *from, *result, *in;
4723 /* Copy string and check for compliance */
4724 from = SvPV(fromstr, len);
4725 if ((norm = is_an_int(from, len)) == NULL)
4726 DIE(aTHX_ "can compress only unsigned integer");
4728 New('w', result, len, char);
4732 *--in = div128(norm, &done) | 0x80;
4733 result[len - 1] &= 0x7F; /* clear continue bit */
4734 sv_catpvn(cat, in, (result + len) - in);
4736 SvREFCNT_dec(norm); /* free norm */
4738 else if (SvNOKp(fromstr)) {
4739 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4740 char *in = buf + sizeof(buf);
4743 double next = floor(adouble / 128);
4744 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4745 if (--in < buf) /* this cannot happen ;-) */
4746 DIE(aTHX_ "Cannot compress integer");
4748 } while (adouble > 0);
4749 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4750 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4753 DIE(aTHX_ "Cannot compress non integer");
4759 aint = SvIV(fromstr);
4760 sv_catpvn(cat, (char*)&aint, sizeof(int));
4766 aulong = SvUV(fromstr);
4768 aulong = PerlSock_htonl(aulong);
4770 CAT32(cat, &aulong);
4776 aulong = SvUV(fromstr);
4778 aulong = htovl(aulong);
4780 CAT32(cat, &aulong);
4784 #if LONGSIZE != SIZE32
4786 unsigned long aulong;
4790 aulong = SvUV(fromstr);
4791 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4799 aulong = SvUV(fromstr);
4800 CAT32(cat, &aulong);
4805 #if LONGSIZE != SIZE32
4811 along = SvIV(fromstr);
4812 sv_catpvn(cat, (char *)&along, sizeof(long));
4820 along = SvIV(fromstr);
4829 auquad = (Uquad_t)SvUV(fromstr);
4830 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4836 aquad = (Quad_t)SvIV(fromstr);
4837 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4840 #endif /* HAS_QUAD */
4842 len = 1; /* assume SV is correct length */
4847 if (fromstr == &PL_sv_undef)
4851 /* XXX better yet, could spirit away the string to
4852 * a safe spot and hang on to it until the result
4853 * of pack() (and all copies of the result) are
4856 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4857 Perl_warner(aTHX_ WARN_UNSAFE,
4858 "Attempt to pack pointer to temporary value");
4859 if (SvPOK(fromstr) || SvNIOK(fromstr))
4860 aptr = SvPV(fromstr,n_a);
4862 aptr = SvPV_force(fromstr,n_a);
4864 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4869 aptr = SvPV(fromstr, fromlen);
4870 SvGROW(cat, fromlen * 4 / 3);
4875 while (fromlen > 0) {
4882 doencodes(cat, aptr, todo);
4901 register I32 limit = POPi; /* note, negative is forever */
4904 register char *s = SvPV(sv, len);
4905 char *strend = s + len;
4907 register REGEXP *rx;
4911 I32 maxiters = (strend - s) + 10;
4914 I32 origlimit = limit;
4917 AV *oldstack = PL_curstack;
4918 I32 gimme = GIMME_V;
4919 I32 oldsave = PL_savestack_ix;
4920 I32 make_mortal = 1;
4921 MAGIC *mg = (MAGIC *) NULL;
4924 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4929 DIE(aTHX_ "panic: do_split");
4930 rx = pm->op_pmregexp;
4932 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4933 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4935 if (pm->op_pmreplroot)
4936 ary = GvAVn((GV*)pm->op_pmreplroot);
4937 else if (gimme != G_ARRAY)
4939 ary = (AV*)PL_curpad[0];
4941 ary = GvAVn(PL_defgv);
4942 #endif /* USE_THREADS */
4945 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4951 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4953 XPUSHs(SvTIED_obj((SV*)ary, mg));
4959 for (i = AvFILLp(ary); i >= 0; i--)
4960 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4962 /* temporarily switch stacks */
4963 SWITCHSTACK(PL_curstack, ary);
4967 base = SP - PL_stack_base;
4969 if (pm->op_pmflags & PMf_SKIPWHITE) {
4970 if (pm->op_pmflags & PMf_LOCALE) {
4971 while (isSPACE_LC(*s))
4979 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4980 SAVEINT(PL_multiline);
4981 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4985 limit = maxiters + 2;
4986 if (pm->op_pmflags & PMf_WHITE) {
4989 while (m < strend &&
4990 !((pm->op_pmflags & PMf_LOCALE)
4991 ? isSPACE_LC(*m) : isSPACE(*m)))
4996 dstr = NEWSV(30, m-s);
4997 sv_setpvn(dstr, s, m-s);
5003 while (s < strend &&
5004 ((pm->op_pmflags & PMf_LOCALE)
5005 ? isSPACE_LC(*s) : isSPACE(*s)))
5009 else if (strEQ("^", rx->precomp)) {
5012 for (m = s; m < strend && *m != '\n'; m++) ;
5016 dstr = NEWSV(30, m-s);
5017 sv_setpvn(dstr, s, m-s);
5024 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5025 && (rx->reganch & ROPT_CHECK_ALL)
5026 && !(rx->reganch & ROPT_ANCH)) {
5027 int tail = (rx->reganch & RE_INTUIT_TAIL);
5028 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5032 if (len == 1 && !tail) {
5036 for (m = s; m < strend && *m != c; m++) ;
5039 dstr = NEWSV(30, m-s);
5040 sv_setpvn(dstr, s, m-s);
5049 while (s < strend && --limit &&
5050 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5051 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5054 dstr = NEWSV(31, m-s);
5055 sv_setpvn(dstr, s, m-s);
5059 s = m + len; /* Fake \n at the end */
5064 maxiters += (strend - s) * rx->nparens;
5065 while (s < strend && --limit
5066 /* && (!rx->check_substr
5067 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5069 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5070 1 /* minend */, sv, NULL, 0))
5072 TAINT_IF(RX_MATCH_TAINTED(rx));
5073 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5078 strend = s + (strend - m);
5080 m = rx->startp[0] + orig;
5081 dstr = NEWSV(32, m-s);
5082 sv_setpvn(dstr, s, m-s);
5087 for (i = 1; i <= rx->nparens; i++) {
5088 s = rx->startp[i] + orig;
5089 m = rx->endp[i] + orig;
5091 dstr = NEWSV(33, m-s);
5092 sv_setpvn(dstr, s, m-s);
5095 dstr = NEWSV(33, 0);
5101 s = rx->endp[0] + orig;
5105 LEAVE_SCOPE(oldsave);
5106 iters = (SP - PL_stack_base) - base;
5107 if (iters > maxiters)
5108 DIE(aTHX_ "Split loop");
5110 /* keep field after final delim? */
5111 if (s < strend || (iters && origlimit)) {
5112 dstr = NEWSV(34, strend-s);
5113 sv_setpvn(dstr, s, strend-s);
5119 else if (!origlimit) {
5120 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5126 SWITCHSTACK(ary, oldstack);
5127 if (SvSMAGICAL(ary)) {
5132 if (gimme == G_ARRAY) {
5134 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5142 call_method("PUSH",G_SCALAR|G_DISCARD);
5145 if (gimme == G_ARRAY) {
5146 /* EXTEND should not be needed - we just popped them */
5148 for (i=0; i < iters; i++) {
5149 SV **svp = av_fetch(ary, i, FALSE);
5150 PUSHs((svp) ? *svp : &PL_sv_undef);
5157 if (gimme == G_ARRAY)
5160 if (iters || !pm->op_pmreplroot) {
5170 Perl_unlock_condpair(pTHX_ void *svv)
5173 MAGIC *mg = mg_find((SV*)svv, 'm');
5176 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5177 MUTEX_LOCK(MgMUTEXP(mg));
5178 if (MgOWNER(mg) != thr)
5179 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5181 COND_SIGNAL(MgOWNERCONDP(mg));
5182 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: unlock 0x%lx\n",
5183 (unsigned long)thr, (unsigned long)svv);)
5184 MUTEX_UNLOCK(MgMUTEXP(mg));
5186 #endif /* USE_THREADS */
5199 mg = condpair_magic(sv);
5200 MUTEX_LOCK(MgMUTEXP(mg));
5201 if (MgOWNER(mg) == thr)
5202 MUTEX_UNLOCK(MgMUTEXP(mg));
5205 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5207 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: pp_lock lock 0x%lx\n",
5208 (unsigned long)thr, (unsigned long)sv);)
5209 MUTEX_UNLOCK(MgMUTEXP(mg));
5210 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5212 #endif /* USE_THREADS */
5213 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5214 || SvTYPE(retsv) == SVt_PVCV) {
5215 retsv = refto(retsv);
5226 if (PL_op->op_private & OPpLVAL_INTRO)
5227 PUSHs(*save_threadsv(PL_op->op_targ));
5229 PUSHs(THREADSV(PL_op->op_targ));
5232 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5233 #endif /* USE_THREADS */