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) {
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 (IN_UTF8 && *(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);
1935 SETi( sv_len_utf8(TOPs) );
1939 SETi( sv_len(TOPs) );
1953 I32 lvalue = PL_op->op_flags & OPf_MOD;
1955 I32 arybase = PL_curcop->cop_arybase;
1959 SvTAINTED_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);
2023 sv_setpvn(TARG, tmps, rem);
2025 sv_insert(sv, pos, rem, repl, repl_len);
2026 else if (lvalue) { /* it's an lvalue! */
2027 if (!SvGMAGICAL(sv)) {
2031 if (ckWARN(WARN_SUBSTR))
2032 Perl_warner(aTHX_ WARN_SUBSTR,
2033 "Attempt to use reference as lvalue in substr");
2035 if (SvOK(sv)) /* is it defined ? */
2036 (void)SvPOK_only(sv);
2038 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2041 if (SvTYPE(TARG) < SVt_PVLV) {
2042 sv_upgrade(TARG, SVt_PVLV);
2043 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2047 if (LvTARG(TARG) != sv) {
2049 SvREFCNT_dec(LvTARG(TARG));
2050 LvTARG(TARG) = SvREFCNT_inc(sv);
2052 LvTARGOFF(TARG) = pos;
2053 LvTARGLEN(TARG) = rem;
2057 PUSHs(TARG); /* avoid SvSETMAGIC here */
2064 register I32 size = POPi;
2065 register I32 offset = POPi;
2066 register SV *src = POPs;
2067 I32 lvalue = PL_op->op_flags & OPf_MOD;
2069 SvTAINTED_off(TARG); /* decontaminate */
2070 if (lvalue) { /* it's an lvalue! */
2071 if (SvTYPE(TARG) < SVt_PVLV) {
2072 sv_upgrade(TARG, SVt_PVLV);
2073 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2076 if (LvTARG(TARG) != src) {
2078 SvREFCNT_dec(LvTARG(TARG));
2079 LvTARG(TARG) = SvREFCNT_inc(src);
2081 LvTARGOFF(TARG) = offset;
2082 LvTARGLEN(TARG) = size;
2085 sv_setuv(TARG, do_vecget(src, offset, size));
2100 I32 arybase = PL_curcop->cop_arybase;
2105 offset = POPi - arybase;
2108 tmps = SvPV(big, biglen);
2109 if (IN_UTF8 && offset > 0)
2110 sv_pos_u2b(big, &offset, 0);
2113 else if (offset > biglen)
2115 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2116 (unsigned char*)tmps + biglen, little, 0)))
2119 retval = tmps2 - tmps;
2120 if (IN_UTF8 && retval > 0)
2121 sv_pos_b2u(big, &retval);
2122 PUSHi(retval + arybase);
2137 I32 arybase = PL_curcop->cop_arybase;
2143 tmps2 = SvPV(little, llen);
2144 tmps = SvPV(big, blen);
2148 if (IN_UTF8 && offset > 0)
2149 sv_pos_u2b(big, &offset, 0);
2150 offset = offset - arybase + llen;
2154 else if (offset > blen)
2156 if (!(tmps2 = rninstr(tmps, tmps + offset,
2157 tmps2, tmps2 + llen)))
2160 retval = tmps2 - tmps;
2161 if (IN_UTF8 && retval > 0)
2162 sv_pos_b2u(big, &retval);
2163 PUSHi(retval + arybase);
2169 djSP; dMARK; dORIGMARK; dTARGET;
2170 do_sprintf(TARG, SP-MARK, MARK+1);
2171 TAINT_IF(SvTAINTED(TARG));
2182 U8 *tmps = (U8*)POPpx;
2185 if (IN_UTF8 && (*tmps & 0x80))
2186 value = utf8_to_uv(tmps, &retlen);
2188 value = (UV)(*tmps & 255);
2199 (void)SvUPGRADE(TARG,SVt_PV);
2201 if (IN_UTF8 && value >= 128) {
2204 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2205 SvCUR_set(TARG, tmps - SvPVX(TARG));
2207 (void)SvPOK_only(TARG);
2217 (void)SvPOK_only(TARG);
2224 djSP; dTARGET; dPOPTOPssrl;
2227 char *tmps = SvPV(left, n_a);
2229 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2231 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2235 "The crypt() function is unimplemented due to excessive paranoia.");
2248 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2252 UV uv = utf8_to_uv(s, &ulen);
2254 if (PL_op->op_private & OPpLOCALE) {
2257 uv = toTITLE_LC_uni(uv);
2260 uv = toTITLE_utf8(s);
2262 tend = uv_to_utf8(tmpbuf, uv);
2264 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2266 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2267 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2271 s = (U8*)SvPV_force(sv, slen);
2272 Copy(tmpbuf, s, ulen, U8);
2276 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2282 s = (U8*)SvPV_force(sv, slen);
2284 if (PL_op->op_private & OPpLOCALE) {
2287 *s = toUPPER_LC(*s);
2305 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2309 UV uv = utf8_to_uv(s, &ulen);
2311 if (PL_op->op_private & OPpLOCALE) {
2314 uv = toLOWER_LC_uni(uv);
2317 uv = toLOWER_utf8(s);
2319 tend = uv_to_utf8(tmpbuf, uv);
2321 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2323 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2324 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2328 s = (U8*)SvPV_force(sv, slen);
2329 Copy(tmpbuf, s, ulen, U8);
2333 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2339 s = (U8*)SvPV_force(sv, slen);
2341 if (PL_op->op_private & OPpLOCALE) {
2344 *s = toLOWER_LC(*s);
2369 s = (U8*)SvPV(sv,len);
2371 sv_setpvn(TARG, "", 0);
2375 (void)SvUPGRADE(TARG, SVt_PV);
2376 SvGROW(TARG, (len * 2) + 1);
2377 (void)SvPOK_only(TARG);
2378 d = (U8*)SvPVX(TARG);
2380 if (PL_op->op_private & OPpLOCALE) {
2384 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2390 d = uv_to_utf8(d, toUPPER_utf8( s ));
2395 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2400 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2406 s = (U8*)SvPV_force(sv, len);
2408 register U8 *send = s + len;
2410 if (PL_op->op_private & OPpLOCALE) {
2413 for (; s < send; s++)
2414 *s = toUPPER_LC(*s);
2417 for (; s < send; s++)
2440 s = (U8*)SvPV(sv,len);
2442 sv_setpvn(TARG, "", 0);
2446 (void)SvUPGRADE(TARG, SVt_PV);
2447 SvGROW(TARG, (len * 2) + 1);
2448 (void)SvPOK_only(TARG);
2449 d = (U8*)SvPVX(TARG);
2451 if (PL_op->op_private & OPpLOCALE) {
2455 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2461 d = uv_to_utf8(d, toLOWER_utf8(s));
2466 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2471 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2478 s = (U8*)SvPV_force(sv, len);
2480 register U8 *send = s + len;
2482 if (PL_op->op_private & OPpLOCALE) {
2485 for (; s < send; s++)
2486 *s = toLOWER_LC(*s);
2489 for (; s < send; s++)
2504 register char *s = SvPV(sv,len);
2508 (void)SvUPGRADE(TARG, SVt_PV);
2509 SvGROW(TARG, (len * 2) + 1);
2514 STRLEN ulen = UTF8SKIP(s);
2537 SvCUR_set(TARG, d - SvPVX(TARG));
2538 (void)SvPOK_only(TARG);
2541 sv_setpvn(TARG, s, len);
2543 if (SvSMAGICAL(TARG))
2552 djSP; dMARK; dORIGMARK;
2554 register AV* av = (AV*)POPs;
2555 register I32 lval = PL_op->op_flags & OPf_MOD;
2556 I32 arybase = PL_curcop->cop_arybase;
2559 if (SvTYPE(av) == SVt_PVAV) {
2560 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2562 for (svp = MARK + 1; svp <= SP; svp++) {
2567 if (max > AvMAX(av))
2570 while (++MARK <= SP) {
2571 elem = SvIVx(*MARK);
2575 svp = av_fetch(av, elem, lval);
2577 if (!svp || *svp == &PL_sv_undef)
2578 DIE(aTHX_ PL_no_aelem, elem);
2579 if (PL_op->op_private & OPpLVAL_INTRO)
2580 save_aelem(av, elem, svp);
2582 *MARK = svp ? *svp : &PL_sv_undef;
2585 if (GIMME != G_ARRAY) {
2593 /* Associative arrays. */
2598 HV *hash = (HV*)POPs;
2600 I32 gimme = GIMME_V;
2601 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2604 /* might clobber stack_sp */
2605 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2610 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2611 if (gimme == G_ARRAY) {
2614 /* might clobber stack_sp */
2616 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2621 else if (gimme == G_SCALAR)
2640 I32 gimme = GIMME_V;
2641 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2645 if (PL_op->op_private & OPpSLICE) {
2649 hvtype = SvTYPE(hv);
2650 if (hvtype == SVt_PVHV) { /* hash element */
2651 while (++MARK <= SP) {
2652 sv = hv_delete_ent(hv, *MARK, discard, 0);
2653 *MARK = sv ? sv : &PL_sv_undef;
2656 else if (hvtype == SVt_PVAV) {
2657 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2658 while (++MARK <= SP) {
2659 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2660 *MARK = sv ? sv : &PL_sv_undef;
2663 else { /* pseudo-hash element */
2664 while (++MARK <= SP) {
2665 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2666 *MARK = sv ? sv : &PL_sv_undef;
2671 DIE(aTHX_ "Not a HASH reference");
2674 else if (gimme == G_SCALAR) {
2683 if (SvTYPE(hv) == SVt_PVHV)
2684 sv = hv_delete_ent(hv, keysv, discard, 0);
2685 else if (SvTYPE(hv) == SVt_PVAV) {
2686 if (PL_op->op_flags & OPf_SPECIAL)
2687 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2689 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2692 DIE(aTHX_ "Not a HASH reference");
2707 if (PL_op->op_private & OPpEXISTS_SUB) {
2711 cv = sv_2cv(sv, &hv, &gv, FALSE);
2714 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2720 if (SvTYPE(hv) == SVt_PVHV) {
2721 if (hv_exists_ent(hv, tmpsv, 0))
2724 else if (SvTYPE(hv) == SVt_PVAV) {
2725 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2726 if (av_exists((AV*)hv, SvIV(tmpsv)))
2729 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2733 DIE(aTHX_ "Not a HASH reference");
2740 djSP; dMARK; dORIGMARK;
2741 register HV *hv = (HV*)POPs;
2742 register I32 lval = PL_op->op_flags & OPf_MOD;
2743 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2745 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2746 DIE(aTHX_ "Can't localize pseudo-hash element");
2748 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2749 while (++MARK <= SP) {
2753 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2754 svp = he ? &HeVAL(he) : 0;
2757 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2760 if (!svp || *svp == &PL_sv_undef) {
2762 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2764 if (PL_op->op_private & OPpLVAL_INTRO)
2765 save_helem(hv, keysv, svp);
2767 *MARK = svp ? *svp : &PL_sv_undef;
2770 if (GIMME != G_ARRAY) {
2778 /* List operators. */
2783 if (GIMME != G_ARRAY) {
2785 *MARK = *SP; /* unwanted list, return last item */
2787 *MARK = &PL_sv_undef;
2796 SV **lastrelem = PL_stack_sp;
2797 SV **lastlelem = PL_stack_base + POPMARK;
2798 SV **firstlelem = PL_stack_base + POPMARK + 1;
2799 register SV **firstrelem = lastlelem + 1;
2800 I32 arybase = PL_curcop->cop_arybase;
2801 I32 lval = PL_op->op_flags & OPf_MOD;
2802 I32 is_something_there = lval;
2804 register I32 max = lastrelem - lastlelem;
2805 register SV **lelem;
2808 if (GIMME != G_ARRAY) {
2809 ix = SvIVx(*lastlelem);
2814 if (ix < 0 || ix >= max)
2815 *firstlelem = &PL_sv_undef;
2817 *firstlelem = firstrelem[ix];
2823 SP = firstlelem - 1;
2827 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2833 if (ix < 0 || ix >= max)
2834 *lelem = &PL_sv_undef;
2836 is_something_there = TRUE;
2837 if (!(*lelem = firstrelem[ix]))
2838 *lelem = &PL_sv_undef;
2841 if (is_something_there)
2844 SP = firstlelem - 1;
2850 djSP; dMARK; dORIGMARK;
2851 I32 items = SP - MARK;
2852 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2853 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2860 djSP; dMARK; dORIGMARK;
2861 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2865 SV *val = NEWSV(46, 0);
2867 sv_setsv(val, *++MARK);
2868 else if (ckWARN(WARN_UNSAFE))
2869 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2870 (void)hv_store_ent(hv,key,val,0);
2879 djSP; dMARK; dORIGMARK;
2880 register AV *ary = (AV*)*++MARK;
2884 register I32 offset;
2885 register I32 length;
2892 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2893 *MARK-- = SvTIED_obj((SV*)ary, mg);
2897 call_method("SPLICE",GIMME_V);
2906 offset = i = SvIVx(*MARK);
2908 offset += AvFILLp(ary) + 1;
2910 offset -= PL_curcop->cop_arybase;
2912 DIE(aTHX_ PL_no_aelem, i);
2914 length = SvIVx(*MARK++);
2916 length += AvFILLp(ary) - offset + 1;
2922 length = AvMAX(ary) + 1; /* close enough to infinity */
2926 length = AvMAX(ary) + 1;
2928 if (offset > AvFILLp(ary) + 1)
2929 offset = AvFILLp(ary) + 1;
2930 after = AvFILLp(ary) + 1 - (offset + length);
2931 if (after < 0) { /* not that much array */
2932 length += after; /* offset+length now in array */
2938 /* At this point, MARK .. SP-1 is our new LIST */
2941 diff = newlen - length;
2942 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2945 if (diff < 0) { /* shrinking the area */
2947 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2948 Copy(MARK, tmparyval, newlen, SV*);
2951 MARK = ORIGMARK + 1;
2952 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2953 MEXTEND(MARK, length);
2954 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2956 EXTEND_MORTAL(length);
2957 for (i = length, dst = MARK; i; i--) {
2958 sv_2mortal(*dst); /* free them eventualy */
2965 *MARK = AvARRAY(ary)[offset+length-1];
2968 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2969 SvREFCNT_dec(*dst++); /* free them now */
2972 AvFILLp(ary) += diff;
2974 /* pull up or down? */
2976 if (offset < after) { /* easier to pull up */
2977 if (offset) { /* esp. if nothing to pull */
2978 src = &AvARRAY(ary)[offset-1];
2979 dst = src - diff; /* diff is negative */
2980 for (i = offset; i > 0; i--) /* can't trust Copy */
2984 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2988 if (after) { /* anything to pull down? */
2989 src = AvARRAY(ary) + offset + length;
2990 dst = src + diff; /* diff is negative */
2991 Move(src, dst, after, SV*);
2993 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2994 /* avoid later double free */
2998 dst[--i] = &PL_sv_undef;
3001 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3003 *dst = NEWSV(46, 0);
3004 sv_setsv(*dst++, *src++);
3006 Safefree(tmparyval);
3009 else { /* no, expanding (or same) */
3011 New(452, tmparyval, length, SV*); /* so remember deletion */
3012 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3015 if (diff > 0) { /* expanding */
3017 /* push up or down? */
3019 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3023 Move(src, dst, offset, SV*);
3025 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3027 AvFILLp(ary) += diff;
3030 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3031 av_extend(ary, AvFILLp(ary) + diff);
3032 AvFILLp(ary) += diff;
3035 dst = AvARRAY(ary) + AvFILLp(ary);
3037 for (i = after; i; i--) {
3044 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3045 *dst = NEWSV(46, 0);
3046 sv_setsv(*dst++, *src++);
3048 MARK = ORIGMARK + 1;
3049 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3051 Copy(tmparyval, MARK, length, SV*);
3053 EXTEND_MORTAL(length);
3054 for (i = length, dst = MARK; i; i--) {
3055 sv_2mortal(*dst); /* free them eventualy */
3059 Safefree(tmparyval);
3063 else if (length--) {
3064 *MARK = tmparyval[length];
3067 while (length-- > 0)
3068 SvREFCNT_dec(tmparyval[length]);
3070 Safefree(tmparyval);
3073 *MARK = &PL_sv_undef;
3081 djSP; dMARK; dORIGMARK; dTARGET;
3082 register AV *ary = (AV*)*++MARK;
3083 register SV *sv = &PL_sv_undef;
3086 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3087 *MARK-- = SvTIED_obj((SV*)ary, mg);
3091 call_method("PUSH",G_SCALAR|G_DISCARD);
3096 /* Why no pre-extend of ary here ? */
3097 for (++MARK; MARK <= SP; MARK++) {
3100 sv_setsv(sv, *MARK);
3105 PUSHi( AvFILL(ary) + 1 );
3113 SV *sv = av_pop(av);
3115 (void)sv_2mortal(sv);
3124 SV *sv = av_shift(av);
3129 (void)sv_2mortal(sv);
3136 djSP; dMARK; dORIGMARK; dTARGET;
3137 register AV *ary = (AV*)*++MARK;
3142 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3143 *MARK-- = SvTIED_obj((SV*)ary, mg);
3147 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3152 av_unshift(ary, SP - MARK);
3155 sv_setsv(sv, *++MARK);
3156 (void)av_store(ary, i++, sv);
3160 PUSHi( AvFILL(ary) + 1 );
3170 if (GIMME == G_ARRAY) {
3177 /* safe as long as stack cannot get extended in the above */
3182 register char *down;
3188 do_join(TARG, &PL_sv_no, MARK, SP);
3190 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3191 up = SvPV_force(TARG, len);
3193 if (IN_UTF8) { /* first reverse each character */
3194 U8* s = (U8*)SvPVX(TARG);
3195 U8* send = (U8*)(s + len);
3204 down = (char*)(s - 1);
3205 if (s > send || !((*down & 0xc0) == 0x80)) {
3206 if (ckWARN_d(WARN_UTF8))
3207 Perl_warner(aTHX_ WARN_UTF8,
3208 "Malformed UTF-8 character");
3220 down = SvPVX(TARG) + len - 1;
3226 (void)SvPOK_only(TARG);
3235 S_mul128(pTHX_ SV *sv, U8 m)
3238 char *s = SvPV(sv, len);
3242 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3243 SV *tmpNew = newSVpvn("0000000000", 10);
3245 sv_catsv(tmpNew, sv);
3246 SvREFCNT_dec(sv); /* free old sv */
3251 while (!*t) /* trailing '\0'? */
3254 i = ((*t - '0') << 7) + m;
3255 *(t--) = '0' + (i % 10);
3261 /* Explosives and implosives. */
3263 #if 'I' == 73 && 'J' == 74
3264 /* On an ASCII/ISO kind of system */
3265 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3268 Some other sort of character set - use memchr() so we don't match
3271 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3278 I32 start_sp_offset = SP - PL_stack_base;
3279 I32 gimme = GIMME_V;
3283 register char *pat = SvPV(left, llen);
3284 register char *s = SvPV(right, rlen);
3285 char *strend = s + rlen;
3287 register char *patend = pat + llen;
3293 /* These must not be in registers: */
3310 register U32 culong;
3314 #ifdef PERL_NATINT_PACK
3315 int natint; /* native integer */
3316 int unatint; /* unsigned native integer */
3319 if (gimme != G_ARRAY) { /* arrange to do first one only */
3321 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3322 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3324 while (isDIGIT(*patend) || *patend == '*')
3330 while (pat < patend) {
3332 datumtype = *pat++ & 0xFF;
3333 #ifdef PERL_NATINT_PACK
3336 if (isSPACE(datumtype))
3338 if (datumtype == '#') {
3339 while (pat < patend && *pat != '\n')
3344 char *natstr = "sSiIlL";
3346 if (strchr(natstr, datumtype)) {
3347 #ifdef PERL_NATINT_PACK
3353 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3358 else if (*pat == '*') {
3359 len = strend - strbeg; /* long enough */
3363 else if (isDIGIT(*pat)) {
3365 while (isDIGIT(*pat)) {
3366 len = (len * 10) + (*pat++ - '0');
3368 DIE(aTHX_ "Repeat count in unpack overflows");
3372 len = (datumtype != '@');
3376 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3377 case ',': /* grandfather in commas but with a warning */
3378 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3379 Perl_warner(aTHX_ WARN_UNSAFE,
3380 "Invalid type in unpack: '%c'", (int)datumtype);
3383 if (len == 1 && pat[-1] != '1')
3392 if (len > strend - strbeg)
3393 DIE(aTHX_ "@ outside of string");
3397 if (len > s - strbeg)
3398 DIE(aTHX_ "X outside of string");
3402 if (len > strend - s)
3403 DIE(aTHX_ "x outside of string");
3407 if (start_sp_offset >= SP - PL_stack_base)
3408 DIE(aTHX_ "/ must follow a numeric type");
3411 pat++; /* ignore '*' for compatibility with pack */
3413 DIE(aTHX_ "/ cannot take a count" );
3420 if (len > strend - s)
3423 goto uchar_checksum;
3424 sv = NEWSV(35, len);
3425 sv_setpvn(sv, s, len);
3427 if (datumtype == 'A' || datumtype == 'Z') {
3428 aptr = s; /* borrow register */
3429 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3434 else { /* 'A' strips both nulls and spaces */
3435 s = SvPVX(sv) + len - 1;
3436 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3440 SvCUR_set(sv, s - SvPVX(sv));
3441 s = aptr; /* unborrow register */
3443 XPUSHs(sv_2mortal(sv));
3447 if (star || len > (strend - s) * 8)
3448 len = (strend - s) * 8;
3451 Newz(601, PL_bitcount, 256, char);
3452 for (bits = 1; bits < 256; bits++) {
3453 if (bits & 1) PL_bitcount[bits]++;
3454 if (bits & 2) PL_bitcount[bits]++;
3455 if (bits & 4) PL_bitcount[bits]++;
3456 if (bits & 8) PL_bitcount[bits]++;
3457 if (bits & 16) PL_bitcount[bits]++;
3458 if (bits & 32) PL_bitcount[bits]++;
3459 if (bits & 64) PL_bitcount[bits]++;
3460 if (bits & 128) PL_bitcount[bits]++;
3464 culong += PL_bitcount[*(unsigned char*)s++];
3469 if (datumtype == 'b') {
3471 if (bits & 1) culong++;
3477 if (bits & 128) culong++;
3484 sv = NEWSV(35, len + 1);
3488 if (datumtype == 'b') {
3490 for (len = 0; len < aint; len++) {
3491 if (len & 7) /*SUPPRESS 595*/
3495 *str++ = '0' + (bits & 1);
3500 for (len = 0; len < aint; len++) {
3505 *str++ = '0' + ((bits & 128) != 0);
3509 XPUSHs(sv_2mortal(sv));
3513 if (star || len > (strend - s) * 2)
3514 len = (strend - s) * 2;
3515 sv = NEWSV(35, len + 1);
3519 if (datumtype == 'h') {
3521 for (len = 0; len < aint; len++) {
3526 *str++ = PL_hexdigit[bits & 15];
3531 for (len = 0; len < aint; len++) {
3536 *str++ = PL_hexdigit[(bits >> 4) & 15];
3540 XPUSHs(sv_2mortal(sv));
3543 if (len > strend - s)
3548 if (aint >= 128) /* fake up signed chars */
3558 if (aint >= 128) /* fake up signed chars */
3561 sv_setiv(sv, (IV)aint);
3562 PUSHs(sv_2mortal(sv));
3567 if (len > strend - s)
3582 sv_setiv(sv, (IV)auint);
3583 PUSHs(sv_2mortal(sv));
3588 if (len > strend - s)
3591 while (len-- > 0 && s < strend) {
3592 auint = utf8_to_uv((U8*)s, &along);
3595 cdouble += (NV)auint;
3603 while (len-- > 0 && s < strend) {
3604 auint = utf8_to_uv((U8*)s, &along);
3607 sv_setuv(sv, (UV)auint);
3608 PUSHs(sv_2mortal(sv));
3613 #if SHORTSIZE == SIZE16
3614 along = (strend - s) / SIZE16;
3616 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3621 #if SHORTSIZE != SIZE16
3625 COPYNN(s, &ashort, sizeof(short));
3636 #if SHORTSIZE > SIZE16
3648 #if SHORTSIZE != SIZE16
3652 COPYNN(s, &ashort, sizeof(short));
3655 sv_setiv(sv, (IV)ashort);
3656 PUSHs(sv_2mortal(sv));
3664 #if SHORTSIZE > SIZE16
3670 sv_setiv(sv, (IV)ashort);
3671 PUSHs(sv_2mortal(sv));
3679 #if SHORTSIZE == SIZE16
3680 along = (strend - s) / SIZE16;
3682 unatint = natint && datumtype == 'S';
3683 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3688 #if SHORTSIZE != SIZE16
3690 unsigned short aushort;
3692 COPYNN(s, &aushort, sizeof(unsigned short));
3693 s += sizeof(unsigned short);
3701 COPY16(s, &aushort);
3704 if (datumtype == 'n')
3705 aushort = PerlSock_ntohs(aushort);
3708 if (datumtype == 'v')
3709 aushort = vtohs(aushort);
3718 #if SHORTSIZE != SIZE16
3720 unsigned short aushort;
3722 COPYNN(s, &aushort, sizeof(unsigned short));
3723 s += sizeof(unsigned short);
3725 sv_setiv(sv, (UV)aushort);
3726 PUSHs(sv_2mortal(sv));
3733 COPY16(s, &aushort);
3737 if (datumtype == 'n')
3738 aushort = PerlSock_ntohs(aushort);
3741 if (datumtype == 'v')
3742 aushort = vtohs(aushort);
3744 sv_setiv(sv, (UV)aushort);
3745 PUSHs(sv_2mortal(sv));
3751 along = (strend - s) / sizeof(int);
3756 Copy(s, &aint, 1, int);
3759 cdouble += (NV)aint;
3768 Copy(s, &aint, 1, int);
3772 /* Without the dummy below unpack("i", pack("i",-1))
3773 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3774 * cc with optimization turned on.
3776 * The bug was detected in
3777 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3778 * with optimization (-O4) turned on.
3779 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3780 * does not have this problem even with -O4.
3782 * This bug was reported as DECC_BUGS 1431
3783 * and tracked internally as GEM_BUGS 7775.
3785 * The bug is fixed in
3786 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3787 * UNIX V4.0F support: DEC C V5.9-006 or later
3788 * UNIX V4.0E support: DEC C V5.8-011 or later
3791 * See also few lines later for the same bug.
3794 sv_setiv(sv, (IV)aint) :
3796 sv_setiv(sv, (IV)aint);
3797 PUSHs(sv_2mortal(sv));
3802 along = (strend - s) / sizeof(unsigned int);
3807 Copy(s, &auint, 1, unsigned int);
3808 s += sizeof(unsigned int);
3810 cdouble += (NV)auint;
3819 Copy(s, &auint, 1, unsigned int);
3820 s += sizeof(unsigned int);
3823 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3824 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3825 * See details few lines earlier. */
3827 sv_setuv(sv, (UV)auint) :
3829 sv_setuv(sv, (UV)auint);
3830 PUSHs(sv_2mortal(sv));
3835 #if LONGSIZE == SIZE32
3836 along = (strend - s) / SIZE32;
3838 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3843 #if LONGSIZE != SIZE32
3847 COPYNN(s, &along, sizeof(long));
3850 cdouble += (NV)along;
3860 #if LONGSIZE > SIZE32
3861 if (along > 2147483647)
3862 along -= 4294967296;
3866 cdouble += (NV)along;
3875 #if LONGSIZE != SIZE32
3879 COPYNN(s, &along, sizeof(long));
3882 sv_setiv(sv, (IV)along);
3883 PUSHs(sv_2mortal(sv));
3891 #if LONGSIZE > SIZE32
3892 if (along > 2147483647)
3893 along -= 4294967296;
3897 sv_setiv(sv, (IV)along);
3898 PUSHs(sv_2mortal(sv));
3906 #if LONGSIZE == SIZE32
3907 along = (strend - s) / SIZE32;
3909 unatint = natint && datumtype == 'L';
3910 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3915 #if LONGSIZE != SIZE32
3917 unsigned long aulong;
3919 COPYNN(s, &aulong, sizeof(unsigned long));
3920 s += sizeof(unsigned long);
3922 cdouble += (NV)aulong;
3934 if (datumtype == 'N')
3935 aulong = PerlSock_ntohl(aulong);
3938 if (datumtype == 'V')
3939 aulong = vtohl(aulong);
3942 cdouble += (NV)aulong;
3951 #if LONGSIZE != SIZE32
3953 unsigned long aulong;
3955 COPYNN(s, &aulong, sizeof(unsigned long));
3956 s += sizeof(unsigned long);
3958 sv_setuv(sv, (UV)aulong);
3959 PUSHs(sv_2mortal(sv));
3969 if (datumtype == 'N')
3970 aulong = PerlSock_ntohl(aulong);
3973 if (datumtype == 'V')
3974 aulong = vtohl(aulong);
3977 sv_setuv(sv, (UV)aulong);
3978 PUSHs(sv_2mortal(sv));
3984 along = (strend - s) / sizeof(char*);
3990 if (sizeof(char*) > strend - s)
3993 Copy(s, &aptr, 1, char*);
3999 PUSHs(sv_2mortal(sv));
4009 while ((len > 0) && (s < strend)) {
4010 auv = (auv << 7) | (*s & 0x7f);
4011 if (!(*s++ & 0x80)) {
4015 PUSHs(sv_2mortal(sv));
4019 else if (++bytes >= sizeof(UV)) { /* promote to string */
4023 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
4024 while (s < strend) {
4025 sv = mul128(sv, *s & 0x7f);
4026 if (!(*s++ & 0x80)) {
4035 PUSHs(sv_2mortal(sv));
4040 if ((s >= strend) && bytes)
4041 DIE(aTHX_ "Unterminated compressed integer");
4046 if (sizeof(char*) > strend - s)
4049 Copy(s, &aptr, 1, char*);
4054 sv_setpvn(sv, aptr, len);
4055 PUSHs(sv_2mortal(sv));
4059 along = (strend - s) / sizeof(Quad_t);
4065 if (s + sizeof(Quad_t) > strend)
4068 Copy(s, &aquad, 1, Quad_t);
4069 s += sizeof(Quad_t);
4072 if (aquad >= IV_MIN && aquad <= IV_MAX)
4073 sv_setiv(sv, (IV)aquad);
4075 sv_setnv(sv, (NV)aquad);
4076 PUSHs(sv_2mortal(sv));
4080 along = (strend - s) / sizeof(Quad_t);
4086 if (s + sizeof(Uquad_t) > strend)
4089 Copy(s, &auquad, 1, Uquad_t);
4090 s += sizeof(Uquad_t);
4093 if (auquad <= UV_MAX)
4094 sv_setuv(sv, (UV)auquad);
4096 sv_setnv(sv, (NV)auquad);
4097 PUSHs(sv_2mortal(sv));
4101 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4104 along = (strend - s) / sizeof(float);
4109 Copy(s, &afloat, 1, float);
4118 Copy(s, &afloat, 1, float);
4121 sv_setnv(sv, (NV)afloat);
4122 PUSHs(sv_2mortal(sv));
4128 along = (strend - s) / sizeof(double);
4133 Copy(s, &adouble, 1, double);
4134 s += sizeof(double);
4142 Copy(s, &adouble, 1, double);
4143 s += sizeof(double);
4145 sv_setnv(sv, (NV)adouble);
4146 PUSHs(sv_2mortal(sv));
4152 * Initialise the decode mapping. By using a table driven
4153 * algorithm, the code will be character-set independent
4154 * (and just as fast as doing character arithmetic)
4156 if (PL_uudmap['M'] == 0) {
4159 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4160 PL_uudmap[PL_uuemap[i]] = i;
4162 * Because ' ' and '`' map to the same value,
4163 * we need to decode them both the same.
4168 along = (strend - s) * 3 / 4;
4169 sv = NEWSV(42, along);
4172 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4177 len = PL_uudmap[*s++] & 077;
4179 if (s < strend && ISUUCHAR(*s))
4180 a = PL_uudmap[*s++] & 077;
4183 if (s < strend && ISUUCHAR(*s))
4184 b = PL_uudmap[*s++] & 077;
4187 if (s < strend && ISUUCHAR(*s))
4188 c = PL_uudmap[*s++] & 077;
4191 if (s < strend && ISUUCHAR(*s))
4192 d = PL_uudmap[*s++] & 077;
4195 hunk[0] = (a << 2) | (b >> 4);
4196 hunk[1] = (b << 4) | (c >> 2);
4197 hunk[2] = (c << 6) | d;
4198 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4203 else if (s[1] == '\n') /* possible checksum byte */
4206 XPUSHs(sv_2mortal(sv));
4211 if (strchr("fFdD", datumtype) ||
4212 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4216 while (checksum >= 16) {
4220 while (checksum >= 4) {
4226 along = (1 << checksum) - 1;
4227 while (cdouble < 0.0)
4229 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4230 sv_setnv(sv, cdouble);
4233 if (checksum < 32) {
4234 aulong = (1 << checksum) - 1;
4237 sv_setuv(sv, (UV)culong);
4239 XPUSHs(sv_2mortal(sv));
4243 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4244 PUSHs(&PL_sv_undef);
4249 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4253 *hunk = PL_uuemap[len];
4254 sv_catpvn(sv, hunk, 1);
4257 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4258 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4259 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4260 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4261 sv_catpvn(sv, hunk, 4);
4266 char r = (len > 1 ? s[1] : '\0');
4267 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4268 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4269 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4270 hunk[3] = PL_uuemap[0];
4271 sv_catpvn(sv, hunk, 4);
4273 sv_catpvn(sv, "\n", 1);
4277 S_is_an_int(pTHX_ char *s, STRLEN l)
4280 SV *result = newSVpvn(s, l);
4281 char *result_c = SvPV(result, n_a); /* convenience */
4282 char *out = result_c;
4292 SvREFCNT_dec(result);
4315 SvREFCNT_dec(result);
4321 SvCUR_set(result, out - result_c);
4325 /* pnum must be '\0' terminated */
4327 S_div128(pTHX_ SV *pnum, bool *done)
4330 char *s = SvPV(pnum, len);
4339 i = m * 10 + (*t - '0');
4341 r = (i >> 7); /* r < 10 */
4348 SvCUR_set(pnum, (STRLEN) (t - s));
4355 djSP; dMARK; dORIGMARK; dTARGET;
4356 register SV *cat = TARG;
4359 register char *pat = SvPVx(*++MARK, fromlen);
4360 register char *patend = pat + fromlen;
4365 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4366 static char *space10 = " ";
4368 /* These must not be in registers: */
4383 #ifdef PERL_NATINT_PACK
4384 int natint; /* native integer */
4389 sv_setpvn(cat, "", 0);
4390 while (pat < patend) {
4391 SV *lengthcode = Nullsv;
4392 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4393 datumtype = *pat++ & 0xFF;
4394 #ifdef PERL_NATINT_PACK
4397 if (isSPACE(datumtype))
4399 if (datumtype == '#') {
4400 while (pat < patend && *pat != '\n')
4405 char *natstr = "sSiIlL";
4407 if (strchr(natstr, datumtype)) {
4408 #ifdef PERL_NATINT_PACK
4414 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4417 len = strchr("@Xxu", datumtype) ? 0 : items;
4420 else if (isDIGIT(*pat)) {
4422 while (isDIGIT(*pat)) {
4423 len = (len * 10) + (*pat++ - '0');
4425 DIE(aTHX_ "Repeat count in pack overflows");
4432 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4433 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4434 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4435 ? *MARK : &PL_sv_no)));
4439 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4440 case ',': /* grandfather in commas but with a warning */
4441 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4442 Perl_warner(aTHX_ WARN_UNSAFE,
4443 "Invalid type in pack: '%c'", (int)datumtype);
4446 DIE(aTHX_ "%% may only be used in unpack");
4457 if (SvCUR(cat) < len)
4458 DIE(aTHX_ "X outside of string");
4465 sv_catpvn(cat, null10, 10);
4468 sv_catpvn(cat, null10, len);
4474 aptr = SvPV(fromstr, fromlen);
4475 if (pat[-1] == '*') {
4477 if (datumtype == 'Z')
4480 if (fromlen >= len) {
4481 sv_catpvn(cat, aptr, len);
4482 if (datumtype == 'Z')
4483 *(SvEND(cat)-1) = '\0';
4486 sv_catpvn(cat, aptr, fromlen);
4488 if (datumtype == 'A') {
4490 sv_catpvn(cat, space10, 10);
4493 sv_catpvn(cat, space10, len);
4497 sv_catpvn(cat, null10, 10);
4500 sv_catpvn(cat, null10, len);
4512 str = SvPV(fromstr, fromlen);
4516 SvCUR(cat) += (len+7)/8;
4517 SvGROW(cat, SvCUR(cat) + 1);
4518 aptr = SvPVX(cat) + aint;
4523 if (datumtype == 'B') {
4524 for (len = 0; len++ < aint;) {
4525 items |= *str++ & 1;
4529 *aptr++ = items & 0xff;
4535 for (len = 0; len++ < aint;) {
4541 *aptr++ = items & 0xff;
4547 if (datumtype == 'B')
4548 items <<= 7 - (aint & 7);
4550 items >>= 7 - (aint & 7);
4551 *aptr++ = items & 0xff;
4553 str = SvPVX(cat) + SvCUR(cat);
4568 str = SvPV(fromstr, fromlen);
4572 SvCUR(cat) += (len+1)/2;
4573 SvGROW(cat, SvCUR(cat) + 1);
4574 aptr = SvPVX(cat) + aint;
4579 if (datumtype == 'H') {
4580 for (len = 0; len++ < aint;) {
4582 items |= ((*str++ & 15) + 9) & 15;
4584 items |= *str++ & 15;
4588 *aptr++ = items & 0xff;
4594 for (len = 0; len++ < aint;) {
4596 items |= (((*str++ & 15) + 9) & 15) << 4;
4598 items |= (*str++ & 15) << 4;
4602 *aptr++ = items & 0xff;
4608 *aptr++ = items & 0xff;
4609 str = SvPVX(cat) + SvCUR(cat);
4620 aint = SvIV(fromstr);
4622 sv_catpvn(cat, &achar, sizeof(char));
4628 auint = SvUV(fromstr);
4629 SvGROW(cat, SvCUR(cat) + 10);
4630 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4635 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4640 afloat = (float)SvNV(fromstr);
4641 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4648 adouble = (double)SvNV(fromstr);
4649 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4655 ashort = (I16)SvIV(fromstr);
4657 ashort = PerlSock_htons(ashort);
4659 CAT16(cat, &ashort);
4665 ashort = (I16)SvIV(fromstr);
4667 ashort = htovs(ashort);
4669 CAT16(cat, &ashort);
4673 #if SHORTSIZE != SIZE16
4675 unsigned short aushort;
4679 aushort = SvUV(fromstr);
4680 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4690 aushort = (U16)SvUV(fromstr);
4691 CAT16(cat, &aushort);
4697 #if SHORTSIZE != SIZE16
4703 ashort = SvIV(fromstr);
4704 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4712 ashort = (I16)SvIV(fromstr);
4713 CAT16(cat, &ashort);
4720 auint = SvUV(fromstr);
4721 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4727 adouble = Perl_floor(SvNV(fromstr));
4730 DIE(aTHX_ "Cannot compress negative numbers");
4736 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4737 adouble <= UV_MAX_cxux
4744 char buf[1 + sizeof(UV)];
4745 char *in = buf + sizeof(buf);
4746 UV auv = U_V(adouble);
4749 *--in = (auv & 0x7f) | 0x80;
4752 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4753 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4755 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4756 char *from, *result, *in;
4761 /* Copy string and check for compliance */
4762 from = SvPV(fromstr, len);
4763 if ((norm = is_an_int(from, len)) == NULL)
4764 DIE(aTHX_ "can compress only unsigned integer");
4766 New('w', result, len, char);
4770 *--in = div128(norm, &done) | 0x80;
4771 result[len - 1] &= 0x7F; /* clear continue bit */
4772 sv_catpvn(cat, in, (result + len) - in);
4774 SvREFCNT_dec(norm); /* free norm */
4776 else if (SvNOKp(fromstr)) {
4777 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4778 char *in = buf + sizeof(buf);
4781 double next = floor(adouble / 128);
4782 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4783 if (--in < buf) /* this cannot happen ;-) */
4784 DIE(aTHX_ "Cannot compress integer");
4786 } while (adouble > 0);
4787 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4788 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4791 DIE(aTHX_ "Cannot compress non integer");
4797 aint = SvIV(fromstr);
4798 sv_catpvn(cat, (char*)&aint, sizeof(int));
4804 aulong = SvUV(fromstr);
4806 aulong = PerlSock_htonl(aulong);
4808 CAT32(cat, &aulong);
4814 aulong = SvUV(fromstr);
4816 aulong = htovl(aulong);
4818 CAT32(cat, &aulong);
4822 #if LONGSIZE != SIZE32
4824 unsigned long aulong;
4828 aulong = SvUV(fromstr);
4829 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4837 aulong = SvUV(fromstr);
4838 CAT32(cat, &aulong);
4843 #if LONGSIZE != SIZE32
4849 along = SvIV(fromstr);
4850 sv_catpvn(cat, (char *)&along, sizeof(long));
4858 along = SvIV(fromstr);
4867 auquad = (Uquad_t)SvUV(fromstr);
4868 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4874 aquad = (Quad_t)SvIV(fromstr);
4875 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4880 len = 1; /* assume SV is correct length */
4885 if (fromstr == &PL_sv_undef)
4889 /* XXX better yet, could spirit away the string to
4890 * a safe spot and hang on to it until the result
4891 * of pack() (and all copies of the result) are
4894 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr)
4895 || (SvPADTMP(fromstr)
4896 && !SvREADONLY(fromstr))))
4898 Perl_warner(aTHX_ WARN_UNSAFE,
4899 "Attempt to pack pointer to temporary value");
4901 if (SvPOK(fromstr) || SvNIOK(fromstr))
4902 aptr = SvPV(fromstr,n_a);
4904 aptr = SvPV_force(fromstr,n_a);
4906 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4911 aptr = SvPV(fromstr, fromlen);
4912 SvGROW(cat, fromlen * 4 / 3);
4917 while (fromlen > 0) {
4924 doencodes(cat, aptr, todo);
4943 register I32 limit = POPi; /* note, negative is forever */
4946 register char *s = SvPV(sv, len);
4947 char *strend = s + len;
4949 register REGEXP *rx;
4953 I32 maxiters = (strend - s) + 10;
4956 I32 origlimit = limit;
4959 AV *oldstack = PL_curstack;
4960 I32 gimme = GIMME_V;
4961 I32 oldsave = PL_savestack_ix;
4962 I32 make_mortal = 1;
4963 MAGIC *mg = (MAGIC *) NULL;
4966 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4971 DIE(aTHX_ "panic: do_split");
4972 rx = pm->op_pmregexp;
4974 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4975 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4977 if (pm->op_pmreplroot) {
4979 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4981 ary = GvAVn((GV*)pm->op_pmreplroot);
4984 else if (gimme != G_ARRAY)
4986 ary = (AV*)PL_curpad[0];
4988 ary = GvAVn(PL_defgv);
4989 #endif /* USE_THREADS */
4992 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4998 if (mg = SvTIED_mg((SV*)ary, 'P')) {
5000 XPUSHs(SvTIED_obj((SV*)ary, mg));
5006 for (i = AvFILLp(ary); i >= 0; i--)
5007 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5009 /* temporarily switch stacks */
5010 SWITCHSTACK(PL_curstack, ary);
5014 base = SP - PL_stack_base;
5016 if (pm->op_pmflags & PMf_SKIPWHITE) {
5017 if (pm->op_pmflags & PMf_LOCALE) {
5018 while (isSPACE_LC(*s))
5026 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5027 SAVEINT(PL_multiline);
5028 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5032 limit = maxiters + 2;
5033 if (pm->op_pmflags & PMf_WHITE) {
5036 while (m < strend &&
5037 !((pm->op_pmflags & PMf_LOCALE)
5038 ? isSPACE_LC(*m) : isSPACE(*m)))
5043 dstr = NEWSV(30, m-s);
5044 sv_setpvn(dstr, s, m-s);
5050 while (s < strend &&
5051 ((pm->op_pmflags & PMf_LOCALE)
5052 ? isSPACE_LC(*s) : isSPACE(*s)))
5056 else if (strEQ("^", rx->precomp)) {
5059 for (m = s; m < strend && *m != '\n'; m++) ;
5063 dstr = NEWSV(30, m-s);
5064 sv_setpvn(dstr, s, m-s);
5071 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5072 && (rx->reganch & ROPT_CHECK_ALL)
5073 && !(rx->reganch & ROPT_ANCH)) {
5074 int tail = (rx->reganch & RE_INTUIT_TAIL);
5075 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5079 if (len == 1 && !tail) {
5083 for (m = s; m < strend && *m != c; m++) ;
5086 dstr = NEWSV(30, m-s);
5087 sv_setpvn(dstr, s, m-s);
5096 while (s < strend && --limit &&
5097 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5098 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5101 dstr = NEWSV(31, m-s);
5102 sv_setpvn(dstr, s, m-s);
5106 s = m + len; /* Fake \n at the end */
5111 maxiters += (strend - s) * rx->nparens;
5112 while (s < strend && --limit
5113 /* && (!rx->check_substr
5114 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5116 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5117 1 /* minend */, sv, NULL, 0))
5119 TAINT_IF(RX_MATCH_TAINTED(rx));
5120 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5125 strend = s + (strend - m);
5127 m = rx->startp[0] + orig;
5128 dstr = NEWSV(32, m-s);
5129 sv_setpvn(dstr, s, m-s);
5134 for (i = 1; i <= rx->nparens; i++) {
5135 s = rx->startp[i] + orig;
5136 m = rx->endp[i] + orig;
5138 dstr = NEWSV(33, m-s);
5139 sv_setpvn(dstr, s, m-s);
5142 dstr = NEWSV(33, 0);
5148 s = rx->endp[0] + orig;
5152 LEAVE_SCOPE(oldsave);
5153 iters = (SP - PL_stack_base) - base;
5154 if (iters > maxiters)
5155 DIE(aTHX_ "Split loop");
5157 /* keep field after final delim? */
5158 if (s < strend || (iters && origlimit)) {
5159 dstr = NEWSV(34, strend-s);
5160 sv_setpvn(dstr, s, strend-s);
5166 else if (!origlimit) {
5167 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5173 SWITCHSTACK(ary, oldstack);
5174 if (SvSMAGICAL(ary)) {
5179 if (gimme == G_ARRAY) {
5181 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5189 call_method("PUSH",G_SCALAR|G_DISCARD);
5192 if (gimme == G_ARRAY) {
5193 /* EXTEND should not be needed - we just popped them */
5195 for (i=0; i < iters; i++) {
5196 SV **svp = av_fetch(ary, i, FALSE);
5197 PUSHs((svp) ? *svp : &PL_sv_undef);
5204 if (gimme == G_ARRAY)
5207 if (iters || !pm->op_pmreplroot) {
5217 Perl_unlock_condpair(pTHX_ void *svv)
5220 MAGIC *mg = mg_find((SV*)svv, 'm');
5223 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5224 MUTEX_LOCK(MgMUTEXP(mg));
5225 if (MgOWNER(mg) != thr)
5226 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5228 COND_SIGNAL(MgOWNERCONDP(mg));
5229 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5230 PTR2UV(thr), PTR2UV(svv));)
5231 MUTEX_UNLOCK(MgMUTEXP(mg));
5233 #endif /* USE_THREADS */
5246 mg = condpair_magic(sv);
5247 MUTEX_LOCK(MgMUTEXP(mg));
5248 if (MgOWNER(mg) == thr)
5249 MUTEX_UNLOCK(MgMUTEXP(mg));
5252 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5254 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5255 PTR2UV(thr), PTR2UV(sv));)
5256 MUTEX_UNLOCK(MgMUTEXP(mg));
5257 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5259 #endif /* USE_THREADS */
5260 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5261 || SvTYPE(retsv) == SVt_PVCV) {
5262 retsv = refto(retsv);
5273 if (PL_op->op_private & OPpLVAL_INTRO)
5274 PUSHs(*save_threadsv(PL_op->op_targ));
5276 PUSHs(THREADSV(PL_op->op_targ));
5279 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5280 #endif /* USE_THREADS */