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,len);
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))
267 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
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))
323 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
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);
2024 if (lvalue) { /* it's an lvalue! */
2025 if (!SvGMAGICAL(sv)) {
2029 if (ckWARN(WARN_SUBSTR))
2030 Perl_warner(aTHX_ WARN_SUBSTR,
2031 "Attempt to use reference as lvalue in substr");
2033 if (SvOK(sv)) /* is it defined ? */
2034 (void)SvPOK_only(sv);
2036 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2039 if (SvTYPE(TARG) < SVt_PVLV) {
2040 sv_upgrade(TARG, SVt_PVLV);
2041 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2045 if (LvTARG(TARG) != sv) {
2047 SvREFCNT_dec(LvTARG(TARG));
2048 LvTARG(TARG) = SvREFCNT_inc(sv);
2050 LvTARGOFF(TARG) = pos;
2051 LvTARGLEN(TARG) = rem;
2054 sv_insert(sv, pos, rem, repl, repl_len);
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) {
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)) {
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) {
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)) {
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)) {
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)) {
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 while (++MARK <= SP) {
2651 if (hvtype == SVt_PVHV)
2652 sv = hv_delete_ent(hv, *MARK, discard, 0);
2654 DIE(aTHX_ "Not a HASH reference");
2655 *MARK = sv ? sv : &PL_sv_undef;
2659 else if (gimme == G_SCALAR) {
2668 if (SvTYPE(hv) == SVt_PVHV)
2669 sv = hv_delete_ent(hv, keysv, discard, 0);
2671 DIE(aTHX_ "Not a HASH reference");
2685 if (SvTYPE(hv) == SVt_PVHV) {
2686 if (hv_exists_ent(hv, tmpsv, 0))
2689 else if (SvTYPE(hv) == SVt_PVAV) {
2690 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2694 DIE(aTHX_ "Not a HASH reference");
2701 djSP; dMARK; dORIGMARK;
2702 register HV *hv = (HV*)POPs;
2703 register I32 lval = PL_op->op_flags & OPf_MOD;
2704 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2706 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2707 DIE(aTHX_ "Can't localize pseudo-hash element");
2709 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2710 while (++MARK <= SP) {
2714 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2715 svp = he ? &HeVAL(he) : 0;
2718 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2721 if (!svp || *svp == &PL_sv_undef) {
2723 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2725 if (PL_op->op_private & OPpLVAL_INTRO)
2726 save_helem(hv, keysv, svp);
2728 *MARK = svp ? *svp : &PL_sv_undef;
2731 if (GIMME != G_ARRAY) {
2739 /* List operators. */
2744 if (GIMME != G_ARRAY) {
2746 *MARK = *SP; /* unwanted list, return last item */
2748 *MARK = &PL_sv_undef;
2757 SV **lastrelem = PL_stack_sp;
2758 SV **lastlelem = PL_stack_base + POPMARK;
2759 SV **firstlelem = PL_stack_base + POPMARK + 1;
2760 register SV **firstrelem = lastlelem + 1;
2761 I32 arybase = PL_curcop->cop_arybase;
2762 I32 lval = PL_op->op_flags & OPf_MOD;
2763 I32 is_something_there = lval;
2765 register I32 max = lastrelem - lastlelem;
2766 register SV **lelem;
2769 if (GIMME != G_ARRAY) {
2770 ix = SvIVx(*lastlelem);
2775 if (ix < 0 || ix >= max)
2776 *firstlelem = &PL_sv_undef;
2778 *firstlelem = firstrelem[ix];
2784 SP = firstlelem - 1;
2788 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2794 if (ix < 0 || ix >= max)
2795 *lelem = &PL_sv_undef;
2797 is_something_there = TRUE;
2798 if (!(*lelem = firstrelem[ix]))
2799 *lelem = &PL_sv_undef;
2802 if (is_something_there)
2805 SP = firstlelem - 1;
2811 djSP; dMARK; dORIGMARK;
2812 I32 items = SP - MARK;
2813 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2814 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2821 djSP; dMARK; dORIGMARK;
2822 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2826 SV *val = NEWSV(46, 0);
2828 sv_setsv(val, *++MARK);
2829 else if (ckWARN(WARN_UNSAFE))
2830 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2831 (void)hv_store_ent(hv,key,val,0);
2840 djSP; dMARK; dORIGMARK;
2841 register AV *ary = (AV*)*++MARK;
2845 register I32 offset;
2846 register I32 length;
2853 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2854 *MARK-- = SvTIED_obj((SV*)ary, mg);
2858 call_method("SPLICE",GIMME_V);
2867 offset = i = SvIVx(*MARK);
2869 offset += AvFILLp(ary) + 1;
2871 offset -= PL_curcop->cop_arybase;
2873 DIE(aTHX_ PL_no_aelem, i);
2875 length = SvIVx(*MARK++);
2877 length += AvFILLp(ary) - offset + 1;
2883 length = AvMAX(ary) + 1; /* close enough to infinity */
2887 length = AvMAX(ary) + 1;
2889 if (offset > AvFILLp(ary) + 1)
2890 offset = AvFILLp(ary) + 1;
2891 after = AvFILLp(ary) + 1 - (offset + length);
2892 if (after < 0) { /* not that much array */
2893 length += after; /* offset+length now in array */
2899 /* At this point, MARK .. SP-1 is our new LIST */
2902 diff = newlen - length;
2903 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2906 if (diff < 0) { /* shrinking the area */
2908 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2909 Copy(MARK, tmparyval, newlen, SV*);
2912 MARK = ORIGMARK + 1;
2913 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2914 MEXTEND(MARK, length);
2915 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2917 EXTEND_MORTAL(length);
2918 for (i = length, dst = MARK; i; i--) {
2919 sv_2mortal(*dst); /* free them eventualy */
2926 *MARK = AvARRAY(ary)[offset+length-1];
2929 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2930 SvREFCNT_dec(*dst++); /* free them now */
2933 AvFILLp(ary) += diff;
2935 /* pull up or down? */
2937 if (offset < after) { /* easier to pull up */
2938 if (offset) { /* esp. if nothing to pull */
2939 src = &AvARRAY(ary)[offset-1];
2940 dst = src - diff; /* diff is negative */
2941 for (i = offset; i > 0; i--) /* can't trust Copy */
2945 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2949 if (after) { /* anything to pull down? */
2950 src = AvARRAY(ary) + offset + length;
2951 dst = src + diff; /* diff is negative */
2952 Move(src, dst, after, SV*);
2954 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2955 /* avoid later double free */
2959 dst[--i] = &PL_sv_undef;
2962 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2964 *dst = NEWSV(46, 0);
2965 sv_setsv(*dst++, *src++);
2967 Safefree(tmparyval);
2970 else { /* no, expanding (or same) */
2972 New(452, tmparyval, length, SV*); /* so remember deletion */
2973 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2976 if (diff > 0) { /* expanding */
2978 /* push up or down? */
2980 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2984 Move(src, dst, offset, SV*);
2986 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2988 AvFILLp(ary) += diff;
2991 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2992 av_extend(ary, AvFILLp(ary) + diff);
2993 AvFILLp(ary) += diff;
2996 dst = AvARRAY(ary) + AvFILLp(ary);
2998 for (i = after; i; i--) {
3005 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3006 *dst = NEWSV(46, 0);
3007 sv_setsv(*dst++, *src++);
3009 MARK = ORIGMARK + 1;
3010 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3012 Copy(tmparyval, MARK, length, SV*);
3014 EXTEND_MORTAL(length);
3015 for (i = length, dst = MARK; i; i--) {
3016 sv_2mortal(*dst); /* free them eventualy */
3020 Safefree(tmparyval);
3024 else if (length--) {
3025 *MARK = tmparyval[length];
3028 while (length-- > 0)
3029 SvREFCNT_dec(tmparyval[length]);
3031 Safefree(tmparyval);
3034 *MARK = &PL_sv_undef;
3042 djSP; dMARK; dORIGMARK; dTARGET;
3043 register AV *ary = (AV*)*++MARK;
3044 register SV *sv = &PL_sv_undef;
3047 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3048 *MARK-- = SvTIED_obj((SV*)ary, mg);
3052 call_method("PUSH",G_SCALAR|G_DISCARD);
3057 /* Why no pre-extend of ary here ? */
3058 for (++MARK; MARK <= SP; MARK++) {
3061 sv_setsv(sv, *MARK);
3066 PUSHi( AvFILL(ary) + 1 );
3074 SV *sv = av_pop(av);
3076 (void)sv_2mortal(sv);
3085 SV *sv = av_shift(av);
3090 (void)sv_2mortal(sv);
3097 djSP; dMARK; dORIGMARK; dTARGET;
3098 register AV *ary = (AV*)*++MARK;
3103 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3104 *MARK-- = SvTIED_obj((SV*)ary, mg);
3108 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3113 av_unshift(ary, SP - MARK);
3116 sv_setsv(sv, *++MARK);
3117 (void)av_store(ary, i++, sv);
3121 PUSHi( AvFILL(ary) + 1 );
3131 if (GIMME == G_ARRAY) {
3138 /* safe as long as stack cannot get extended in the above */
3143 register char *down;
3149 do_join(TARG, &PL_sv_no, MARK, SP);
3151 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3152 up = SvPV_force(TARG, len);
3154 if (IN_UTF8) { /* first reverse each character */
3155 U8* s = (U8*)SvPVX(TARG);
3156 U8* send = (U8*)(s + len);
3165 down = (char*)(s - 1);
3166 if (s > send || !((*down & 0xc0) == 0x80)) {
3167 if (ckWARN_d(WARN_UTF8))
3168 Perl_warner(aTHX_ WARN_UTF8,
3169 "Malformed UTF-8 character");
3181 down = SvPVX(TARG) + len - 1;
3187 (void)SvPOK_only(TARG);
3196 S_mul128(pTHX_ SV *sv, U8 m)
3199 char *s = SvPV(sv, len);
3203 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3204 SV *tmpNew = newSVpvn("0000000000", 10);
3206 sv_catsv(tmpNew, sv);
3207 SvREFCNT_dec(sv); /* free old sv */
3212 while (!*t) /* trailing '\0'? */
3215 i = ((*t - '0') << 7) + m;
3216 *(t--) = '0' + (i % 10);
3222 /* Explosives and implosives. */
3224 #if 'I' == 73 && 'J' == 74
3225 /* On an ASCII/ISO kind of system */
3226 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3229 Some other sort of character set - use memchr() so we don't match
3232 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3239 I32 start_sp_offset = SP - PL_stack_base;
3240 I32 gimme = GIMME_V;
3244 register char *pat = SvPV(left, llen);
3245 register char *s = SvPV(right, rlen);
3246 char *strend = s + rlen;
3248 register char *patend = pat + llen;
3253 /* These must not be in registers: */
3270 register U32 culong;
3274 #ifdef PERL_NATINT_PACK
3275 int natint; /* native integer */
3276 int unatint; /* unsigned native integer */
3279 if (gimme != G_ARRAY) { /* arrange to do first one only */
3281 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3282 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3284 while (isDIGIT(*patend) || *patend == '*')
3290 while (pat < patend) {
3292 datumtype = *pat++ & 0xFF;
3293 #ifdef PERL_NATINT_PACK
3296 if (isSPACE(datumtype))
3298 if (datumtype == '#') {
3299 while (pat < patend && *pat != '\n')
3304 char *natstr = "sSiIlL";
3306 if (strchr(natstr, datumtype)) {
3307 #ifdef PERL_NATINT_PACK
3313 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3318 else if (*pat == '*') {
3319 len = strend - strbeg; /* long enough */
3323 else if (isDIGIT(*pat)) {
3325 while (isDIGIT(*pat)) {
3326 len = (len * 10) + (*pat++ - '0');
3328 DIE(aTHX_ "Repeat count in unpack overflows");
3332 len = (datumtype != '@');
3336 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3337 case ',': /* grandfather in commas but with a warning */
3338 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3339 Perl_warner(aTHX_ WARN_UNSAFE,
3340 "Invalid type in unpack: '%c'", (int)datumtype);
3343 if (len == 1 && pat[-1] != '1')
3352 if (len > strend - strbeg)
3353 DIE(aTHX_ "@ outside of string");
3357 if (len > s - strbeg)
3358 DIE(aTHX_ "X outside of string");
3362 if (len > strend - s)
3363 DIE(aTHX_ "x outside of string");
3367 if (start_sp_offset >= SP - PL_stack_base)
3368 DIE(aTHX_ "/ must follow a numeric type");
3371 pat++; /* ignore '*' for compatibility with pack */
3373 DIE(aTHX_ "/ cannot take a count" );
3380 if (len > strend - s)
3383 goto uchar_checksum;
3384 sv = NEWSV(35, len);
3385 sv_setpvn(sv, s, len);
3387 if (datumtype == 'A' || datumtype == 'Z') {
3388 aptr = s; /* borrow register */
3389 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3394 else { /* 'A' strips both nulls and spaces */
3395 s = SvPVX(sv) + len - 1;
3396 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3400 SvCUR_set(sv, s - SvPVX(sv));
3401 s = aptr; /* unborrow register */
3403 XPUSHs(sv_2mortal(sv));
3407 if (star || len > (strend - s) * 8)
3408 len = (strend - s) * 8;
3411 Newz(601, PL_bitcount, 256, char);
3412 for (bits = 1; bits < 256; bits++) {
3413 if (bits & 1) PL_bitcount[bits]++;
3414 if (bits & 2) PL_bitcount[bits]++;
3415 if (bits & 4) PL_bitcount[bits]++;
3416 if (bits & 8) PL_bitcount[bits]++;
3417 if (bits & 16) PL_bitcount[bits]++;
3418 if (bits & 32) PL_bitcount[bits]++;
3419 if (bits & 64) PL_bitcount[bits]++;
3420 if (bits & 128) PL_bitcount[bits]++;
3424 culong += PL_bitcount[*(unsigned char*)s++];
3429 if (datumtype == 'b') {
3431 if (bits & 1) culong++;
3437 if (bits & 128) culong++;
3444 sv = NEWSV(35, len + 1);
3447 aptr = pat; /* borrow register */
3449 if (datumtype == 'b') {
3451 for (len = 0; len < aint; len++) {
3452 if (len & 7) /*SUPPRESS 595*/
3456 *pat++ = '0' + (bits & 1);
3461 for (len = 0; len < aint; len++) {
3466 *pat++ = '0' + ((bits & 128) != 0);
3470 pat = aptr; /* unborrow register */
3471 XPUSHs(sv_2mortal(sv));
3475 if (star || len > (strend - s) * 2)
3476 len = (strend - s) * 2;
3477 sv = NEWSV(35, len + 1);
3480 aptr = pat; /* borrow register */
3482 if (datumtype == 'h') {
3484 for (len = 0; len < aint; len++) {
3489 *pat++ = PL_hexdigit[bits & 15];
3494 for (len = 0; len < aint; len++) {
3499 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3503 pat = aptr; /* unborrow register */
3504 XPUSHs(sv_2mortal(sv));
3507 if (len > strend - s)
3512 if (aint >= 128) /* fake up signed chars */
3522 if (aint >= 128) /* fake up signed chars */
3525 sv_setiv(sv, (IV)aint);
3526 PUSHs(sv_2mortal(sv));
3531 if (len > strend - s)
3546 sv_setiv(sv, (IV)auint);
3547 PUSHs(sv_2mortal(sv));
3552 if (len > strend - s)
3555 while (len-- > 0 && s < strend) {
3556 auint = utf8_to_uv((U8*)s, &along);
3559 cdouble += (NV)auint;
3567 while (len-- > 0 && s < strend) {
3568 auint = utf8_to_uv((U8*)s, &along);
3571 sv_setuv(sv, (UV)auint);
3572 PUSHs(sv_2mortal(sv));
3577 #if SHORTSIZE == SIZE16
3578 along = (strend - s) / SIZE16;
3580 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3585 #if SHORTSIZE != SIZE16
3589 COPYNN(s, &ashort, sizeof(short));
3600 #if SHORTSIZE > SIZE16
3612 #if SHORTSIZE != SIZE16
3616 COPYNN(s, &ashort, sizeof(short));
3619 sv_setiv(sv, (IV)ashort);
3620 PUSHs(sv_2mortal(sv));
3628 #if SHORTSIZE > SIZE16
3634 sv_setiv(sv, (IV)ashort);
3635 PUSHs(sv_2mortal(sv));
3643 #if SHORTSIZE == SIZE16
3644 along = (strend - s) / SIZE16;
3646 unatint = natint && datumtype == 'S';
3647 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3652 #if SHORTSIZE != SIZE16
3654 unsigned short aushort;
3656 COPYNN(s, &aushort, sizeof(unsigned short));
3657 s += sizeof(unsigned short);
3665 COPY16(s, &aushort);
3668 if (datumtype == 'n')
3669 aushort = PerlSock_ntohs(aushort);
3672 if (datumtype == 'v')
3673 aushort = vtohs(aushort);
3682 #if SHORTSIZE != SIZE16
3684 unsigned short aushort;
3686 COPYNN(s, &aushort, sizeof(unsigned short));
3687 s += sizeof(unsigned short);
3689 sv_setiv(sv, (UV)aushort);
3690 PUSHs(sv_2mortal(sv));
3697 COPY16(s, &aushort);
3701 if (datumtype == 'n')
3702 aushort = PerlSock_ntohs(aushort);
3705 if (datumtype == 'v')
3706 aushort = vtohs(aushort);
3708 sv_setiv(sv, (UV)aushort);
3709 PUSHs(sv_2mortal(sv));
3715 along = (strend - s) / sizeof(int);
3720 Copy(s, &aint, 1, int);
3723 cdouble += (NV)aint;
3732 Copy(s, &aint, 1, int);
3736 /* Without the dummy below unpack("i", pack("i",-1))
3737 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3738 * cc with optimization turned on.
3740 * The bug was detected in
3741 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3742 * with optimization (-O4) turned on.
3743 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3744 * does not have this problem even with -O4.
3746 * This bug was reported as DECC_BUGS 1431
3747 * and tracked internally as GEM_BUGS 7775.
3749 * The bug is fixed in
3750 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3751 * UNIX V4.0F support: DEC C V5.9-006 or later
3752 * UNIX V4.0E support: DEC C V5.8-011 or later
3755 * See also few lines later for the same bug.
3758 sv_setiv(sv, (IV)aint) :
3760 sv_setiv(sv, (IV)aint);
3761 PUSHs(sv_2mortal(sv));
3766 along = (strend - s) / sizeof(unsigned int);
3771 Copy(s, &auint, 1, unsigned int);
3772 s += sizeof(unsigned int);
3774 cdouble += (NV)auint;
3783 Copy(s, &auint, 1, unsigned int);
3784 s += sizeof(unsigned int);
3787 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3788 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3789 * See details few lines earlier. */
3791 sv_setuv(sv, (UV)auint) :
3793 sv_setuv(sv, (UV)auint);
3794 PUSHs(sv_2mortal(sv));
3799 #if LONGSIZE == SIZE32
3800 along = (strend - s) / SIZE32;
3802 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3807 #if LONGSIZE != SIZE32
3811 COPYNN(s, &along, sizeof(long));
3814 cdouble += (NV)along;
3824 #if LONGSIZE > SIZE32
3825 if (along > 2147483647)
3826 along -= 4294967296;
3830 cdouble += (NV)along;
3839 #if LONGSIZE != SIZE32
3843 COPYNN(s, &along, sizeof(long));
3846 sv_setiv(sv, (IV)along);
3847 PUSHs(sv_2mortal(sv));
3855 #if LONGSIZE > SIZE32
3856 if (along > 2147483647)
3857 along -= 4294967296;
3861 sv_setiv(sv, (IV)along);
3862 PUSHs(sv_2mortal(sv));
3870 #if LONGSIZE == SIZE32
3871 along = (strend - s) / SIZE32;
3873 unatint = natint && datumtype == 'L';
3874 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3879 #if LONGSIZE != SIZE32
3881 unsigned long aulong;
3883 COPYNN(s, &aulong, sizeof(unsigned long));
3884 s += sizeof(unsigned long);
3886 cdouble += (NV)aulong;
3898 if (datumtype == 'N')
3899 aulong = PerlSock_ntohl(aulong);
3902 if (datumtype == 'V')
3903 aulong = vtohl(aulong);
3906 cdouble += (NV)aulong;
3915 #if LONGSIZE != SIZE32
3917 unsigned long aulong;
3919 COPYNN(s, &aulong, sizeof(unsigned long));
3920 s += sizeof(unsigned long);
3922 sv_setuv(sv, (UV)aulong);
3923 PUSHs(sv_2mortal(sv));
3933 if (datumtype == 'N')
3934 aulong = PerlSock_ntohl(aulong);
3937 if (datumtype == 'V')
3938 aulong = vtohl(aulong);
3941 sv_setuv(sv, (UV)aulong);
3942 PUSHs(sv_2mortal(sv));
3948 along = (strend - s) / sizeof(char*);
3954 if (sizeof(char*) > strend - s)
3957 Copy(s, &aptr, 1, char*);
3963 PUSHs(sv_2mortal(sv));
3973 while ((len > 0) && (s < strend)) {
3974 auv = (auv << 7) | (*s & 0x7f);
3975 if (!(*s++ & 0x80)) {
3979 PUSHs(sv_2mortal(sv));
3983 else if (++bytes >= sizeof(UV)) { /* promote to string */
3987 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3988 while (s < strend) {
3989 sv = mul128(sv, *s & 0x7f);
3990 if (!(*s++ & 0x80)) {
3999 PUSHs(sv_2mortal(sv));
4004 if ((s >= strend) && bytes)
4005 DIE(aTHX_ "Unterminated compressed integer");
4010 if (sizeof(char*) > strend - s)
4013 Copy(s, &aptr, 1, char*);
4018 sv_setpvn(sv, aptr, len);
4019 PUSHs(sv_2mortal(sv));
4023 along = (strend - s) / sizeof(Quad_t);
4029 if (s + sizeof(Quad_t) > strend)
4032 Copy(s, &aquad, 1, Quad_t);
4033 s += sizeof(Quad_t);
4036 if (aquad >= IV_MIN && aquad <= IV_MAX)
4037 sv_setiv(sv, (IV)aquad);
4039 sv_setnv(sv, (NV)aquad);
4040 PUSHs(sv_2mortal(sv));
4044 along = (strend - s) / sizeof(Quad_t);
4050 if (s + sizeof(Uquad_t) > strend)
4053 Copy(s, &auquad, 1, Uquad_t);
4054 s += sizeof(Uquad_t);
4057 if (auquad <= UV_MAX)
4058 sv_setuv(sv, (UV)auquad);
4060 sv_setnv(sv, (NV)auquad);
4061 PUSHs(sv_2mortal(sv));
4065 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4068 along = (strend - s) / sizeof(float);
4073 Copy(s, &afloat, 1, float);
4082 Copy(s, &afloat, 1, float);
4085 sv_setnv(sv, (NV)afloat);
4086 PUSHs(sv_2mortal(sv));
4092 along = (strend - s) / sizeof(double);
4097 Copy(s, &adouble, 1, double);
4098 s += sizeof(double);
4106 Copy(s, &adouble, 1, double);
4107 s += sizeof(double);
4109 sv_setnv(sv, (NV)adouble);
4110 PUSHs(sv_2mortal(sv));
4116 * Initialise the decode mapping. By using a table driven
4117 * algorithm, the code will be character-set independent
4118 * (and just as fast as doing character arithmetic)
4120 if (PL_uudmap['M'] == 0) {
4123 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4124 PL_uudmap[PL_uuemap[i]] = i;
4126 * Because ' ' and '`' map to the same value,
4127 * we need to decode them both the same.
4132 along = (strend - s) * 3 / 4;
4133 sv = NEWSV(42, along);
4136 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4141 len = PL_uudmap[*s++] & 077;
4143 if (s < strend && ISUUCHAR(*s))
4144 a = PL_uudmap[*s++] & 077;
4147 if (s < strend && ISUUCHAR(*s))
4148 b = PL_uudmap[*s++] & 077;
4151 if (s < strend && ISUUCHAR(*s))
4152 c = PL_uudmap[*s++] & 077;
4155 if (s < strend && ISUUCHAR(*s))
4156 d = PL_uudmap[*s++] & 077;
4159 hunk[0] = (a << 2) | (b >> 4);
4160 hunk[1] = (b << 4) | (c >> 2);
4161 hunk[2] = (c << 6) | d;
4162 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4167 else if (s[1] == '\n') /* possible checksum byte */
4170 XPUSHs(sv_2mortal(sv));
4175 if (strchr("fFdD", datumtype) ||
4176 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4180 while (checksum >= 16) {
4184 while (checksum >= 4) {
4190 along = (1 << checksum) - 1;
4191 while (cdouble < 0.0)
4193 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4194 sv_setnv(sv, cdouble);
4197 if (checksum < 32) {
4198 aulong = (1 << checksum) - 1;
4201 sv_setuv(sv, (UV)culong);
4203 XPUSHs(sv_2mortal(sv));
4207 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4208 PUSHs(&PL_sv_undef);
4213 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4217 *hunk = PL_uuemap[len];
4218 sv_catpvn(sv, hunk, 1);
4221 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4222 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4223 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4224 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4225 sv_catpvn(sv, hunk, 4);
4230 char r = (len > 1 ? s[1] : '\0');
4231 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4232 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4233 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4234 hunk[3] = PL_uuemap[0];
4235 sv_catpvn(sv, hunk, 4);
4237 sv_catpvn(sv, "\n", 1);
4241 S_is_an_int(pTHX_ char *s, STRLEN l)
4244 SV *result = newSVpvn(s, l);
4245 char *result_c = SvPV(result, n_a); /* convenience */
4246 char *out = result_c;
4256 SvREFCNT_dec(result);
4279 SvREFCNT_dec(result);
4285 SvCUR_set(result, out - result_c);
4289 /* pnum must be '\0' terminated */
4291 S_div128(pTHX_ SV *pnum, bool *done)
4294 char *s = SvPV(pnum, len);
4303 i = m * 10 + (*t - '0');
4305 r = (i >> 7); /* r < 10 */
4312 SvCUR_set(pnum, (STRLEN) (t - s));
4319 djSP; dMARK; dORIGMARK; dTARGET;
4320 register SV *cat = TARG;
4323 register char *pat = SvPVx(*++MARK, fromlen);
4324 register char *patend = pat + fromlen;
4329 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4330 static char *space10 = " ";
4332 /* These must not be in registers: */
4347 #ifdef PERL_NATINT_PACK
4348 int natint; /* native integer */
4353 sv_setpvn(cat, "", 0);
4354 while (pat < patend) {
4355 SV *lengthcode = Nullsv;
4356 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4357 datumtype = *pat++ & 0xFF;
4358 #ifdef PERL_NATINT_PACK
4361 if (isSPACE(datumtype))
4363 if (datumtype == '#') {
4364 while (pat < patend && *pat != '\n')
4369 char *natstr = "sSiIlL";
4371 if (strchr(natstr, datumtype)) {
4372 #ifdef PERL_NATINT_PACK
4378 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4381 len = strchr("@Xxu", datumtype) ? 0 : items;
4384 else if (isDIGIT(*pat)) {
4386 while (isDIGIT(*pat)) {
4387 len = (len * 10) + (*pat++ - '0');
4389 DIE(aTHX_ "Repeat count in pack overflows");
4396 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4397 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4398 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4399 ? *MARK : &PL_sv_no)));
4403 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4404 case ',': /* grandfather in commas but with a warning */
4405 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4406 Perl_warner(aTHX_ WARN_UNSAFE,
4407 "Invalid type in pack: '%c'", (int)datumtype);
4410 DIE(aTHX_ "%% may only be used in unpack");
4421 if (SvCUR(cat) < len)
4422 DIE(aTHX_ "X outside of string");
4429 sv_catpvn(cat, null10, 10);
4432 sv_catpvn(cat, null10, len);
4438 aptr = SvPV(fromstr, fromlen);
4439 if (pat[-1] == '*') {
4441 if (datumtype == 'Z')
4444 if (fromlen >= len) {
4445 sv_catpvn(cat, aptr, len);
4446 if (datumtype == 'Z')
4447 *(SvEND(cat)-1) = '\0';
4450 sv_catpvn(cat, aptr, fromlen);
4452 if (datumtype == 'A') {
4454 sv_catpvn(cat, space10, 10);
4457 sv_catpvn(cat, space10, len);
4461 sv_catpvn(cat, null10, 10);
4464 sv_catpvn(cat, null10, len);
4471 char *savepat = pat;
4476 aptr = SvPV(fromstr, fromlen);
4481 SvCUR(cat) += (len+7)/8;
4482 SvGROW(cat, SvCUR(cat) + 1);
4483 aptr = SvPVX(cat) + aint;
4488 if (datumtype == 'B') {
4489 for (len = 0; len++ < aint;) {
4490 items |= *pat++ & 1;
4494 *aptr++ = items & 0xff;
4500 for (len = 0; len++ < aint;) {
4506 *aptr++ = items & 0xff;
4512 if (datumtype == 'B')
4513 items <<= 7 - (aint & 7);
4515 items >>= 7 - (aint & 7);
4516 *aptr++ = items & 0xff;
4518 pat = SvPVX(cat) + SvCUR(cat);
4529 char *savepat = pat;
4534 aptr = SvPV(fromstr, fromlen);
4539 SvCUR(cat) += (len+1)/2;
4540 SvGROW(cat, SvCUR(cat) + 1);
4541 aptr = SvPVX(cat) + aint;
4546 if (datumtype == 'H') {
4547 for (len = 0; len++ < aint;) {
4549 items |= ((*pat++ & 15) + 9) & 15;
4551 items |= *pat++ & 15;
4555 *aptr++ = items & 0xff;
4561 for (len = 0; len++ < aint;) {
4563 items |= (((*pat++ & 15) + 9) & 15) << 4;
4565 items |= (*pat++ & 15) << 4;
4569 *aptr++ = items & 0xff;
4575 *aptr++ = items & 0xff;
4576 pat = SvPVX(cat) + SvCUR(cat);
4588 aint = SvIV(fromstr);
4590 sv_catpvn(cat, &achar, sizeof(char));
4596 auint = SvUV(fromstr);
4597 SvGROW(cat, SvCUR(cat) + 10);
4598 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4603 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4608 afloat = (float)SvNV(fromstr);
4609 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4616 adouble = (double)SvNV(fromstr);
4617 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4623 ashort = (I16)SvIV(fromstr);
4625 ashort = PerlSock_htons(ashort);
4627 CAT16(cat, &ashort);
4633 ashort = (I16)SvIV(fromstr);
4635 ashort = htovs(ashort);
4637 CAT16(cat, &ashort);
4641 #if SHORTSIZE != SIZE16
4643 unsigned short aushort;
4647 aushort = SvUV(fromstr);
4648 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4658 aushort = (U16)SvUV(fromstr);
4659 CAT16(cat, &aushort);
4665 #if SHORTSIZE != SIZE16
4671 ashort = SvIV(fromstr);
4672 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4680 ashort = (I16)SvIV(fromstr);
4681 CAT16(cat, &ashort);
4688 auint = SvUV(fromstr);
4689 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4695 adouble = Perl_floor(SvNV(fromstr));
4698 DIE(aTHX_ "Cannot compress negative numbers");
4704 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4705 adouble <= UV_MAX_cxux
4712 char buf[1 + sizeof(UV)];
4713 char *in = buf + sizeof(buf);
4714 UV auv = U_V(adouble);
4717 *--in = (auv & 0x7f) | 0x80;
4720 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4721 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4723 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4724 char *from, *result, *in;
4729 /* Copy string and check for compliance */
4730 from = SvPV(fromstr, len);
4731 if ((norm = is_an_int(from, len)) == NULL)
4732 DIE(aTHX_ "can compress only unsigned integer");
4734 New('w', result, len, char);
4738 *--in = div128(norm, &done) | 0x80;
4739 result[len - 1] &= 0x7F; /* clear continue bit */
4740 sv_catpvn(cat, in, (result + len) - in);
4742 SvREFCNT_dec(norm); /* free norm */
4744 else if (SvNOKp(fromstr)) {
4745 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4746 char *in = buf + sizeof(buf);
4749 double next = floor(adouble / 128);
4750 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4751 if (--in < buf) /* this cannot happen ;-) */
4752 DIE(aTHX_ "Cannot compress integer");
4754 } while (adouble > 0);
4755 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4756 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4759 DIE(aTHX_ "Cannot compress non integer");
4765 aint = SvIV(fromstr);
4766 sv_catpvn(cat, (char*)&aint, sizeof(int));
4772 aulong = SvUV(fromstr);
4774 aulong = PerlSock_htonl(aulong);
4776 CAT32(cat, &aulong);
4782 aulong = SvUV(fromstr);
4784 aulong = htovl(aulong);
4786 CAT32(cat, &aulong);
4790 #if LONGSIZE != SIZE32
4792 unsigned long aulong;
4796 aulong = SvUV(fromstr);
4797 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4805 aulong = SvUV(fromstr);
4806 CAT32(cat, &aulong);
4811 #if LONGSIZE != SIZE32
4817 along = SvIV(fromstr);
4818 sv_catpvn(cat, (char *)&along, sizeof(long));
4826 along = SvIV(fromstr);
4835 auquad = (Uquad_t)SvUV(fromstr);
4836 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4842 aquad = (Quad_t)SvIV(fromstr);
4843 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4848 len = 1; /* assume SV is correct length */
4853 if (fromstr == &PL_sv_undef)
4857 /* XXX better yet, could spirit away the string to
4858 * a safe spot and hang on to it until the result
4859 * of pack() (and all copies of the result) are
4862 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4863 Perl_warner(aTHX_ WARN_UNSAFE,
4864 "Attempt to pack pointer to temporary value");
4865 if (SvPOK(fromstr) || SvNIOK(fromstr))
4866 aptr = SvPV(fromstr,n_a);
4868 aptr = SvPV_force(fromstr,n_a);
4870 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4875 aptr = SvPV(fromstr, fromlen);
4876 SvGROW(cat, fromlen * 4 / 3);
4881 while (fromlen > 0) {
4888 doencodes(cat, aptr, todo);
4907 register I32 limit = POPi; /* note, negative is forever */
4910 register char *s = SvPV(sv, len);
4911 char *strend = s + len;
4913 register REGEXP *rx;
4917 I32 maxiters = (strend - s) + 10;
4920 I32 origlimit = limit;
4923 AV *oldstack = PL_curstack;
4924 I32 gimme = GIMME_V;
4925 I32 oldsave = PL_savestack_ix;
4926 I32 make_mortal = 1;
4927 MAGIC *mg = (MAGIC *) NULL;
4930 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4935 DIE(aTHX_ "panic: do_split");
4936 rx = pm->op_pmregexp;
4938 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4939 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4941 if (pm->op_pmreplroot) {
4943 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4945 ary = GvAVn((GV*)pm->op_pmreplroot);
4948 else if (gimme != G_ARRAY)
4950 ary = (AV*)PL_curpad[0];
4952 ary = GvAVn(PL_defgv);
4953 #endif /* USE_THREADS */
4956 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4962 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4964 XPUSHs(SvTIED_obj((SV*)ary, mg));
4970 for (i = AvFILLp(ary); i >= 0; i--)
4971 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4973 /* temporarily switch stacks */
4974 SWITCHSTACK(PL_curstack, ary);
4978 base = SP - PL_stack_base;
4980 if (pm->op_pmflags & PMf_SKIPWHITE) {
4981 if (pm->op_pmflags & PMf_LOCALE) {
4982 while (isSPACE_LC(*s))
4990 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4991 SAVEINT(PL_multiline);
4992 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4996 limit = maxiters + 2;
4997 if (pm->op_pmflags & PMf_WHITE) {
5000 while (m < strend &&
5001 !((pm->op_pmflags & PMf_LOCALE)
5002 ? isSPACE_LC(*m) : isSPACE(*m)))
5007 dstr = NEWSV(30, m-s);
5008 sv_setpvn(dstr, s, m-s);
5014 while (s < strend &&
5015 ((pm->op_pmflags & PMf_LOCALE)
5016 ? isSPACE_LC(*s) : isSPACE(*s)))
5020 else if (strEQ("^", rx->precomp)) {
5023 for (m = s; m < strend && *m != '\n'; m++) ;
5027 dstr = NEWSV(30, m-s);
5028 sv_setpvn(dstr, s, m-s);
5035 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5036 && (rx->reganch & ROPT_CHECK_ALL)
5037 && !(rx->reganch & ROPT_ANCH)) {
5038 int tail = (rx->reganch & RE_INTUIT_TAIL);
5039 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5043 if (len == 1 && !tail) {
5047 for (m = s; m < strend && *m != c; m++) ;
5050 dstr = NEWSV(30, m-s);
5051 sv_setpvn(dstr, s, m-s);
5060 while (s < strend && --limit &&
5061 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5062 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5065 dstr = NEWSV(31, m-s);
5066 sv_setpvn(dstr, s, m-s);
5070 s = m + len; /* Fake \n at the end */
5075 maxiters += (strend - s) * rx->nparens;
5076 while (s < strend && --limit
5077 /* && (!rx->check_substr
5078 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5080 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5081 1 /* minend */, sv, NULL, 0))
5083 TAINT_IF(RX_MATCH_TAINTED(rx));
5084 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5089 strend = s + (strend - m);
5091 m = rx->startp[0] + orig;
5092 dstr = NEWSV(32, m-s);
5093 sv_setpvn(dstr, s, m-s);
5098 for (i = 1; i <= rx->nparens; i++) {
5099 s = rx->startp[i] + orig;
5100 m = rx->endp[i] + orig;
5102 dstr = NEWSV(33, m-s);
5103 sv_setpvn(dstr, s, m-s);
5106 dstr = NEWSV(33, 0);
5112 s = rx->endp[0] + orig;
5116 LEAVE_SCOPE(oldsave);
5117 iters = (SP - PL_stack_base) - base;
5118 if (iters > maxiters)
5119 DIE(aTHX_ "Split loop");
5121 /* keep field after final delim? */
5122 if (s < strend || (iters && origlimit)) {
5123 dstr = NEWSV(34, strend-s);
5124 sv_setpvn(dstr, s, strend-s);
5130 else if (!origlimit) {
5131 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5137 SWITCHSTACK(ary, oldstack);
5138 if (SvSMAGICAL(ary)) {
5143 if (gimme == G_ARRAY) {
5145 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5153 call_method("PUSH",G_SCALAR|G_DISCARD);
5156 if (gimme == G_ARRAY) {
5157 /* EXTEND should not be needed - we just popped them */
5159 for (i=0; i < iters; i++) {
5160 SV **svp = av_fetch(ary, i, FALSE);
5161 PUSHs((svp) ? *svp : &PL_sv_undef);
5168 if (gimme == G_ARRAY)
5171 if (iters || !pm->op_pmreplroot) {
5181 Perl_unlock_condpair(pTHX_ void *svv)
5184 MAGIC *mg = mg_find((SV*)svv, 'm');
5187 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5188 MUTEX_LOCK(MgMUTEXP(mg));
5189 if (MgOWNER(mg) != thr)
5190 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5192 COND_SIGNAL(MgOWNERCONDP(mg));
5193 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5194 PTR2UV(thr), PTR2UV(svv));)
5195 MUTEX_UNLOCK(MgMUTEXP(mg));
5197 #endif /* USE_THREADS */
5210 mg = condpair_magic(sv);
5211 MUTEX_LOCK(MgMUTEXP(mg));
5212 if (MgOWNER(mg) == thr)
5213 MUTEX_UNLOCK(MgMUTEXP(mg));
5216 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5218 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5219 PTR2UV(thr), PTR2UV(sv));)
5220 MUTEX_UNLOCK(MgMUTEXP(mg));
5221 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5223 #endif /* USE_THREADS */
5224 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5225 || SvTYPE(retsv) == SVt_PVCV) {
5226 retsv = refto(retsv);
5237 if (PL_op->op_private & OPpLVAL_INTRO)
5238 PUSHs(*save_threadsv(PL_op->op_targ));
5240 PUSHs(THREADSV(PL_op->op_targ));
5243 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5244 #endif /* USE_THREADS */