3 * Copyright (c) 1991-2000, 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)
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 LONGSIZE > 4 && defined(_CRAY)
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) {
246 if (cUNOP->op_targ) {
248 SV *namesv = PL_curpad[cUNOP->op_targ];
249 name = SvPV(namesv, len);
250 gv = (GV*)NEWSV(0,0);
251 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
254 name = CopSTASHPV(PL_curcop);
257 sv_upgrade(sv, SVt_RV);
263 if (PL_op->op_flags & OPf_REF ||
264 PL_op->op_private & HINT_STRICT_REFS)
265 DIE(aTHX_ PL_no_usym, "a symbol");
266 if (ckWARN(WARN_UNINITIALIZED))
271 if ((PL_op->op_flags & OPf_SPECIAL) &&
272 !(PL_op->op_flags & OPf_MOD))
274 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
279 if (PL_op->op_private & HINT_STRICT_REFS)
280 DIE(aTHX_ PL_no_symref, sym, "a symbol");
281 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
285 if (PL_op->op_private & OPpLVAL_INTRO)
286 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
297 tryAMAGICunDEREF(to_sv);
300 switch (SvTYPE(sv)) {
304 DIE(aTHX_ "Not a SCALAR reference");
312 if (SvTYPE(gv) != SVt_PVGV) {
313 if (SvGMAGICAL(sv)) {
319 if (PL_op->op_flags & OPf_REF ||
320 PL_op->op_private & HINT_STRICT_REFS)
321 DIE(aTHX_ PL_no_usym, "a SCALAR");
322 if (ckWARN(WARN_UNINITIALIZED))
327 if ((PL_op->op_flags & OPf_SPECIAL) &&
328 !(PL_op->op_flags & OPf_MOD))
330 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
335 if (PL_op->op_private & HINT_STRICT_REFS)
336 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
337 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
342 if (PL_op->op_flags & OPf_MOD) {
343 if (PL_op->op_private & OPpLVAL_INTRO)
344 sv = save_scalar((GV*)TOPs);
345 else if (PL_op->op_private & OPpDEREF)
346 vivify_ref(sv, PL_op->op_private & OPpDEREF);
356 SV *sv = AvARYLEN(av);
358 AvARYLEN(av) = sv = NEWSV(0,0);
359 sv_upgrade(sv, SVt_IV);
360 sv_magic(sv, (SV*)av, '#', Nullch, 0);
368 djSP; dTARGET; dPOPss;
370 if (PL_op->op_flags & OPf_MOD) {
371 if (SvTYPE(TARG) < SVt_PVLV) {
372 sv_upgrade(TARG, SVt_PVLV);
373 sv_magic(TARG, Nullsv, '.', Nullch, 0);
377 if (LvTARG(TARG) != sv) {
379 SvREFCNT_dec(LvTARG(TARG));
380 LvTARG(TARG) = SvREFCNT_inc(sv);
382 PUSHs(TARG); /* no SvSETMAGIC */
388 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
389 mg = mg_find(sv, 'g');
390 if (mg && mg->mg_len >= 0) {
394 PUSHi(i + PL_curcop->cop_arybase);
408 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
409 /* (But not in defined().) */
410 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
413 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
414 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
415 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
418 cv = (CV*)&PL_sv_undef;
432 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
433 char *s = SvPVX(TOPs);
434 if (strnEQ(s, "CORE::", 6)) {
437 code = keyword(s + 6, SvCUR(TOPs) - 6);
438 if (code < 0) { /* Overridable. */
439 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
440 int i = 0, n = 0, seen_question = 0;
442 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
444 while (i < MAXO) { /* The slow way. */
445 if (strEQ(s + 6, PL_op_name[i])
446 || strEQ(s + 6, PL_op_desc[i]))
452 goto nonesuch; /* Should not happen... */
454 oa = PL_opargs[i] >> OASHIFT;
456 if (oa & OA_OPTIONAL) {
460 else if (seen_question)
461 goto set; /* XXXX system, exec */
462 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
463 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
466 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
467 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
471 ret = sv_2mortal(newSVpvn(str, n - 1));
473 else if (code) /* Non-Overridable */
475 else { /* None such */
477 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
481 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
483 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
492 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
494 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
510 if (GIMME != G_ARRAY) {
514 *MARK = &PL_sv_undef;
515 *MARK = refto(*MARK);
519 EXTEND_MORTAL(SP - MARK);
521 *MARK = refto(*MARK);
526 S_refto(pTHX_ SV *sv)
530 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
533 if (!(sv = LvTARG(sv)))
536 (void)SvREFCNT_inc(sv);
538 else if (SvTYPE(sv) == SVt_PVAV) {
539 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
542 (void)SvREFCNT_inc(sv);
544 else if (SvPADTMP(sv))
548 (void)SvREFCNT_inc(sv);
551 sv_upgrade(rv, SVt_RV);
565 if (sv && SvGMAGICAL(sv))
568 if (!sv || !SvROK(sv))
572 pv = sv_reftype(sv,TRUE);
573 PUSHp(pv, strlen(pv));
583 stash = CopSTASH(PL_curcop);
587 char *ptr = SvPV(ssv,len);
588 if (ckWARN(WARN_UNSAFE) && len == 0)
589 Perl_warner(aTHX_ WARN_UNSAFE,
590 "Explicit blessing to '' (assuming package main)");
591 stash = gv_stashpvn(ptr, len, TRUE);
594 (void)sv_bless(TOPs, stash);
608 elem = SvPV(sv, n_a);
612 switch (elem ? *elem : '\0')
615 if (strEQ(elem, "ARRAY"))
616 tmpRef = (SV*)GvAV(gv);
619 if (strEQ(elem, "CODE"))
620 tmpRef = (SV*)GvCVu(gv);
623 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
624 tmpRef = (SV*)GvIOp(gv);
627 if (strEQ(elem, "GLOB"))
631 if (strEQ(elem, "HASH"))
632 tmpRef = (SV*)GvHV(gv);
635 if (strEQ(elem, "IO"))
636 tmpRef = (SV*)GvIOp(gv);
639 if (strEQ(elem, "NAME"))
640 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
643 if (strEQ(elem, "PACKAGE"))
644 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
647 if (strEQ(elem, "SCALAR"))
661 /* Pattern matching */
666 register unsigned char *s;
669 register I32 *sfirst;
673 if (sv == PL_lastscream) {
679 SvSCREAM_off(PL_lastscream);
680 SvREFCNT_dec(PL_lastscream);
682 PL_lastscream = SvREFCNT_inc(sv);
685 s = (unsigned char*)(SvPV(sv, len));
689 if (pos > PL_maxscream) {
690 if (PL_maxscream < 0) {
691 PL_maxscream = pos + 80;
692 New(301, PL_screamfirst, 256, I32);
693 New(302, PL_screamnext, PL_maxscream, I32);
696 PL_maxscream = pos + pos / 4;
697 Renew(PL_screamnext, PL_maxscream, I32);
701 sfirst = PL_screamfirst;
702 snext = PL_screamnext;
704 if (!sfirst || !snext)
705 DIE(aTHX_ "do_study: out of memory");
707 for (ch = 256; ch; --ch)
714 snext[pos] = sfirst[ch] - pos;
721 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
730 if (PL_op->op_flags & OPf_STACKED)
736 TARG = sv_newmortal();
741 /* Lvalue operators. */
753 djSP; dMARK; dTARGET;
763 SETi(do_chomp(TOPs));
769 djSP; dMARK; dTARGET;
770 register I32 count = 0;
773 count += do_chomp(POPs);
784 if (!sv || !SvANY(sv))
786 switch (SvTYPE(sv)) {
788 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
792 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
796 if (CvROOT(sv) || CvXSUB(sv))
813 if (!PL_op->op_private) {
822 if (SvTHINKFIRST(sv))
825 switch (SvTYPE(sv)) {
835 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
836 Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
837 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
841 /* let user-undef'd sub keep its identity */
842 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
849 SvSetMagicSV(sv, &PL_sv_undef);
853 Newz(602, gp, 1, GP);
854 GvGP(sv) = gp_ref(gp);
855 GvSV(sv) = NEWSV(72,0);
856 GvLINE(sv) = CopLINE(PL_curcop);
862 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
865 SvPV_set(sv, Nullch);
878 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
879 DIE(aTHX_ PL_no_modify);
880 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
881 SvIVX(TOPs) != IV_MIN)
884 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
895 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
896 DIE(aTHX_ PL_no_modify);
897 sv_setsv(TARG, TOPs);
898 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
899 SvIVX(TOPs) != IV_MAX)
902 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
916 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
917 DIE(aTHX_ PL_no_modify);
918 sv_setsv(TARG, TOPs);
919 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
920 SvIVX(TOPs) != IV_MIN)
923 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
932 /* Ordinary operators. */
936 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
939 SETn( pow( left, right) );
946 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
949 SETn( left * right );
956 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
961 DIE(aTHX_ "Illegal division by zero");
963 /* insure that 20./5. == 4. */
966 if ((NV)I_V(left) == left &&
967 (NV)I_V(right) == right &&
968 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
972 value = left / right;
976 value = left / right;
985 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
995 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
997 right = (right_neg = (i < 0)) ? -i : i;
1002 right_neg = dright < 0;
1007 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1009 left = (left_neg = (i < 0)) ? -i : i;
1017 left_neg = dleft < 0;
1026 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1028 # define CAST_D2UV(d) U_V(d)
1030 # define CAST_D2UV(d) ((UV)(d))
1032 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1033 * or, in other words, precision of UV more than of NV.
1034 * But in fact the approach below turned out to be an
1035 * optimization - floor() may be slow */
1036 if (dright <= UV_MAX && dleft <= UV_MAX) {
1037 right = CAST_D2UV(dright);
1038 left = CAST_D2UV(dleft);
1043 /* Backward-compatibility clause: */
1044 dright = floor(dright + 0.5);
1045 dleft = floor(dleft + 0.5);
1048 DIE(aTHX_ "Illegal modulus zero");
1050 dans = Perl_fmod(dleft, dright);
1051 if ((left_neg != right_neg) && dans)
1052 dans = dright - dans;
1055 sv_setnv(TARG, dans);
1062 DIE(aTHX_ "Illegal modulus zero");
1065 if ((left_neg != right_neg) && ans)
1068 /* XXX may warn: unary minus operator applied to unsigned type */
1069 /* could change -foo to be (~foo)+1 instead */
1070 if (ans <= ~((UV)IV_MAX)+1)
1071 sv_setiv(TARG, ~ans+1);
1073 sv_setnv(TARG, -(NV)ans);
1076 sv_setuv(TARG, ans);
1085 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1087 register I32 count = POPi;
1088 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1090 I32 items = SP - MARK;
1093 max = items * count;
1102 repeatcpy((char*)(MARK + items), (char*)MARK,
1103 items * sizeof(SV*), count - 1);
1106 else if (count <= 0)
1109 else { /* Note: mark already snarfed by pp_list */
1114 SvSetSV(TARG, tmpstr);
1115 SvPV_force(TARG, len);
1120 SvGROW(TARG, (count * len) + 1);
1121 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1122 SvCUR(TARG) *= count;
1124 *SvEND(TARG) = '\0';
1126 (void)SvPOK_only(TARG);
1135 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1138 SETn( left - right );
1145 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1148 if (PL_op->op_private & HINT_INTEGER) {
1150 i = BWi(i) << shift;
1164 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1167 if (PL_op->op_private & HINT_INTEGER) {
1169 i = BWi(i) >> shift;
1183 djSP; tryAMAGICbinSET(lt,0);
1186 SETs(boolSV(TOPn < value));
1193 djSP; tryAMAGICbinSET(gt,0);
1196 SETs(boolSV(TOPn > value));
1203 djSP; tryAMAGICbinSET(le,0);
1206 SETs(boolSV(TOPn <= value));
1213 djSP; tryAMAGICbinSET(ge,0);
1216 SETs(boolSV(TOPn >= value));
1223 djSP; tryAMAGICbinSET(ne,0);
1226 SETs(boolSV(TOPn != value));
1233 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1240 else if (left < right)
1242 else if (left > right)
1255 djSP; tryAMAGICbinSET(slt,0);
1258 int cmp = ((PL_op->op_private & OPpLOCALE)
1259 ? sv_cmp_locale(left, right)
1260 : sv_cmp(left, right));
1261 SETs(boolSV(cmp < 0));
1268 djSP; tryAMAGICbinSET(sgt,0);
1271 int cmp = ((PL_op->op_private & OPpLOCALE)
1272 ? sv_cmp_locale(left, right)
1273 : sv_cmp(left, right));
1274 SETs(boolSV(cmp > 0));
1281 djSP; tryAMAGICbinSET(sle,0);
1284 int cmp = ((PL_op->op_private & OPpLOCALE)
1285 ? sv_cmp_locale(left, right)
1286 : sv_cmp(left, right));
1287 SETs(boolSV(cmp <= 0));
1294 djSP; tryAMAGICbinSET(sge,0);
1297 int cmp = ((PL_op->op_private & OPpLOCALE)
1298 ? sv_cmp_locale(left, right)
1299 : sv_cmp(left, right));
1300 SETs(boolSV(cmp >= 0));
1307 djSP; tryAMAGICbinSET(seq,0);
1310 SETs(boolSV(sv_eq(left, right)));
1317 djSP; tryAMAGICbinSET(sne,0);
1320 SETs(boolSV(!sv_eq(left, right)));
1327 djSP; dTARGET; tryAMAGICbin(scmp,0);
1330 int cmp = ((PL_op->op_private & OPpLOCALE)
1331 ? sv_cmp_locale(left, right)
1332 : sv_cmp(left, right));
1340 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1343 if (SvNIOKp(left) || SvNIOKp(right)) {
1344 if (PL_op->op_private & HINT_INTEGER) {
1345 IBW value = SvIV(left) & SvIV(right);
1349 UBW value = SvUV(left) & SvUV(right);
1354 do_vop(PL_op->op_type, TARG, left, right);
1363 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1366 if (SvNIOKp(left) || SvNIOKp(right)) {
1367 if (PL_op->op_private & HINT_INTEGER) {
1368 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1372 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1377 do_vop(PL_op->op_type, TARG, left, right);
1386 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1389 if (SvNIOKp(left) || SvNIOKp(right)) {
1390 if (PL_op->op_private & HINT_INTEGER) {
1391 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1395 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1400 do_vop(PL_op->op_type, TARG, left, right);
1409 djSP; dTARGET; tryAMAGICun(neg);
1414 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1416 else if (SvNIOKp(sv))
1418 else if (SvPOKp(sv)) {
1420 char *s = SvPV(sv, len);
1421 if (isIDFIRST(*s)) {
1422 sv_setpvn(TARG, "-", 1);
1425 else if (*s == '+' || *s == '-') {
1427 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1429 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1430 sv_setpvn(TARG, "-", 1);
1434 sv_setnv(TARG, -SvNV(sv));
1445 djSP; tryAMAGICunSET(not);
1446 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1452 djSP; dTARGET; tryAMAGICun(compl);
1456 if (PL_op->op_private & HINT_INTEGER) {
1457 IBW value = ~SvIV(sv);
1461 UBW value = ~SvUV(sv);
1466 register char *tmps;
1467 register long *tmpl;
1472 tmps = SvPV_force(TARG, len);
1475 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1478 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1482 for ( ; anum > 0; anum--, tmps++)
1491 /* integer versions of some of the above */
1495 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1498 SETi( left * right );
1505 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1509 DIE(aTHX_ "Illegal division by zero");
1510 value = POPi / value;
1518 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1522 DIE(aTHX_ "Illegal modulus zero");
1523 SETi( left % right );
1530 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1533 SETi( left + right );
1540 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1543 SETi( left - right );
1550 djSP; tryAMAGICbinSET(lt,0);
1553 SETs(boolSV(left < right));
1560 djSP; tryAMAGICbinSET(gt,0);
1563 SETs(boolSV(left > right));
1570 djSP; tryAMAGICbinSET(le,0);
1573 SETs(boolSV(left <= right));
1580 djSP; tryAMAGICbinSET(ge,0);
1583 SETs(boolSV(left >= right));
1590 djSP; tryAMAGICbinSET(eq,0);
1593 SETs(boolSV(left == right));
1600 djSP; tryAMAGICbinSET(ne,0);
1603 SETs(boolSV(left != right));
1610 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1617 else if (left < right)
1628 djSP; dTARGET; tryAMAGICun(neg);
1633 /* High falutin' math. */
1637 djSP; dTARGET; tryAMAGICbin(atan2,0);
1640 SETn(Perl_atan2(left, right));
1647 djSP; dTARGET; tryAMAGICun(sin);
1651 value = Perl_sin(value);
1659 djSP; dTARGET; tryAMAGICun(cos);
1663 value = Perl_cos(value);
1669 /* Support Configure command-line overrides for rand() functions.
1670 After 5.005, perhaps we should replace this by Configure support
1671 for drand48(), random(), or rand(). For 5.005, though, maintain
1672 compatibility by calling rand() but allow the user to override it.
1673 See INSTALL for details. --Andy Dougherty 15 July 1998
1675 /* Now it's after 5.005, and Configure supports drand48() and random(),
1676 in addition to rand(). So the overrides should not be needed any more.
1677 --Jarkko Hietaniemi 27 September 1998
1680 #ifndef HAS_DRAND48_PROTO
1681 extern double drand48 (void);
1694 if (!PL_srand_called) {
1695 (void)seedDrand01((Rand_seed_t)seed());
1696 PL_srand_called = TRUE;
1711 (void)seedDrand01((Rand_seed_t)anum);
1712 PL_srand_called = TRUE;
1721 * This is really just a quick hack which grabs various garbage
1722 * values. It really should be a real hash algorithm which
1723 * spreads the effect of every input bit onto every output bit,
1724 * if someone who knows about such things would bother to write it.
1725 * Might be a good idea to add that function to CORE as well.
1726 * No numbers below come from careful analysis or anything here,
1727 * except they are primes and SEED_C1 > 1E6 to get a full-width
1728 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1729 * probably be bigger too.
1732 # define SEED_C1 1000003
1733 #define SEED_C4 73819
1735 # define SEED_C1 25747
1736 #define SEED_C4 20639
1740 #define SEED_C5 26107
1743 #ifndef PERL_NO_DEV_RANDOM
1748 # include <starlet.h>
1749 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1750 * in 100-ns units, typically incremented ever 10 ms. */
1751 unsigned int when[2];
1753 # ifdef HAS_GETTIMEOFDAY
1754 struct timeval when;
1760 /* This test is an escape hatch, this symbol isn't set by Configure. */
1761 #ifndef PERL_NO_DEV_RANDOM
1762 #ifndef PERL_RANDOM_DEVICE
1763 /* /dev/random isn't used by default because reads from it will block
1764 * if there isn't enough entropy available. You can compile with
1765 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1766 * is enough real entropy to fill the seed. */
1767 # define PERL_RANDOM_DEVICE "/dev/urandom"
1769 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1771 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1780 _ckvmssts(sys$gettim(when));
1781 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1783 # ifdef HAS_GETTIMEOFDAY
1784 gettimeofday(&when,(struct timezone *) 0);
1785 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1788 u = (U32)SEED_C1 * when;
1791 u += SEED_C3 * (U32)PerlProc_getpid();
1792 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1793 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1794 u += SEED_C5 * (U32)PTR2UV(&when);
1801 djSP; dTARGET; tryAMAGICun(exp);
1805 value = Perl_exp(value);
1813 djSP; dTARGET; tryAMAGICun(log);
1818 RESTORE_NUMERIC_STANDARD();
1819 DIE(aTHX_ "Can't take log of %g", value);
1821 value = Perl_log(value);
1829 djSP; dTARGET; tryAMAGICun(sqrt);
1834 RESTORE_NUMERIC_STANDARD();
1835 DIE(aTHX_ "Can't take sqrt of %g", value);
1837 value = Perl_sqrt(value);
1850 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1856 (void)Perl_modf(value, &value);
1858 (void)Perl_modf(-value, &value);
1873 djSP; dTARGET; tryAMAGICun(abs);
1878 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1879 (iv = SvIVX(TOPs)) != IV_MIN) {
1901 XPUSHn(scan_hex(tmps, 99, &argtype));
1914 while (*tmps && isSPACE(*tmps))
1919 value = scan_hex(++tmps, 99, &argtype);
1920 else if (*tmps == 'b')
1921 value = scan_bin(++tmps, 99, &argtype);
1923 value = scan_oct(tmps, 99, &argtype);
1936 SETi(sv_len_utf8(sv));
1952 I32 lvalue = PL_op->op_flags & OPf_MOD;
1954 I32 arybase = PL_curcop->cop_arybase;
1958 SvTAINTED_off(TARG); /* decontaminate */
1959 SvUTF8_off(TARG); /* decontaminate */
1963 repl = SvPV(sv, repl_len);
1970 tmps = SvPV(sv, curlen);
1972 utfcurlen = sv_len_utf8(sv);
1973 if (utfcurlen == curlen)
1981 if (pos >= arybase) {
1999 else if (len >= 0) {
2001 if (rem > (I32)curlen)
2015 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2016 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2021 sv_pos_u2b(sv, &pos, &rem);
2025 sv_setpvn(TARG, tmps, rem);
2027 sv_insert(sv, pos, rem, repl, repl_len);
2028 else if (lvalue) { /* it's an lvalue! */
2029 if (!SvGMAGICAL(sv)) {
2033 if (ckWARN(WARN_SUBSTR))
2034 Perl_warner(aTHX_ WARN_SUBSTR,
2035 "Attempt to use reference as lvalue in substr");
2037 if (SvOK(sv)) /* is it defined ? */
2038 (void)SvPOK_only(sv);
2040 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2043 if (SvTYPE(TARG) < SVt_PVLV) {
2044 sv_upgrade(TARG, SVt_PVLV);
2045 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2049 if (LvTARG(TARG) != sv) {
2051 SvREFCNT_dec(LvTARG(TARG));
2052 LvTARG(TARG) = SvREFCNT_inc(sv);
2054 LvTARGOFF(TARG) = pos;
2055 LvTARGLEN(TARG) = rem;
2059 PUSHs(TARG); /* avoid SvSETMAGIC here */
2066 register I32 size = POPi;
2067 register I32 offset = POPi;
2068 register SV *src = POPs;
2069 I32 lvalue = PL_op->op_flags & OPf_MOD;
2071 SvTAINTED_off(TARG); /* decontaminate */
2072 if (lvalue) { /* it's an lvalue! */
2073 if (SvTYPE(TARG) < SVt_PVLV) {
2074 sv_upgrade(TARG, SVt_PVLV);
2075 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2078 if (LvTARG(TARG) != src) {
2080 SvREFCNT_dec(LvTARG(TARG));
2081 LvTARG(TARG) = SvREFCNT_inc(src);
2083 LvTARGOFF(TARG) = offset;
2084 LvTARGLEN(TARG) = size;
2087 sv_setuv(TARG, do_vecget(src, offset, size));
2102 I32 arybase = PL_curcop->cop_arybase;
2107 offset = POPi - arybase;
2110 tmps = SvPV(big, biglen);
2111 if (offset > 0 && DO_UTF8(big))
2112 sv_pos_u2b(big, &offset, 0);
2115 else if (offset > biglen)
2117 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2118 (unsigned char*)tmps + biglen, little, 0)))
2121 retval = tmps2 - tmps;
2122 if (retval > 0 && DO_UTF8(big))
2123 sv_pos_b2u(big, &retval);
2124 PUSHi(retval + arybase);
2139 I32 arybase = PL_curcop->cop_arybase;
2145 tmps2 = SvPV(little, llen);
2146 tmps = SvPV(big, blen);
2150 if (offset > 0 && DO_UTF8(big))
2151 sv_pos_u2b(big, &offset, 0);
2152 offset = offset - arybase + llen;
2156 else if (offset > blen)
2158 if (!(tmps2 = rninstr(tmps, tmps + offset,
2159 tmps2, tmps2 + llen)))
2162 retval = tmps2 - tmps;
2163 if (retval > 0 && DO_UTF8(big))
2164 sv_pos_b2u(big, &retval);
2165 PUSHi(retval + arybase);
2171 djSP; dMARK; dORIGMARK; dTARGET;
2172 do_sprintf(TARG, SP-MARK, MARK+1);
2173 TAINT_IF(SvTAINTED(TARG));
2185 U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
2188 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2189 value = utf8_to_uv(tmps, &retlen);
2191 value = (UV)(*tmps & 255);
2202 (void)SvUPGRADE(TARG,SVt_PV);
2204 if (value > 255 && !IN_BYTE) {
2207 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2208 SvCUR_set(TARG, tmps - SvPVX(TARG));
2211 (void)SvPOK_only(TARG);
2221 SvUTF8_off(TARG); /* decontaminate */
2222 (void)SvPOK_only(TARG);
2229 djSP; dTARGET; dPOPTOPssrl;
2232 char *tmps = SvPV(left, n_a);
2234 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2236 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2240 "The crypt() function is unimplemented due to excessive paranoia.");
2253 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2257 UV uv = utf8_to_uv(s, &ulen);
2259 if (PL_op->op_private & OPpLOCALE) {
2262 uv = toTITLE_LC_uni(uv);
2265 uv = toTITLE_utf8(s);
2267 tend = uv_to_utf8(tmpbuf, uv);
2269 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2271 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2272 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2277 s = (U8*)SvPV_force(sv, slen);
2278 Copy(tmpbuf, s, ulen, U8);
2282 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2284 SvUTF8_off(TARG); /* decontaminate */
2289 s = (U8*)SvPV_force(sv, slen);
2291 if (PL_op->op_private & OPpLOCALE) {
2294 *s = toUPPER_LC(*s);
2312 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2316 UV uv = utf8_to_uv(s, &ulen);
2318 if (PL_op->op_private & OPpLOCALE) {
2321 uv = toLOWER_LC_uni(uv);
2324 uv = toLOWER_utf8(s);
2326 tend = uv_to_utf8(tmpbuf, uv);
2328 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2330 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2331 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2336 s = (U8*)SvPV_force(sv, slen);
2337 Copy(tmpbuf, s, ulen, U8);
2341 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2343 SvUTF8_off(TARG); /* decontaminate */
2348 s = (U8*)SvPV_force(sv, slen);
2350 if (PL_op->op_private & OPpLOCALE) {
2353 *s = toLOWER_LC(*s);
2377 s = (U8*)SvPV(sv,len);
2379 SvUTF8_off(TARG); /* decontaminate */
2380 sv_setpvn(TARG, "", 0);
2384 (void)SvUPGRADE(TARG, SVt_PV);
2385 SvGROW(TARG, (len * 2) + 1);
2386 (void)SvPOK_only(TARG);
2387 d = (U8*)SvPVX(TARG);
2389 if (PL_op->op_private & OPpLOCALE) {
2393 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2399 d = uv_to_utf8(d, toUPPER_utf8( s ));
2405 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2410 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2412 SvUTF8_off(TARG); /* decontaminate */
2417 s = (U8*)SvPV_force(sv, len);
2419 register U8 *send = s + len;
2421 if (PL_op->op_private & OPpLOCALE) {
2424 for (; s < send; s++)
2425 *s = toUPPER_LC(*s);
2428 for (; s < send; s++)
2451 s = (U8*)SvPV(sv,len);
2453 SvUTF8_off(TARG); /* decontaminate */
2454 sv_setpvn(TARG, "", 0);
2458 (void)SvUPGRADE(TARG, SVt_PV);
2459 SvGROW(TARG, (len * 2) + 1);
2460 (void)SvPOK_only(TARG);
2461 d = (U8*)SvPVX(TARG);
2463 if (PL_op->op_private & OPpLOCALE) {
2467 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2473 d = uv_to_utf8(d, toLOWER_utf8(s));
2479 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2484 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2486 SvUTF8_off(TARG); /* decontaminate */
2492 s = (U8*)SvPV_force(sv, len);
2494 register U8 *send = s + len;
2496 if (PL_op->op_private & OPpLOCALE) {
2499 for (; s < send; s++)
2500 *s = toLOWER_LC(*s);
2503 for (; s < send; s++)
2518 register char *s = SvPV(sv,len);
2521 SvUTF8_off(TARG); /* decontaminate */
2523 (void)SvUPGRADE(TARG, SVt_PV);
2524 SvGROW(TARG, (len * 2) + 1);
2529 STRLEN ulen = UTF8SKIP(s);
2553 SvCUR_set(TARG, d - SvPVX(TARG));
2554 (void)SvPOK_only(TARG);
2557 sv_setpvn(TARG, s, len);
2559 if (SvSMAGICAL(TARG))
2568 djSP; dMARK; dORIGMARK;
2570 register AV* av = (AV*)POPs;
2571 register I32 lval = PL_op->op_flags & OPf_MOD;
2572 I32 arybase = PL_curcop->cop_arybase;
2575 if (SvTYPE(av) == SVt_PVAV) {
2576 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2578 for (svp = MARK + 1; svp <= SP; svp++) {
2583 if (max > AvMAX(av))
2586 while (++MARK <= SP) {
2587 elem = SvIVx(*MARK);
2591 svp = av_fetch(av, elem, lval);
2593 if (!svp || *svp == &PL_sv_undef)
2594 DIE(aTHX_ PL_no_aelem, elem);
2595 if (PL_op->op_private & OPpLVAL_INTRO)
2596 save_aelem(av, elem, svp);
2598 *MARK = svp ? *svp : &PL_sv_undef;
2601 if (GIMME != G_ARRAY) {
2609 /* Associative arrays. */
2614 HV *hash = (HV*)POPs;
2616 I32 gimme = GIMME_V;
2617 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2620 /* might clobber stack_sp */
2621 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2626 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2627 if (gimme == G_ARRAY) {
2630 /* might clobber stack_sp */
2632 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2637 else if (gimme == G_SCALAR)
2656 I32 gimme = GIMME_V;
2657 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2661 if (PL_op->op_private & OPpSLICE) {
2665 hvtype = SvTYPE(hv);
2666 if (hvtype == SVt_PVHV) { /* hash element */
2667 while (++MARK <= SP) {
2668 sv = hv_delete_ent(hv, *MARK, discard, 0);
2669 *MARK = sv ? sv : &PL_sv_undef;
2672 else if (hvtype == SVt_PVAV) {
2673 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2674 while (++MARK <= SP) {
2675 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2676 *MARK = sv ? sv : &PL_sv_undef;
2679 else { /* pseudo-hash element */
2680 while (++MARK <= SP) {
2681 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2682 *MARK = sv ? sv : &PL_sv_undef;
2687 DIE(aTHX_ "Not a HASH reference");
2690 else if (gimme == G_SCALAR) {
2699 if (SvTYPE(hv) == SVt_PVHV)
2700 sv = hv_delete_ent(hv, keysv, discard, 0);
2701 else if (SvTYPE(hv) == SVt_PVAV) {
2702 if (PL_op->op_flags & OPf_SPECIAL)
2703 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2705 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2708 DIE(aTHX_ "Not a HASH reference");
2723 if (PL_op->op_private & OPpEXISTS_SUB) {
2727 cv = sv_2cv(sv, &hv, &gv, FALSE);
2730 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2736 if (SvTYPE(hv) == SVt_PVHV) {
2737 if (hv_exists_ent(hv, tmpsv, 0))
2740 else if (SvTYPE(hv) == SVt_PVAV) {
2741 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2742 if (av_exists((AV*)hv, SvIV(tmpsv)))
2745 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2749 DIE(aTHX_ "Not a HASH reference");
2756 djSP; dMARK; dORIGMARK;
2757 register HV *hv = (HV*)POPs;
2758 register I32 lval = PL_op->op_flags & OPf_MOD;
2759 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2761 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2762 DIE(aTHX_ "Can't localize pseudo-hash element");
2764 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2765 while (++MARK <= SP) {
2769 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2770 svp = he ? &HeVAL(he) : 0;
2773 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2776 if (!svp || *svp == &PL_sv_undef) {
2778 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2780 if (PL_op->op_private & OPpLVAL_INTRO)
2781 save_helem(hv, keysv, svp);
2783 *MARK = svp ? *svp : &PL_sv_undef;
2786 if (GIMME != G_ARRAY) {
2794 /* List operators. */
2799 if (GIMME != G_ARRAY) {
2801 *MARK = *SP; /* unwanted list, return last item */
2803 *MARK = &PL_sv_undef;
2812 SV **lastrelem = PL_stack_sp;
2813 SV **lastlelem = PL_stack_base + POPMARK;
2814 SV **firstlelem = PL_stack_base + POPMARK + 1;
2815 register SV **firstrelem = lastlelem + 1;
2816 I32 arybase = PL_curcop->cop_arybase;
2817 I32 lval = PL_op->op_flags & OPf_MOD;
2818 I32 is_something_there = lval;
2820 register I32 max = lastrelem - lastlelem;
2821 register SV **lelem;
2824 if (GIMME != G_ARRAY) {
2825 ix = SvIVx(*lastlelem);
2830 if (ix < 0 || ix >= max)
2831 *firstlelem = &PL_sv_undef;
2833 *firstlelem = firstrelem[ix];
2839 SP = firstlelem - 1;
2843 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2849 if (ix < 0 || ix >= max)
2850 *lelem = &PL_sv_undef;
2852 is_something_there = TRUE;
2853 if (!(*lelem = firstrelem[ix]))
2854 *lelem = &PL_sv_undef;
2857 if (is_something_there)
2860 SP = firstlelem - 1;
2866 djSP; dMARK; dORIGMARK;
2867 I32 items = SP - MARK;
2868 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2869 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2876 djSP; dMARK; dORIGMARK;
2877 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2881 SV *val = NEWSV(46, 0);
2883 sv_setsv(val, *++MARK);
2884 else if (ckWARN(WARN_UNSAFE))
2885 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2886 (void)hv_store_ent(hv,key,val,0);
2895 djSP; dMARK; dORIGMARK;
2896 register AV *ary = (AV*)*++MARK;
2900 register I32 offset;
2901 register I32 length;
2908 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2909 *MARK-- = SvTIED_obj((SV*)ary, mg);
2913 call_method("SPLICE",GIMME_V);
2922 offset = i = SvIVx(*MARK);
2924 offset += AvFILLp(ary) + 1;
2926 offset -= PL_curcop->cop_arybase;
2928 DIE(aTHX_ PL_no_aelem, i);
2930 length = SvIVx(*MARK++);
2932 length += AvFILLp(ary) - offset + 1;
2938 length = AvMAX(ary) + 1; /* close enough to infinity */
2942 length = AvMAX(ary) + 1;
2944 if (offset > AvFILLp(ary) + 1)
2945 offset = AvFILLp(ary) + 1;
2946 after = AvFILLp(ary) + 1 - (offset + length);
2947 if (after < 0) { /* not that much array */
2948 length += after; /* offset+length now in array */
2954 /* At this point, MARK .. SP-1 is our new LIST */
2957 diff = newlen - length;
2958 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2961 if (diff < 0) { /* shrinking the area */
2963 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2964 Copy(MARK, tmparyval, newlen, SV*);
2967 MARK = ORIGMARK + 1;
2968 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2969 MEXTEND(MARK, length);
2970 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2972 EXTEND_MORTAL(length);
2973 for (i = length, dst = MARK; i; i--) {
2974 sv_2mortal(*dst); /* free them eventualy */
2981 *MARK = AvARRAY(ary)[offset+length-1];
2984 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2985 SvREFCNT_dec(*dst++); /* free them now */
2988 AvFILLp(ary) += diff;
2990 /* pull up or down? */
2992 if (offset < after) { /* easier to pull up */
2993 if (offset) { /* esp. if nothing to pull */
2994 src = &AvARRAY(ary)[offset-1];
2995 dst = src - diff; /* diff is negative */
2996 for (i = offset; i > 0; i--) /* can't trust Copy */
3000 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3004 if (after) { /* anything to pull down? */
3005 src = AvARRAY(ary) + offset + length;
3006 dst = src + diff; /* diff is negative */
3007 Move(src, dst, after, SV*);
3009 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3010 /* avoid later double free */
3014 dst[--i] = &PL_sv_undef;
3017 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3019 *dst = NEWSV(46, 0);
3020 sv_setsv(*dst++, *src++);
3022 Safefree(tmparyval);
3025 else { /* no, expanding (or same) */
3027 New(452, tmparyval, length, SV*); /* so remember deletion */
3028 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3031 if (diff > 0) { /* expanding */
3033 /* push up or down? */
3035 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3039 Move(src, dst, offset, SV*);
3041 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3043 AvFILLp(ary) += diff;
3046 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3047 av_extend(ary, AvFILLp(ary) + diff);
3048 AvFILLp(ary) += diff;
3051 dst = AvARRAY(ary) + AvFILLp(ary);
3053 for (i = after; i; i--) {
3060 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3061 *dst = NEWSV(46, 0);
3062 sv_setsv(*dst++, *src++);
3064 MARK = ORIGMARK + 1;
3065 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3067 Copy(tmparyval, MARK, length, SV*);
3069 EXTEND_MORTAL(length);
3070 for (i = length, dst = MARK; i; i--) {
3071 sv_2mortal(*dst); /* free them eventualy */
3075 Safefree(tmparyval);
3079 else if (length--) {
3080 *MARK = tmparyval[length];
3083 while (length-- > 0)
3084 SvREFCNT_dec(tmparyval[length]);
3086 Safefree(tmparyval);
3089 *MARK = &PL_sv_undef;
3097 djSP; dMARK; dORIGMARK; dTARGET;
3098 register AV *ary = (AV*)*++MARK;
3099 register SV *sv = &PL_sv_undef;
3102 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3103 *MARK-- = SvTIED_obj((SV*)ary, mg);
3107 call_method("PUSH",G_SCALAR|G_DISCARD);
3112 /* Why no pre-extend of ary here ? */
3113 for (++MARK; MARK <= SP; MARK++) {
3116 sv_setsv(sv, *MARK);
3121 PUSHi( AvFILL(ary) + 1 );
3129 SV *sv = av_pop(av);
3131 (void)sv_2mortal(sv);
3140 SV *sv = av_shift(av);
3145 (void)sv_2mortal(sv);
3152 djSP; dMARK; dORIGMARK; dTARGET;
3153 register AV *ary = (AV*)*++MARK;
3158 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3159 *MARK-- = SvTIED_obj((SV*)ary, mg);
3163 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3168 av_unshift(ary, SP - MARK);
3171 sv_setsv(sv, *++MARK);
3172 (void)av_store(ary, i++, sv);
3176 PUSHi( AvFILL(ary) + 1 );
3186 if (GIMME == G_ARRAY) {
3193 /* safe as long as stack cannot get extended in the above */
3198 register char *down;
3203 SvUTF8_off(TARG); /* decontaminate */
3205 do_join(TARG, &PL_sv_no, MARK, SP);
3207 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3208 up = SvPV_force(TARG, len);
3210 if (DO_UTF8(TARG)) { /* first reverse each character */
3211 U8* s = (U8*)SvPVX(TARG);
3212 U8* send = (U8*)(s + len);
3221 down = (char*)(s - 1);
3222 if (s > send || !((*down & 0xc0) == 0x80)) {
3223 if (ckWARN_d(WARN_UTF8))
3224 Perl_warner(aTHX_ WARN_UTF8,
3225 "Malformed UTF-8 character");
3237 down = SvPVX(TARG) + len - 1;
3243 (void)SvPOK_only(TARG);
3252 S_mul128(pTHX_ SV *sv, U8 m)
3255 char *s = SvPV(sv, len);
3259 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3260 SV *tmpNew = newSVpvn("0000000000", 10);
3262 sv_catsv(tmpNew, sv);
3263 SvREFCNT_dec(sv); /* free old sv */
3268 while (!*t) /* trailing '\0'? */
3271 i = ((*t - '0') << 7) + m;
3272 *(t--) = '0' + (i % 10);
3278 /* Explosives and implosives. */
3280 #if 'I' == 73 && 'J' == 74
3281 /* On an ASCII/ISO kind of system */
3282 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3285 Some other sort of character set - use memchr() so we don't match
3288 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3295 I32 start_sp_offset = SP - PL_stack_base;
3296 I32 gimme = GIMME_V;
3300 register char *pat = SvPV(left, llen);
3301 register char *s = SvPV(right, rlen);
3302 char *strend = s + rlen;
3304 register char *patend = pat + llen;
3310 /* These must not be in registers: */
3327 register U32 culong;
3331 #ifdef PERL_NATINT_PACK
3332 int natint; /* native integer */
3333 int unatint; /* unsigned native integer */
3336 if (gimme != G_ARRAY) { /* arrange to do first one only */
3338 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3339 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3341 while (isDIGIT(*patend) || *patend == '*')
3347 while (pat < patend) {
3349 datumtype = *pat++ & 0xFF;
3350 #ifdef PERL_NATINT_PACK
3353 if (isSPACE(datumtype))
3355 if (datumtype == '#') {
3356 while (pat < patend && *pat != '\n')
3361 char *natstr = "sSiIlL";
3363 if (strchr(natstr, datumtype)) {
3364 #ifdef PERL_NATINT_PACK
3370 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3375 else if (*pat == '*') {
3376 len = strend - strbeg; /* long enough */
3380 else if (isDIGIT(*pat)) {
3382 while (isDIGIT(*pat)) {
3383 len = (len * 10) + (*pat++ - '0');
3385 DIE(aTHX_ "Repeat count in unpack overflows");
3389 len = (datumtype != '@');
3393 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3394 case ',': /* grandfather in commas but with a warning */
3395 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3396 Perl_warner(aTHX_ WARN_UNSAFE,
3397 "Invalid type in unpack: '%c'", (int)datumtype);
3400 if (len == 1 && pat[-1] != '1')
3409 if (len > strend - strbeg)
3410 DIE(aTHX_ "@ outside of string");
3414 if (len > s - strbeg)
3415 DIE(aTHX_ "X outside of string");
3419 if (len > strend - s)
3420 DIE(aTHX_ "x outside of string");
3424 if (start_sp_offset >= SP - PL_stack_base)
3425 DIE(aTHX_ "/ must follow a numeric type");
3428 pat++; /* ignore '*' for compatibility with pack */
3430 DIE(aTHX_ "/ cannot take a count" );
3437 if (len > strend - s)
3440 goto uchar_checksum;
3441 sv = NEWSV(35, len);
3442 sv_setpvn(sv, s, len);
3444 if (datumtype == 'A' || datumtype == 'Z') {
3445 aptr = s; /* borrow register */
3446 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3451 else { /* 'A' strips both nulls and spaces */
3452 s = SvPVX(sv) + len - 1;
3453 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3457 SvCUR_set(sv, s - SvPVX(sv));
3458 s = aptr; /* unborrow register */
3460 XPUSHs(sv_2mortal(sv));
3464 if (star || len > (strend - s) * 8)
3465 len = (strend - s) * 8;
3468 Newz(601, PL_bitcount, 256, char);
3469 for (bits = 1; bits < 256; bits++) {
3470 if (bits & 1) PL_bitcount[bits]++;
3471 if (bits & 2) PL_bitcount[bits]++;
3472 if (bits & 4) PL_bitcount[bits]++;
3473 if (bits & 8) PL_bitcount[bits]++;
3474 if (bits & 16) PL_bitcount[bits]++;
3475 if (bits & 32) PL_bitcount[bits]++;
3476 if (bits & 64) PL_bitcount[bits]++;
3477 if (bits & 128) PL_bitcount[bits]++;
3481 culong += PL_bitcount[*(unsigned char*)s++];
3486 if (datumtype == 'b') {
3488 if (bits & 1) culong++;
3494 if (bits & 128) culong++;
3501 sv = NEWSV(35, len + 1);
3505 if (datumtype == 'b') {
3507 for (len = 0; len < aint; len++) {
3508 if (len & 7) /*SUPPRESS 595*/
3512 *str++ = '0' + (bits & 1);
3517 for (len = 0; len < aint; len++) {
3522 *str++ = '0' + ((bits & 128) != 0);
3526 XPUSHs(sv_2mortal(sv));
3530 if (star || len > (strend - s) * 2)
3531 len = (strend - s) * 2;
3532 sv = NEWSV(35, len + 1);
3536 if (datumtype == 'h') {
3538 for (len = 0; len < aint; len++) {
3543 *str++ = PL_hexdigit[bits & 15];
3548 for (len = 0; len < aint; len++) {
3553 *str++ = PL_hexdigit[(bits >> 4) & 15];
3557 XPUSHs(sv_2mortal(sv));
3560 if (len > strend - s)
3565 if (aint >= 128) /* fake up signed chars */
3575 if (aint >= 128) /* fake up signed chars */
3578 sv_setiv(sv, (IV)aint);
3579 PUSHs(sv_2mortal(sv));
3584 if (len > strend - s)
3599 sv_setiv(sv, (IV)auint);
3600 PUSHs(sv_2mortal(sv));
3605 if (len > strend - s)
3608 while (len-- > 0 && s < strend) {
3609 auint = utf8_to_uv((U8*)s, &along);
3612 cdouble += (NV)auint;
3620 while (len-- > 0 && s < strend) {
3621 auint = utf8_to_uv((U8*)s, &along);
3624 sv_setuv(sv, (UV)auint);
3625 PUSHs(sv_2mortal(sv));
3630 #if SHORTSIZE == SIZE16
3631 along = (strend - s) / SIZE16;
3633 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3638 #if SHORTSIZE != SIZE16
3642 COPYNN(s, &ashort, sizeof(short));
3653 #if SHORTSIZE > SIZE16
3665 #if SHORTSIZE != SIZE16
3669 COPYNN(s, &ashort, sizeof(short));
3672 sv_setiv(sv, (IV)ashort);
3673 PUSHs(sv_2mortal(sv));
3681 #if SHORTSIZE > SIZE16
3687 sv_setiv(sv, (IV)ashort);
3688 PUSHs(sv_2mortal(sv));
3696 #if SHORTSIZE == SIZE16
3697 along = (strend - s) / SIZE16;
3699 unatint = natint && datumtype == 'S';
3700 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3705 #if SHORTSIZE != SIZE16
3707 unsigned short aushort;
3709 COPYNN(s, &aushort, sizeof(unsigned short));
3710 s += sizeof(unsigned short);
3718 COPY16(s, &aushort);
3721 if (datumtype == 'n')
3722 aushort = PerlSock_ntohs(aushort);
3725 if (datumtype == 'v')
3726 aushort = vtohs(aushort);
3735 #if SHORTSIZE != SIZE16
3737 unsigned short aushort;
3739 COPYNN(s, &aushort, sizeof(unsigned short));
3740 s += sizeof(unsigned short);
3742 sv_setiv(sv, (UV)aushort);
3743 PUSHs(sv_2mortal(sv));
3750 COPY16(s, &aushort);
3754 if (datumtype == 'n')
3755 aushort = PerlSock_ntohs(aushort);
3758 if (datumtype == 'v')
3759 aushort = vtohs(aushort);
3761 sv_setiv(sv, (UV)aushort);
3762 PUSHs(sv_2mortal(sv));
3768 along = (strend - s) / sizeof(int);
3773 Copy(s, &aint, 1, int);
3776 cdouble += (NV)aint;
3785 Copy(s, &aint, 1, int);
3789 /* Without the dummy below unpack("i", pack("i",-1))
3790 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3791 * cc with optimization turned on.
3793 * The bug was detected in
3794 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3795 * with optimization (-O4) turned on.
3796 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3797 * does not have this problem even with -O4.
3799 * This bug was reported as DECC_BUGS 1431
3800 * and tracked internally as GEM_BUGS 7775.
3802 * The bug is fixed in
3803 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3804 * UNIX V4.0F support: DEC C V5.9-006 or later
3805 * UNIX V4.0E support: DEC C V5.8-011 or later
3808 * See also few lines later for the same bug.
3811 sv_setiv(sv, (IV)aint) :
3813 sv_setiv(sv, (IV)aint);
3814 PUSHs(sv_2mortal(sv));
3819 along = (strend - s) / sizeof(unsigned int);
3824 Copy(s, &auint, 1, unsigned int);
3825 s += sizeof(unsigned int);
3827 cdouble += (NV)auint;
3836 Copy(s, &auint, 1, unsigned int);
3837 s += sizeof(unsigned int);
3840 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3841 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3842 * See details few lines earlier. */
3844 sv_setuv(sv, (UV)auint) :
3846 sv_setuv(sv, (UV)auint);
3847 PUSHs(sv_2mortal(sv));
3852 #if LONGSIZE == SIZE32
3853 along = (strend - s) / SIZE32;
3855 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3860 #if LONGSIZE != SIZE32
3864 COPYNN(s, &along, sizeof(long));
3867 cdouble += (NV)along;
3877 #if LONGSIZE > SIZE32
3878 if (along > 2147483647)
3879 along -= 4294967296;
3883 cdouble += (NV)along;
3892 #if LONGSIZE != SIZE32
3896 COPYNN(s, &along, sizeof(long));
3899 sv_setiv(sv, (IV)along);
3900 PUSHs(sv_2mortal(sv));
3908 #if LONGSIZE > SIZE32
3909 if (along > 2147483647)
3910 along -= 4294967296;
3914 sv_setiv(sv, (IV)along);
3915 PUSHs(sv_2mortal(sv));
3923 #if LONGSIZE == SIZE32
3924 along = (strend - s) / SIZE32;
3926 unatint = natint && datumtype == 'L';
3927 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3932 #if LONGSIZE != SIZE32
3934 unsigned long aulong;
3936 COPYNN(s, &aulong, sizeof(unsigned long));
3937 s += sizeof(unsigned long);
3939 cdouble += (NV)aulong;
3951 if (datumtype == 'N')
3952 aulong = PerlSock_ntohl(aulong);
3955 if (datumtype == 'V')
3956 aulong = vtohl(aulong);
3959 cdouble += (NV)aulong;
3968 #if LONGSIZE != SIZE32
3970 unsigned long aulong;
3972 COPYNN(s, &aulong, sizeof(unsigned long));
3973 s += sizeof(unsigned long);
3975 sv_setuv(sv, (UV)aulong);
3976 PUSHs(sv_2mortal(sv));
3986 if (datumtype == 'N')
3987 aulong = PerlSock_ntohl(aulong);
3990 if (datumtype == 'V')
3991 aulong = vtohl(aulong);
3994 sv_setuv(sv, (UV)aulong);
3995 PUSHs(sv_2mortal(sv));
4001 along = (strend - s) / sizeof(char*);
4007 if (sizeof(char*) > strend - s)
4010 Copy(s, &aptr, 1, char*);
4016 PUSHs(sv_2mortal(sv));
4026 while ((len > 0) && (s < strend)) {
4027 auv = (auv << 7) | (*s & 0x7f);
4028 if (!(*s++ & 0x80)) {
4032 PUSHs(sv_2mortal(sv));
4036 else if (++bytes >= sizeof(UV)) { /* promote to string */
4040 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4041 while (s < strend) {
4042 sv = mul128(sv, *s & 0x7f);
4043 if (!(*s++ & 0x80)) {
4052 PUSHs(sv_2mortal(sv));
4057 if ((s >= strend) && bytes)
4058 DIE(aTHX_ "Unterminated compressed integer");
4063 if (sizeof(char*) > strend - s)
4066 Copy(s, &aptr, 1, char*);
4071 sv_setpvn(sv, aptr, len);
4072 PUSHs(sv_2mortal(sv));
4076 along = (strend - s) / sizeof(Quad_t);
4082 if (s + sizeof(Quad_t) > strend)
4085 Copy(s, &aquad, 1, Quad_t);
4086 s += sizeof(Quad_t);
4089 if (aquad >= IV_MIN && aquad <= IV_MAX)
4090 sv_setiv(sv, (IV)aquad);
4092 sv_setnv(sv, (NV)aquad);
4093 PUSHs(sv_2mortal(sv));
4097 along = (strend - s) / sizeof(Quad_t);
4103 if (s + sizeof(Uquad_t) > strend)
4106 Copy(s, &auquad, 1, Uquad_t);
4107 s += sizeof(Uquad_t);
4110 if (auquad <= UV_MAX)
4111 sv_setuv(sv, (UV)auquad);
4113 sv_setnv(sv, (NV)auquad);
4114 PUSHs(sv_2mortal(sv));
4118 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4121 along = (strend - s) / sizeof(float);
4126 Copy(s, &afloat, 1, float);
4135 Copy(s, &afloat, 1, float);
4138 sv_setnv(sv, (NV)afloat);
4139 PUSHs(sv_2mortal(sv));
4145 along = (strend - s) / sizeof(double);
4150 Copy(s, &adouble, 1, double);
4151 s += sizeof(double);
4159 Copy(s, &adouble, 1, double);
4160 s += sizeof(double);
4162 sv_setnv(sv, (NV)adouble);
4163 PUSHs(sv_2mortal(sv));
4169 * Initialise the decode mapping. By using a table driven
4170 * algorithm, the code will be character-set independent
4171 * (and just as fast as doing character arithmetic)
4173 if (PL_uudmap['M'] == 0) {
4176 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4177 PL_uudmap[PL_uuemap[i]] = i;
4179 * Because ' ' and '`' map to the same value,
4180 * we need to decode them both the same.
4185 along = (strend - s) * 3 / 4;
4186 sv = NEWSV(42, along);
4189 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4194 len = PL_uudmap[*s++] & 077;
4196 if (s < strend && ISUUCHAR(*s))
4197 a = PL_uudmap[*s++] & 077;
4200 if (s < strend && ISUUCHAR(*s))
4201 b = PL_uudmap[*s++] & 077;
4204 if (s < strend && ISUUCHAR(*s))
4205 c = PL_uudmap[*s++] & 077;
4208 if (s < strend && ISUUCHAR(*s))
4209 d = PL_uudmap[*s++] & 077;
4212 hunk[0] = (a << 2) | (b >> 4);
4213 hunk[1] = (b << 4) | (c >> 2);
4214 hunk[2] = (c << 6) | d;
4215 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4220 else if (s[1] == '\n') /* possible checksum byte */
4223 XPUSHs(sv_2mortal(sv));
4228 if (strchr("fFdD", datumtype) ||
4229 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4233 while (checksum >= 16) {
4237 while (checksum >= 4) {
4243 along = (1 << checksum) - 1;
4244 while (cdouble < 0.0)
4246 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4247 sv_setnv(sv, cdouble);
4250 if (checksum < 32) {
4251 aulong = (1 << checksum) - 1;
4254 sv_setuv(sv, (UV)culong);
4256 XPUSHs(sv_2mortal(sv));
4260 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4261 PUSHs(&PL_sv_undef);
4266 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4270 *hunk = PL_uuemap[len];
4271 sv_catpvn(sv, hunk, 1);
4274 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4275 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4276 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4277 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4278 sv_catpvn(sv, hunk, 4);
4283 char r = (len > 1 ? s[1] : '\0');
4284 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4285 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4286 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4287 hunk[3] = PL_uuemap[0];
4288 sv_catpvn(sv, hunk, 4);
4290 sv_catpvn(sv, "\n", 1);
4294 S_is_an_int(pTHX_ char *s, STRLEN l)
4297 SV *result = newSVpvn(s, l);
4298 char *result_c = SvPV(result, n_a); /* convenience */
4299 char *out = result_c;
4309 SvREFCNT_dec(result);
4332 SvREFCNT_dec(result);
4338 SvCUR_set(result, out - result_c);
4342 /* pnum must be '\0' terminated */
4344 S_div128(pTHX_ SV *pnum, bool *done)
4347 char *s = SvPV(pnum, len);
4356 i = m * 10 + (*t - '0');
4358 r = (i >> 7); /* r < 10 */
4365 SvCUR_set(pnum, (STRLEN) (t - s));
4372 djSP; dMARK; dORIGMARK; dTARGET;
4373 register SV *cat = TARG;
4376 register char *pat = SvPVx(*++MARK, fromlen);
4377 register char *patend = pat + fromlen;
4382 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4383 static char *space10 = " ";
4385 /* These must not be in registers: */
4400 #ifdef PERL_NATINT_PACK
4401 int natint; /* native integer */
4406 sv_setpvn(cat, "", 0);
4407 while (pat < patend) {
4408 SV *lengthcode = Nullsv;
4409 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4410 datumtype = *pat++ & 0xFF;
4411 #ifdef PERL_NATINT_PACK
4414 if (isSPACE(datumtype))
4416 if (datumtype == '#') {
4417 while (pat < patend && *pat != '\n')
4422 char *natstr = "sSiIlL";
4424 if (strchr(natstr, datumtype)) {
4425 #ifdef PERL_NATINT_PACK
4431 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4434 len = strchr("@Xxu", datumtype) ? 0 : items;
4437 else if (isDIGIT(*pat)) {
4439 while (isDIGIT(*pat)) {
4440 len = (len * 10) + (*pat++ - '0');
4442 DIE(aTHX_ "Repeat count in pack overflows");
4449 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4450 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4451 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4452 ? *MARK : &PL_sv_no)));
4456 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4457 case ',': /* grandfather in commas but with a warning */
4458 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4459 Perl_warner(aTHX_ WARN_UNSAFE,
4460 "Invalid type in pack: '%c'", (int)datumtype);
4463 DIE(aTHX_ "%% may only be used in unpack");
4474 if (SvCUR(cat) < len)
4475 DIE(aTHX_ "X outside of string");
4482 sv_catpvn(cat, null10, 10);
4485 sv_catpvn(cat, null10, len);
4491 aptr = SvPV(fromstr, fromlen);
4492 if (pat[-1] == '*') {
4494 if (datumtype == 'Z')
4497 if (fromlen >= len) {
4498 sv_catpvn(cat, aptr, len);
4499 if (datumtype == 'Z')
4500 *(SvEND(cat)-1) = '\0';
4503 sv_catpvn(cat, aptr, fromlen);
4505 if (datumtype == 'A') {
4507 sv_catpvn(cat, space10, 10);
4510 sv_catpvn(cat, space10, len);
4514 sv_catpvn(cat, null10, 10);
4517 sv_catpvn(cat, null10, len);
4529 str = SvPV(fromstr, fromlen);
4533 SvCUR(cat) += (len+7)/8;
4534 SvGROW(cat, SvCUR(cat) + 1);
4535 aptr = SvPVX(cat) + aint;
4540 if (datumtype == 'B') {
4541 for (len = 0; len++ < aint;) {
4542 items |= *str++ & 1;
4546 *aptr++ = items & 0xff;
4552 for (len = 0; len++ < aint;) {
4558 *aptr++ = items & 0xff;
4564 if (datumtype == 'B')
4565 items <<= 7 - (aint & 7);
4567 items >>= 7 - (aint & 7);
4568 *aptr++ = items & 0xff;
4570 str = SvPVX(cat) + SvCUR(cat);
4585 str = SvPV(fromstr, fromlen);
4589 SvCUR(cat) += (len+1)/2;
4590 SvGROW(cat, SvCUR(cat) + 1);
4591 aptr = SvPVX(cat) + aint;
4596 if (datumtype == 'H') {
4597 for (len = 0; len++ < aint;) {
4599 items |= ((*str++ & 15) + 9) & 15;
4601 items |= *str++ & 15;
4605 *aptr++ = items & 0xff;
4611 for (len = 0; len++ < aint;) {
4613 items |= (((*str++ & 15) + 9) & 15) << 4;
4615 items |= (*str++ & 15) << 4;
4619 *aptr++ = items & 0xff;
4625 *aptr++ = items & 0xff;
4626 str = SvPVX(cat) + SvCUR(cat);
4637 aint = SvIV(fromstr);
4639 sv_catpvn(cat, &achar, sizeof(char));
4645 auint = SvUV(fromstr);
4646 SvGROW(cat, SvCUR(cat) + 10);
4647 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4652 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4657 afloat = (float)SvNV(fromstr);
4658 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4665 adouble = (double)SvNV(fromstr);
4666 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4672 ashort = (I16)SvIV(fromstr);
4674 ashort = PerlSock_htons(ashort);
4676 CAT16(cat, &ashort);
4682 ashort = (I16)SvIV(fromstr);
4684 ashort = htovs(ashort);
4686 CAT16(cat, &ashort);
4690 #if SHORTSIZE != SIZE16
4692 unsigned short aushort;
4696 aushort = SvUV(fromstr);
4697 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4707 aushort = (U16)SvUV(fromstr);
4708 CAT16(cat, &aushort);
4714 #if SHORTSIZE != SIZE16
4720 ashort = SvIV(fromstr);
4721 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4729 ashort = (I16)SvIV(fromstr);
4730 CAT16(cat, &ashort);
4737 auint = SvUV(fromstr);
4738 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4744 adouble = Perl_floor(SvNV(fromstr));
4747 DIE(aTHX_ "Cannot compress negative numbers");
4753 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4754 adouble <= UV_MAX_cxux
4761 char buf[1 + sizeof(UV)];
4762 char *in = buf + sizeof(buf);
4763 UV auv = U_V(adouble);
4766 *--in = (auv & 0x7f) | 0x80;
4769 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4770 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4772 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4773 char *from, *result, *in;
4778 /* Copy string and check for compliance */
4779 from = SvPV(fromstr, len);
4780 if ((norm = is_an_int(from, len)) == NULL)
4781 DIE(aTHX_ "can compress only unsigned integer");
4783 New('w', result, len, char);
4787 *--in = div128(norm, &done) | 0x80;
4788 result[len - 1] &= 0x7F; /* clear continue bit */
4789 sv_catpvn(cat, in, (result + len) - in);
4791 SvREFCNT_dec(norm); /* free norm */
4793 else if (SvNOKp(fromstr)) {
4794 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4795 char *in = buf + sizeof(buf);
4798 double next = floor(adouble / 128);
4799 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4800 if (--in < buf) /* this cannot happen ;-) */
4801 DIE(aTHX_ "Cannot compress integer");
4803 } while (adouble > 0);
4804 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4805 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4808 DIE(aTHX_ "Cannot compress non integer");
4814 aint = SvIV(fromstr);
4815 sv_catpvn(cat, (char*)&aint, sizeof(int));
4821 aulong = SvUV(fromstr);
4823 aulong = PerlSock_htonl(aulong);
4825 CAT32(cat, &aulong);
4831 aulong = SvUV(fromstr);
4833 aulong = htovl(aulong);
4835 CAT32(cat, &aulong);
4839 #if LONGSIZE != SIZE32
4841 unsigned long aulong;
4845 aulong = SvUV(fromstr);
4846 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4854 aulong = SvUV(fromstr);
4855 CAT32(cat, &aulong);
4860 #if LONGSIZE != SIZE32
4866 along = SvIV(fromstr);
4867 sv_catpvn(cat, (char *)&along, sizeof(long));
4875 along = SvIV(fromstr);
4884 auquad = (Uquad_t)SvUV(fromstr);
4885 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4891 aquad = (Quad_t)SvIV(fromstr);
4892 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4897 len = 1; /* assume SV is correct length */
4902 if (fromstr == &PL_sv_undef)
4906 /* XXX better yet, could spirit away the string to
4907 * a safe spot and hang on to it until the result
4908 * of pack() (and all copies of the result) are
4911 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr)
4912 || (SvPADTMP(fromstr)
4913 && !SvREADONLY(fromstr))))
4915 Perl_warner(aTHX_ WARN_UNSAFE,
4916 "Attempt to pack pointer to temporary value");
4918 if (SvPOK(fromstr) || SvNIOK(fromstr))
4919 aptr = SvPV(fromstr,n_a);
4921 aptr = SvPV_force(fromstr,n_a);
4923 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4928 aptr = SvPV(fromstr, fromlen);
4929 SvGROW(cat, fromlen * 4 / 3);
4934 while (fromlen > 0) {
4941 doencodes(cat, aptr, todo);
4960 register I32 limit = POPi; /* note, negative is forever */
4963 register char *s = SvPV(sv, len);
4964 char *strend = s + len;
4966 register REGEXP *rx;
4970 I32 maxiters = (strend - s) + 10;
4973 I32 origlimit = limit;
4976 AV *oldstack = PL_curstack;
4977 I32 gimme = GIMME_V;
4978 I32 oldsave = PL_savestack_ix;
4979 I32 make_mortal = 1;
4980 MAGIC *mg = (MAGIC *) NULL;
4983 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4988 DIE(aTHX_ "panic: do_split");
4989 rx = pm->op_pmregexp;
4991 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4992 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4994 if (pm->op_pmreplroot) {
4996 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4998 ary = GvAVn((GV*)pm->op_pmreplroot);
5001 else if (gimme != G_ARRAY)
5003 ary = (AV*)PL_curpad[0];
5005 ary = GvAVn(PL_defgv);
5006 #endif /* USE_THREADS */
5009 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5015 if (mg = SvTIED_mg((SV*)ary, 'P')) {
5017 XPUSHs(SvTIED_obj((SV*)ary, mg));
5023 for (i = AvFILLp(ary); i >= 0; i--)
5024 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5026 /* temporarily switch stacks */
5027 SWITCHSTACK(PL_curstack, ary);
5031 base = SP - PL_stack_base;
5033 if (pm->op_pmflags & PMf_SKIPWHITE) {
5034 if (pm->op_pmflags & PMf_LOCALE) {
5035 while (isSPACE_LC(*s))
5043 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5044 SAVEINT(PL_multiline);
5045 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5049 limit = maxiters + 2;
5050 if (pm->op_pmflags & PMf_WHITE) {
5053 while (m < strend &&
5054 !((pm->op_pmflags & PMf_LOCALE)
5055 ? isSPACE_LC(*m) : isSPACE(*m)))
5060 dstr = NEWSV(30, m-s);
5061 sv_setpvn(dstr, s, m-s);
5067 while (s < strend &&
5068 ((pm->op_pmflags & PMf_LOCALE)
5069 ? isSPACE_LC(*s) : isSPACE(*s)))
5073 else if (strEQ("^", rx->precomp)) {
5076 for (m = s; m < strend && *m != '\n'; m++) ;
5080 dstr = NEWSV(30, m-s);
5081 sv_setpvn(dstr, s, m-s);
5088 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5089 && (rx->reganch & ROPT_CHECK_ALL)
5090 && !(rx->reganch & ROPT_ANCH)) {
5091 int tail = (rx->reganch & RE_INTUIT_TAIL);
5092 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5096 if (len == 1 && !tail) {
5100 for (m = s; m < strend && *m != c; m++) ;
5103 dstr = NEWSV(30, m-s);
5104 sv_setpvn(dstr, s, m-s);
5113 while (s < strend && --limit &&
5114 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5115 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5118 dstr = NEWSV(31, m-s);
5119 sv_setpvn(dstr, s, m-s);
5123 s = m + len; /* Fake \n at the end */
5128 maxiters += (strend - s) * rx->nparens;
5129 while (s < strend && --limit
5130 /* && (!rx->check_substr
5131 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5133 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5134 1 /* minend */, sv, NULL, 0))
5136 TAINT_IF(RX_MATCH_TAINTED(rx));
5137 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5142 strend = s + (strend - m);
5144 m = rx->startp[0] + orig;
5145 dstr = NEWSV(32, m-s);
5146 sv_setpvn(dstr, s, m-s);
5151 for (i = 1; i <= rx->nparens; i++) {
5152 s = rx->startp[i] + orig;
5153 m = rx->endp[i] + orig;
5155 dstr = NEWSV(33, m-s);
5156 sv_setpvn(dstr, s, m-s);
5159 dstr = NEWSV(33, 0);
5165 s = rx->endp[0] + orig;
5169 LEAVE_SCOPE(oldsave);
5170 iters = (SP - PL_stack_base) - base;
5171 if (iters > maxiters)
5172 DIE(aTHX_ "Split loop");
5174 /* keep field after final delim? */
5175 if (s < strend || (iters && origlimit)) {
5176 dstr = NEWSV(34, strend-s);
5177 sv_setpvn(dstr, s, strend-s);
5183 else if (!origlimit) {
5184 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5190 SWITCHSTACK(ary, oldstack);
5191 if (SvSMAGICAL(ary)) {
5196 if (gimme == G_ARRAY) {
5198 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5206 call_method("PUSH",G_SCALAR|G_DISCARD);
5209 if (gimme == G_ARRAY) {
5210 /* EXTEND should not be needed - we just popped them */
5212 for (i=0; i < iters; i++) {
5213 SV **svp = av_fetch(ary, i, FALSE);
5214 PUSHs((svp) ? *svp : &PL_sv_undef);
5221 if (gimme == G_ARRAY)
5224 if (iters || !pm->op_pmreplroot) {
5234 Perl_unlock_condpair(pTHX_ void *svv)
5237 MAGIC *mg = mg_find((SV*)svv, 'm');
5240 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5241 MUTEX_LOCK(MgMUTEXP(mg));
5242 if (MgOWNER(mg) != thr)
5243 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5245 COND_SIGNAL(MgOWNERCONDP(mg));
5246 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5247 PTR2UV(thr), PTR2UV(svv));)
5248 MUTEX_UNLOCK(MgMUTEXP(mg));
5250 #endif /* USE_THREADS */
5263 mg = condpair_magic(sv);
5264 MUTEX_LOCK(MgMUTEXP(mg));
5265 if (MgOWNER(mg) == thr)
5266 MUTEX_UNLOCK(MgMUTEXP(mg));
5269 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5271 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5272 PTR2UV(thr), PTR2UV(sv));)
5273 MUTEX_UNLOCK(MgMUTEXP(mg));
5274 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5276 #endif /* USE_THREADS */
5277 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5278 || SvTYPE(retsv) == SVt_PVCV) {
5279 retsv = refto(retsv);
5290 if (PL_op->op_private & OPpLVAL_INTRO)
5291 PUSHs(*save_threadsv(PL_op->op_targ));
5293 PUSHs(THREADSV(PL_op->op_targ));
5296 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5297 #endif /* USE_THREADS */