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 * Offset for integer pack/unpack.
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
42 * the preprocessor.) --???
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55 # define PERL_NATINT_PACK
58 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
59 # if BYTEORDER == 0x12345678
60 # define OFF16(p) (char*)(p)
61 # define OFF32(p) (char*)(p)
63 # if BYTEORDER == 0x87654321
64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
67 }}}} bad cray byte order
70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
76 # define COPY16(s,p) Copy(s, p, SIZE16, char)
77 # define COPY32(s,p) Copy(s, p, SIZE32, char)
78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
83 /* variations on pp_null */
89 /* XXX I can't imagine anyone who doesn't have this actually _needs_
90 it, since pid_t is an integral type.
93 #ifdef NEED_GETPID_PROTO
94 extern Pid_t getpid (void);
100 if (GIMME_V == G_SCALAR)
101 XPUSHs(&PL_sv_undef);
115 if (PL_op->op_private & OPpLVAL_INTRO)
116 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
118 if (PL_op->op_flags & OPf_REF) {
122 if (GIMME == G_ARRAY) {
123 I32 maxarg = AvFILL((AV*)TARG) + 1;
125 if (SvMAGICAL(TARG)) {
127 for (i=0; i < maxarg; i++) {
128 SV **svp = av_fetch((AV*)TARG, i, FALSE);
129 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
133 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
138 SV* sv = sv_newmortal();
139 I32 maxarg = AvFILL((AV*)TARG) + 1;
140 sv_setiv(sv, maxarg);
152 if (PL_op->op_private & OPpLVAL_INTRO)
153 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
154 if (PL_op->op_flags & OPf_REF)
157 if (gimme == G_ARRAY) {
160 else if (gimme == G_SCALAR) {
161 SV* sv = sv_newmortal();
162 if (HvFILL((HV*)TARG))
163 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
164 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
174 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
185 tryAMAGICunDEREF(to_gv);
188 if (SvTYPE(sv) == SVt_PVIO) {
189 GV *gv = (GV*) sv_newmortal();
190 gv_init(gv, 0, "", 0, 0);
191 GvIOp(gv) = (IO *)sv;
192 (void)SvREFCNT_inc(sv);
195 else if (SvTYPE(sv) != SVt_PVGV)
196 DIE(aTHX_ "Not a GLOB reference");
199 if (SvTYPE(sv) != SVt_PVGV) {
203 if (SvGMAGICAL(sv)) {
209 /* If this is a 'my' scalar and flag is set then vivify
212 if (PL_op->op_private & OPpDEREF) {
213 GV *gv = (GV *) newSV(0);
216 if (cUNOP->op_first->op_type == OP_PADSV) {
217 SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
218 name = SvPV(padname,len);
220 gv_init(gv, PL_curcop->cop_stash, name, len, 0);
221 sv_upgrade(sv, SVt_RV);
222 SvRV(sv) = (SV *) gv;
227 if (PL_op->op_flags & OPf_REF ||
228 PL_op->op_private & HINT_STRICT_REFS)
229 DIE(aTHX_ PL_no_usym, "a symbol");
230 if (ckWARN(WARN_UNINITIALIZED))
231 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
235 if ((PL_op->op_flags & OPf_SPECIAL) &&
236 !(PL_op->op_flags & OPf_MOD))
238 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
243 if (PL_op->op_private & HINT_STRICT_REFS)
244 DIE(aTHX_ PL_no_symref, sym, "a symbol");
245 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
249 if (PL_op->op_private & OPpLVAL_INTRO)
250 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
261 tryAMAGICunDEREF(to_sv);
264 switch (SvTYPE(sv)) {
268 DIE(aTHX_ "Not a SCALAR reference");
276 if (SvTYPE(gv) != SVt_PVGV) {
277 if (SvGMAGICAL(sv)) {
283 if (PL_op->op_flags & OPf_REF ||
284 PL_op->op_private & HINT_STRICT_REFS)
285 DIE(aTHX_ PL_no_usym, "a SCALAR");
286 if (ckWARN(WARN_UNINITIALIZED))
287 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
291 if ((PL_op->op_flags & OPf_SPECIAL) &&
292 !(PL_op->op_flags & OPf_MOD))
294 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
299 if (PL_op->op_private & HINT_STRICT_REFS)
300 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
301 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
306 if (PL_op->op_flags & OPf_MOD) {
307 if (PL_op->op_private & OPpLVAL_INTRO)
308 sv = save_scalar((GV*)TOPs);
309 else if (PL_op->op_private & OPpDEREF)
310 vivify_ref(sv, PL_op->op_private & OPpDEREF);
320 SV *sv = AvARYLEN(av);
322 AvARYLEN(av) = sv = NEWSV(0,0);
323 sv_upgrade(sv, SVt_IV);
324 sv_magic(sv, (SV*)av, '#', Nullch, 0);
332 djSP; dTARGET; dPOPss;
334 if (PL_op->op_flags & OPf_MOD) {
335 if (SvTYPE(TARG) < SVt_PVLV) {
336 sv_upgrade(TARG, SVt_PVLV);
337 sv_magic(TARG, Nullsv, '.', Nullch, 0);
341 if (LvTARG(TARG) != sv) {
343 SvREFCNT_dec(LvTARG(TARG));
344 LvTARG(TARG) = SvREFCNT_inc(sv);
346 PUSHs(TARG); /* no SvSETMAGIC */
352 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
353 mg = mg_find(sv, 'g');
354 if (mg && mg->mg_len >= 0) {
358 PUSHi(i + PL_curcop->cop_arybase);
372 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
373 /* (But not in defined().) */
374 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
377 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
380 cv = (CV*)&PL_sv_undef;
394 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
395 char *s = SvPVX(TOPs);
396 if (strnEQ(s, "CORE::", 6)) {
399 code = keyword(s + 6, SvCUR(TOPs) - 6);
400 if (code < 0) { /* Overridable. */
401 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
402 int i = 0, n = 0, seen_question = 0;
404 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
406 while (i < MAXO) { /* The slow way. */
407 if (strEQ(s + 6, PL_op_name[i])
408 || strEQ(s + 6, PL_op_desc[i]))
414 goto nonesuch; /* Should not happen... */
416 oa = PL_opargs[i] >> OASHIFT;
418 if (oa & OA_OPTIONAL) {
422 else if (seen_question)
423 goto set; /* XXXX system, exec */
424 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
425 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
428 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
429 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
433 ret = sv_2mortal(newSVpvn(str, n - 1));
435 else if (code) /* Non-Overridable */
437 else { /* None such */
439 Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
443 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
445 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
454 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
456 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
472 if (GIMME != G_ARRAY) {
476 *MARK = &PL_sv_undef;
477 *MARK = refto(*MARK);
481 EXTEND_MORTAL(SP - MARK);
483 *MARK = refto(*MARK);
488 S_refto(pTHX_ SV *sv)
492 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
495 if (!(sv = LvTARG(sv)))
498 (void)SvREFCNT_inc(sv);
500 else if (SvPADTMP(sv))
504 (void)SvREFCNT_inc(sv);
507 sv_upgrade(rv, SVt_RV);
521 if (sv && SvGMAGICAL(sv))
524 if (!sv || !SvROK(sv))
528 pv = sv_reftype(sv,TRUE);
529 PUSHp(pv, strlen(pv));
539 stash = PL_curcop->cop_stash;
543 char *ptr = SvPV(ssv,len);
544 if (ckWARN(WARN_UNSAFE) && len == 0)
545 Perl_warner(aTHX_ WARN_UNSAFE,
546 "Explicit blessing to '' (assuming package main)");
547 stash = gv_stashpvn(ptr, len, TRUE);
550 (void)sv_bless(TOPs, stash);
564 elem = SvPV(sv, n_a);
568 switch (elem ? *elem : '\0')
571 if (strEQ(elem, "ARRAY"))
572 tmpRef = (SV*)GvAV(gv);
575 if (strEQ(elem, "CODE"))
576 tmpRef = (SV*)GvCVu(gv);
579 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
580 tmpRef = (SV*)GvIOp(gv);
583 if (strEQ(elem, "GLOB"))
587 if (strEQ(elem, "HASH"))
588 tmpRef = (SV*)GvHV(gv);
591 if (strEQ(elem, "IO"))
592 tmpRef = (SV*)GvIOp(gv);
595 if (strEQ(elem, "NAME"))
596 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
599 if (strEQ(elem, "PACKAGE"))
600 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
603 if (strEQ(elem, "SCALAR"))
617 /* Pattern matching */
622 register unsigned char *s;
625 register I32 *sfirst;
629 if (sv == PL_lastscream) {
635 SvSCREAM_off(PL_lastscream);
636 SvREFCNT_dec(PL_lastscream);
638 PL_lastscream = SvREFCNT_inc(sv);
641 s = (unsigned char*)(SvPV(sv, len));
645 if (pos > PL_maxscream) {
646 if (PL_maxscream < 0) {
647 PL_maxscream = pos + 80;
648 New(301, PL_screamfirst, 256, I32);
649 New(302, PL_screamnext, PL_maxscream, I32);
652 PL_maxscream = pos + pos / 4;
653 Renew(PL_screamnext, PL_maxscream, I32);
657 sfirst = PL_screamfirst;
658 snext = PL_screamnext;
660 if (!sfirst || !snext)
661 DIE(aTHX_ "do_study: out of memory");
663 for (ch = 256; ch; --ch)
670 snext[pos] = sfirst[ch] - pos;
677 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
686 if (PL_op->op_flags & OPf_STACKED)
692 TARG = sv_newmortal();
697 /* Lvalue operators. */
709 djSP; dMARK; dTARGET;
719 SETi(do_chomp(TOPs));
725 djSP; dMARK; dTARGET;
726 register I32 count = 0;
729 count += do_chomp(POPs);
740 if (!sv || !SvANY(sv))
742 switch (SvTYPE(sv)) {
744 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
748 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
752 if (CvROOT(sv) || CvXSUB(sv))
769 if (!PL_op->op_private) {
778 if (SvTHINKFIRST(sv))
781 switch (SvTYPE(sv)) {
791 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
792 Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
793 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
797 /* let user-undef'd sub keep its identity */
798 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
805 SvSetMagicSV(sv, &PL_sv_undef);
809 Newz(602, gp, 1, GP);
810 GvGP(sv) = gp_ref(gp);
811 GvSV(sv) = NEWSV(72,0);
812 GvLINE(sv) = PL_curcop->cop_line;
818 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
821 SvPV_set(sv, Nullch);
834 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
835 Perl_croak(aTHX_ PL_no_modify);
836 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
837 SvIVX(TOPs) != IV_MIN)
840 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
851 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
852 Perl_croak(aTHX_ PL_no_modify);
853 sv_setsv(TARG, TOPs);
854 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
855 SvIVX(TOPs) != IV_MAX)
858 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
873 Perl_croak(aTHX_ PL_no_modify);
874 sv_setsv(TARG, TOPs);
875 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
876 SvIVX(TOPs) != IV_MIN)
879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
888 /* Ordinary operators. */
892 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
895 SETn( pow( left, right) );
902 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
906 SETn( left * right );
913 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
917 DIE(aTHX_ "Illegal division by zero");
918 if ((left % right) && !(PL_op->op_private & HINT_INTEGER))
919 SETn( (NV)left / (NV)right );
921 SETi( left / right );
928 DIE(aTHX_ "Illegal division by zero");
930 /* insure that 20./5. == 4. */
933 if ((NV)I_V(left) == left &&
934 (NV)I_V(right) == right &&
935 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
939 value = left / right;
943 value = left / right;
952 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
962 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
964 right = (right_neg = (i < 0)) ? -i : i;
969 right_neg = dright < 0;
974 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
976 left = (left_neg = (i < 0)) ? -i : i;
984 left_neg = dleft < 0;
993 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
995 # define CAST_D2UV(d) U_V(d)
997 # define CAST_D2UV(d) ((UV)(d))
999 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1000 * or, in other words, precision of UV more than of NV.
1001 * But in fact the approach below turned out to be an
1002 * optimization - floor() may be slow */
1003 if (dright <= UV_MAX && dleft <= UV_MAX) {
1004 right = CAST_D2UV(dright);
1005 left = CAST_D2UV(dleft);
1010 /* Backward-compatibility clause: */
1011 dright = floor(dright + 0.5);
1012 dleft = floor(dleft + 0.5);
1015 DIE(aTHX_ "Illegal modulus zero");
1017 dans = Perl_fmod(dleft, dright);
1018 if ((left_neg != right_neg) && dans)
1019 dans = dright - dans;
1022 sv_setnv(TARG, dans);
1029 DIE(aTHX_ "Illegal modulus zero");
1032 if ((left_neg != right_neg) && ans)
1035 /* XXX may warn: unary minus operator applied to unsigned type */
1036 /* could change -foo to be (~foo)+1 instead */
1037 if (ans <= ~((UV)IV_MAX)+1)
1038 sv_setiv(TARG, ~ans+1);
1040 sv_setnv(TARG, -(NV)ans);
1043 sv_setuv(TARG, ans);
1052 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1054 register I32 count = POPi;
1055 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1057 I32 items = SP - MARK;
1060 max = items * count;
1069 repeatcpy((char*)(MARK + items), (char*)MARK,
1070 items * sizeof(SV*), count - 1);
1073 else if (count <= 0)
1076 else { /* Note: mark already snarfed by pp_list */
1081 SvSetSV(TARG, tmpstr);
1082 SvPV_force(TARG, len);
1087 SvGROW(TARG, (count * len) + 1);
1088 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1089 SvCUR(TARG) *= count;
1091 *SvEND(TARG) = '\0';
1093 (void)SvPOK_only(TARG);
1102 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1106 SETn( left - right );
1113 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1116 if (PL_op->op_private & HINT_INTEGER) {
1130 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1133 if (PL_op->op_private & HINT_INTEGER) {
1147 djSP; tryAMAGICbinSET(lt,0);
1150 SETs(boolSV(TOPn < value));
1157 djSP; tryAMAGICbinSET(gt,0);
1160 SETs(boolSV(TOPn > value));
1167 djSP; tryAMAGICbinSET(le,0);
1170 SETs(boolSV(TOPn <= value));
1177 djSP; tryAMAGICbinSET(ge,0);
1180 SETs(boolSV(TOPn >= value));
1187 djSP; tryAMAGICbinSET(ne,0);
1190 SETs(boolSV(TOPn != value));
1197 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1204 else if (left < right)
1206 else if (left > right)
1219 djSP; tryAMAGICbinSET(slt,0);
1222 int cmp = ((PL_op->op_private & OPpLOCALE)
1223 ? sv_cmp_locale(left, right)
1224 : sv_cmp(left, right));
1225 SETs(boolSV(cmp < 0));
1232 djSP; tryAMAGICbinSET(sgt,0);
1235 int cmp = ((PL_op->op_private & OPpLOCALE)
1236 ? sv_cmp_locale(left, right)
1237 : sv_cmp(left, right));
1238 SETs(boolSV(cmp > 0));
1245 djSP; tryAMAGICbinSET(sle,0);
1248 int cmp = ((PL_op->op_private & OPpLOCALE)
1249 ? sv_cmp_locale(left, right)
1250 : sv_cmp(left, right));
1251 SETs(boolSV(cmp <= 0));
1258 djSP; tryAMAGICbinSET(sge,0);
1261 int cmp = ((PL_op->op_private & OPpLOCALE)
1262 ? sv_cmp_locale(left, right)
1263 : sv_cmp(left, right));
1264 SETs(boolSV(cmp >= 0));
1271 djSP; tryAMAGICbinSET(seq,0);
1274 SETs(boolSV(sv_eq(left, right)));
1281 djSP; tryAMAGICbinSET(sne,0);
1284 SETs(boolSV(!sv_eq(left, right)));
1291 djSP; dTARGET; tryAMAGICbin(scmp,0);
1294 int cmp = ((PL_op->op_private & OPpLOCALE)
1295 ? sv_cmp_locale(left, right)
1296 : sv_cmp(left, right));
1304 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1307 if (SvNIOKp(left) || SvNIOKp(right)) {
1308 if (PL_op->op_private & HINT_INTEGER) {
1309 IV value = SvIV(left) & SvIV(right);
1313 UV value = SvUV(left) & SvUV(right);
1318 do_vop(PL_op->op_type, TARG, left, right);
1327 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1330 if (SvNIOKp(left) || SvNIOKp(right)) {
1331 if (PL_op->op_private & HINT_INTEGER) {
1332 IV value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1336 UV value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1341 do_vop(PL_op->op_type, TARG, left, right);
1350 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1353 if (SvNIOKp(left) || SvNIOKp(right)) {
1354 if (PL_op->op_private & HINT_INTEGER) {
1355 IV value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1359 UV value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1364 do_vop(PL_op->op_type, TARG, left, right);
1373 djSP; dTARGET; tryAMAGICun(neg);
1378 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1380 else if (SvNIOKp(sv))
1382 else if (SvPOKp(sv)) {
1384 char *s = SvPV(sv, len);
1385 if (isIDFIRST(*s)) {
1386 sv_setpvn(TARG, "-", 1);
1389 else if (*s == '+' || *s == '-') {
1391 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1393 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1394 sv_setpvn(TARG, "-", 1);
1398 sv_setnv(TARG, -SvNV(sv));
1409 djSP; tryAMAGICunSET(not);
1410 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1416 djSP; dTARGET; tryAMAGICun(compl);
1420 if (PL_op->op_private & HINT_INTEGER) {
1421 IV value = ~SvIV(sv);
1425 UV value = ~SvUV(sv);
1430 register char *tmps;
1431 register long *tmpl;
1436 tmps = SvPV_force(TARG, len);
1439 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1442 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1446 for ( ; anum > 0; anum--, tmps++)
1455 /* integer versions of some of the above */
1459 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1462 SETi( left * right );
1469 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1473 DIE(aTHX_ "Illegal division by zero");
1474 value = POPi / value;
1482 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1486 DIE(aTHX_ "Illegal modulus zero");
1487 SETi( left % right );
1494 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1497 SETi( left + right );
1504 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1507 SETi( left - right );
1514 djSP; tryAMAGICbinSET(lt,0);
1517 SETs(boolSV(left < right));
1524 djSP; tryAMAGICbinSET(gt,0);
1527 SETs(boolSV(left > right));
1534 djSP; tryAMAGICbinSET(le,0);
1537 SETs(boolSV(left <= right));
1544 djSP; tryAMAGICbinSET(ge,0);
1547 SETs(boolSV(left >= right));
1554 djSP; tryAMAGICbinSET(eq,0);
1557 SETs(boolSV(left == right));
1564 djSP; tryAMAGICbinSET(ne,0);
1567 SETs(boolSV(left != right));
1574 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1581 else if (left < right)
1592 djSP; dTARGET; tryAMAGICun(neg);
1597 /* High falutin' math. */
1601 djSP; dTARGET; tryAMAGICbin(atan2,0);
1604 SETn(Perl_atan2(left, right));
1611 djSP; dTARGET; tryAMAGICun(sin);
1615 value = Perl_sin(value);
1623 djSP; dTARGET; tryAMAGICun(cos);
1627 value = Perl_cos(value);
1633 /* Support Configure command-line overrides for rand() functions.
1634 After 5.005, perhaps we should replace this by Configure support
1635 for drand48(), random(), or rand(). For 5.005, though, maintain
1636 compatibility by calling rand() but allow the user to override it.
1637 See INSTALL for details. --Andy Dougherty 15 July 1998
1639 /* Now it's after 5.005, and Configure supports drand48() and random(),
1640 in addition to rand(). So the overrides should not be needed any more.
1641 --Jarkko Hietaniemi 27 September 1998
1644 #ifndef HAS_DRAND48_PROTO
1645 extern double drand48 (void);
1658 if (!PL_srand_called) {
1659 (void)seedDrand01((Rand_seed_t)seed());
1660 PL_srand_called = TRUE;
1675 (void)seedDrand01((Rand_seed_t)anum);
1676 PL_srand_called = TRUE;
1685 * This is really just a quick hack which grabs various garbage
1686 * values. It really should be a real hash algorithm which
1687 * spreads the effect of every input bit onto every output bit,
1688 * if someone who knows about such things would bother to write it.
1689 * Might be a good idea to add that function to CORE as well.
1690 * No numbers below come from careful analysis or anything here,
1691 * except they are primes and SEED_C1 > 1E6 to get a full-width
1692 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1693 * probably be bigger too.
1696 # define SEED_C1 1000003
1697 #define SEED_C4 73819
1699 # define SEED_C1 25747
1700 #define SEED_C4 20639
1704 #define SEED_C5 26107
1707 #ifndef PERL_NO_DEV_RANDOM
1712 # include <starlet.h>
1713 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1714 * in 100-ns units, typically incremented ever 10 ms. */
1715 unsigned int when[2];
1717 # ifdef HAS_GETTIMEOFDAY
1718 struct timeval when;
1724 /* This test is an escape hatch, this symbol isn't set by Configure. */
1725 #ifndef PERL_NO_DEV_RANDOM
1726 #ifndef PERL_RANDOM_DEVICE
1727 /* /dev/random isn't used by default because reads from it will block
1728 * if there isn't enough entropy available. You can compile with
1729 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1730 * is enough real entropy to fill the seed. */
1731 # define PERL_RANDOM_DEVICE "/dev/urandom"
1733 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1735 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1744 _ckvmssts(sys$gettim(when));
1745 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1747 # ifdef HAS_GETTIMEOFDAY
1748 gettimeofday(&when,(struct timezone *) 0);
1749 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1752 u = (U32)SEED_C1 * when;
1755 u += SEED_C3 * (U32)getpid();
1756 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1757 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1758 u += SEED_C5 * (U32)(UV)&when;
1765 djSP; dTARGET; tryAMAGICun(exp);
1769 value = Perl_exp(value);
1777 djSP; dTARGET; tryAMAGICun(log);
1782 RESTORE_NUMERIC_STANDARD();
1783 DIE(aTHX_ "Can't take log of %g", value);
1785 value = Perl_log(value);
1793 djSP; dTARGET; tryAMAGICun(sqrt);
1798 RESTORE_NUMERIC_STANDARD();
1799 DIE(aTHX_ "Can't take sqrt of %g", value);
1801 value = Perl_sqrt(value);
1814 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1820 (void)Perl_modf(value, &value);
1822 (void)Perl_modf(-value, &value);
1837 djSP; dTARGET; tryAMAGICun(abs);
1842 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1843 (iv = SvIVX(TOPs)) != IV_MIN) {
1865 XPUSHn(scan_hex(tmps, 99, &argtype));
1878 while (*tmps && isSPACE(*tmps))
1883 value = scan_hex(++tmps, 99, &argtype);
1884 else if (*tmps == 'b')
1885 value = scan_bin(++tmps, 99, &argtype);
1887 value = scan_oct(tmps, 99, &argtype);
1899 SETi( sv_len_utf8(TOPs) );
1903 SETi( sv_len(TOPs) );
1917 I32 lvalue = PL_op->op_flags & OPf_MOD;
1919 I32 arybase = PL_curcop->cop_arybase;
1923 SvTAINTED_off(TARG); /* decontaminate */
1927 repl = SvPV(sv, repl_len);
1934 tmps = SvPV(sv, curlen);
1936 utfcurlen = sv_len_utf8(sv);
1937 if (utfcurlen == curlen)
1945 if (pos >= arybase) {
1963 else if (len >= 0) {
1965 if (rem > (I32)curlen)
1979 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1980 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
1985 sv_pos_u2b(sv, &pos, &rem);
1987 sv_setpvn(TARG, tmps, rem);
1988 if (lvalue) { /* it's an lvalue! */
1989 if (!SvGMAGICAL(sv)) {
1993 if (ckWARN(WARN_SUBSTR))
1994 Perl_warner(aTHX_ WARN_SUBSTR,
1995 "Attempt to use reference as lvalue in substr");
1997 if (SvOK(sv)) /* is it defined ? */
1998 (void)SvPOK_only(sv);
2000 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2003 if (SvTYPE(TARG) < SVt_PVLV) {
2004 sv_upgrade(TARG, SVt_PVLV);
2005 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2009 if (LvTARG(TARG) != sv) {
2011 SvREFCNT_dec(LvTARG(TARG));
2012 LvTARG(TARG) = SvREFCNT_inc(sv);
2014 LvTARGOFF(TARG) = pos;
2015 LvTARGLEN(TARG) = rem;
2018 sv_insert(sv, pos, rem, repl, repl_len);
2021 PUSHs(TARG); /* avoid SvSETMAGIC here */
2028 register I32 size = POPi;
2029 register I32 offset = POPi;
2030 register SV *src = POPs;
2031 I32 lvalue = PL_op->op_flags & OPf_MOD;
2033 unsigned char *s = (unsigned char*)SvPV(src, srclen);
2034 unsigned long retnum;
2037 SvTAINTED_off(TARG); /* decontaminate */
2038 offset *= size; /* turn into bit offset */
2039 len = (offset + size + 7) / 8;
2040 if (offset < 0 || size < 1)
2043 if (lvalue) { /* it's an lvalue! */
2044 if (SvTYPE(TARG) < SVt_PVLV) {
2045 sv_upgrade(TARG, SVt_PVLV);
2046 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2050 if (LvTARG(TARG) != src) {
2052 SvREFCNT_dec(LvTARG(TARG));
2053 LvTARG(TARG) = SvREFCNT_inc(src);
2055 LvTARGOFF(TARG) = offset;
2056 LvTARGLEN(TARG) = size;
2064 if (offset >= srclen)
2067 retnum = (unsigned long) s[offset] << 8;
2069 else if (size == 32) {
2070 if (offset >= srclen)
2072 else if (offset + 1 >= srclen)
2073 retnum = (unsigned long) s[offset] << 24;
2074 else if (offset + 2 >= srclen)
2075 retnum = ((unsigned long) s[offset] << 24) +
2076 ((unsigned long) s[offset + 1] << 16);
2078 retnum = ((unsigned long) s[offset] << 24) +
2079 ((unsigned long) s[offset + 1] << 16) +
2080 (s[offset + 2] << 8);
2085 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
2090 else if (size == 16)
2091 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
2092 else if (size == 32)
2093 retnum = ((unsigned long) s[offset] << 24) +
2094 ((unsigned long) s[offset + 1] << 16) +
2095 (s[offset + 2] << 8) + s[offset+3];
2099 sv_setuv(TARG, (UV)retnum);
2114 I32 arybase = PL_curcop->cop_arybase;
2119 offset = POPi - arybase;
2122 tmps = SvPV(big, biglen);
2123 if (IN_UTF8 && offset > 0)
2124 sv_pos_u2b(big, &offset, 0);
2127 else if (offset > biglen)
2129 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2130 (unsigned char*)tmps + biglen, little, 0)))
2133 retval = tmps2 - tmps;
2134 if (IN_UTF8 && retval > 0)
2135 sv_pos_b2u(big, &retval);
2136 PUSHi(retval + arybase);
2151 I32 arybase = PL_curcop->cop_arybase;
2157 tmps2 = SvPV(little, llen);
2158 tmps = SvPV(big, blen);
2162 if (IN_UTF8 && offset > 0)
2163 sv_pos_u2b(big, &offset, 0);
2164 offset = offset - arybase + llen;
2168 else if (offset > blen)
2170 if (!(tmps2 = rninstr(tmps, tmps + offset,
2171 tmps2, tmps2 + llen)))
2174 retval = tmps2 - tmps;
2175 if (IN_UTF8 && retval > 0)
2176 sv_pos_b2u(big, &retval);
2177 PUSHi(retval + arybase);
2183 djSP; dMARK; dORIGMARK; dTARGET;
2184 do_sprintf(TARG, SP-MARK, MARK+1);
2185 TAINT_IF(SvTAINTED(TARG));
2196 U8 *tmps = (U8*)POPpx;
2199 if (IN_UTF8 && (*tmps & 0x80))
2200 value = utf8_to_uv(tmps, &retlen);
2202 value = (UV)(*tmps & 255);
2213 (void)SvUPGRADE(TARG,SVt_PV);
2215 if (IN_UTF8 && value >= 128) {
2218 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2219 SvCUR_set(TARG, tmps - SvPVX(TARG));
2221 (void)SvPOK_only(TARG);
2231 (void)SvPOK_only(TARG);
2238 djSP; dTARGET; dPOPTOPssrl;
2241 char *tmps = SvPV(left, n_a);
2243 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2245 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2249 "The crypt() function is unimplemented due to excessive paranoia.");
2262 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2266 UV uv = utf8_to_uv(s, &ulen);
2268 if (PL_op->op_private & OPpLOCALE) {
2271 uv = toTITLE_LC_uni(uv);
2274 uv = toTITLE_utf8(s);
2276 tend = uv_to_utf8(tmpbuf, uv);
2278 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2280 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2281 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2285 s = (U8*)SvPV_force(sv, slen);
2286 Copy(tmpbuf, s, ulen, U8);
2290 if (!SvPADTMP(sv)) {
2296 s = (U8*)SvPV_force(sv, slen);
2298 if (PL_op->op_private & OPpLOCALE) {
2301 *s = toUPPER_LC(*s);
2319 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2323 UV uv = utf8_to_uv(s, &ulen);
2325 if (PL_op->op_private & OPpLOCALE) {
2328 uv = toLOWER_LC_uni(uv);
2331 uv = toLOWER_utf8(s);
2333 tend = uv_to_utf8(tmpbuf, uv);
2335 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2337 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2338 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2342 s = (U8*)SvPV_force(sv, slen);
2343 Copy(tmpbuf, s, ulen, U8);
2347 if (!SvPADTMP(sv)) {
2353 s = (U8*)SvPV_force(sv, slen);
2355 if (PL_op->op_private & OPpLOCALE) {
2358 *s = toLOWER_LC(*s);
2383 s = (U8*)SvPV(sv,len);
2385 sv_setpvn(TARG, "", 0);
2389 (void)SvUPGRADE(TARG, SVt_PV);
2390 SvGROW(TARG, (len * 2) + 1);
2391 (void)SvPOK_only(TARG);
2392 d = (U8*)SvPVX(TARG);
2394 if (PL_op->op_private & OPpLOCALE) {
2398 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2404 d = uv_to_utf8(d, toUPPER_utf8( s ));
2409 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2414 if (!SvPADTMP(sv)) {
2420 s = (U8*)SvPV_force(sv, len);
2422 register U8 *send = s + len;
2424 if (PL_op->op_private & OPpLOCALE) {
2427 for (; s < send; s++)
2428 *s = toUPPER_LC(*s);
2431 for (; s < send; s++)
2454 s = (U8*)SvPV(sv,len);
2456 sv_setpvn(TARG, "", 0);
2460 (void)SvUPGRADE(TARG, SVt_PV);
2461 SvGROW(TARG, (len * 2) + 1);
2462 (void)SvPOK_only(TARG);
2463 d = (U8*)SvPVX(TARG);
2465 if (PL_op->op_private & OPpLOCALE) {
2469 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2475 d = uv_to_utf8(d, toLOWER_utf8(s));
2480 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2485 if (!SvPADTMP(sv)) {
2492 s = (U8*)SvPV_force(sv, len);
2494 register U8 *send = s + len;
2496 if (PL_op->op_private & OPpLOCALE) {
2499 for (; s < send; s++)
2500 *s = toLOWER_LC(*s);
2503 for (; s < send; s++)
2518 register char *s = SvPV(sv,len);
2522 (void)SvUPGRADE(TARG, SVt_PV);
2523 SvGROW(TARG, (len * 2) + 1);
2528 STRLEN ulen = UTF8SKIP(s);
2551 SvCUR_set(TARG, d - SvPVX(TARG));
2552 (void)SvPOK_only(TARG);
2555 sv_setpvn(TARG, s, len);
2557 if (SvSMAGICAL(TARG))
2566 djSP; dMARK; dORIGMARK;
2568 register AV* av = (AV*)POPs;
2569 register I32 lval = PL_op->op_flags & OPf_MOD;
2570 I32 arybase = PL_curcop->cop_arybase;
2573 if (SvTYPE(av) == SVt_PVAV) {
2574 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2576 for (svp = MARK + 1; svp <= SP; svp++) {
2581 if (max > AvMAX(av))
2584 while (++MARK <= SP) {
2585 elem = SvIVx(*MARK);
2589 svp = av_fetch(av, elem, lval);
2591 if (!svp || *svp == &PL_sv_undef)
2592 DIE(aTHX_ PL_no_aelem, elem);
2593 if (PL_op->op_private & OPpLVAL_INTRO)
2594 save_aelem(av, elem, svp);
2596 *MARK = svp ? *svp : &PL_sv_undef;
2599 if (GIMME != G_ARRAY) {
2607 /* Associative arrays. */
2612 HV *hash = (HV*)POPs;
2614 I32 gimme = GIMME_V;
2615 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2618 /* might clobber stack_sp */
2619 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2624 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2625 if (gimme == G_ARRAY) {
2628 /* might clobber stack_sp */
2630 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2635 else if (gimme == G_SCALAR)
2654 I32 gimme = GIMME_V;
2655 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2659 if (PL_op->op_private & OPpSLICE) {
2663 hvtype = SvTYPE(hv);
2664 while (++MARK <= SP) {
2665 if (hvtype == SVt_PVHV)
2666 sv = hv_delete_ent(hv, *MARK, discard, 0);
2668 DIE(aTHX_ "Not a HASH reference");
2669 *MARK = sv ? sv : &PL_sv_undef;
2673 else if (gimme == G_SCALAR) {
2682 if (SvTYPE(hv) == SVt_PVHV)
2683 sv = hv_delete_ent(hv, keysv, discard, 0);
2685 DIE(aTHX_ "Not a HASH reference");
2699 if (SvTYPE(hv) == SVt_PVHV) {
2700 if (hv_exists_ent(hv, tmpsv, 0))
2703 else if (SvTYPE(hv) == SVt_PVAV) {
2704 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2708 DIE(aTHX_ "Not a HASH reference");
2715 djSP; dMARK; dORIGMARK;
2716 register HV *hv = (HV*)POPs;
2717 register I32 lval = PL_op->op_flags & OPf_MOD;
2718 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2720 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2721 DIE(aTHX_ "Can't localize pseudo-hash element");
2723 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2724 while (++MARK <= SP) {
2728 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2729 svp = he ? &HeVAL(he) : 0;
2732 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2735 if (!svp || *svp == &PL_sv_undef) {
2737 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2739 if (PL_op->op_private & OPpLVAL_INTRO)
2740 save_helem(hv, keysv, svp);
2742 *MARK = svp ? *svp : &PL_sv_undef;
2745 if (GIMME != G_ARRAY) {
2753 /* List operators. */
2758 if (GIMME != G_ARRAY) {
2760 *MARK = *SP; /* unwanted list, return last item */
2762 *MARK = &PL_sv_undef;
2771 SV **lastrelem = PL_stack_sp;
2772 SV **lastlelem = PL_stack_base + POPMARK;
2773 SV **firstlelem = PL_stack_base + POPMARK + 1;
2774 register SV **firstrelem = lastlelem + 1;
2775 I32 arybase = PL_curcop->cop_arybase;
2776 I32 lval = PL_op->op_flags & OPf_MOD;
2777 I32 is_something_there = lval;
2779 register I32 max = lastrelem - lastlelem;
2780 register SV **lelem;
2783 if (GIMME != G_ARRAY) {
2784 ix = SvIVx(*lastlelem);
2789 if (ix < 0 || ix >= max)
2790 *firstlelem = &PL_sv_undef;
2792 *firstlelem = firstrelem[ix];
2798 SP = firstlelem - 1;
2802 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2808 if (ix < 0 || ix >= max)
2809 *lelem = &PL_sv_undef;
2811 is_something_there = TRUE;
2812 if (!(*lelem = firstrelem[ix]))
2813 *lelem = &PL_sv_undef;
2816 if (is_something_there)
2819 SP = firstlelem - 1;
2825 djSP; dMARK; dORIGMARK;
2826 I32 items = SP - MARK;
2827 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2828 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2835 djSP; dMARK; dORIGMARK;
2836 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2840 SV *val = NEWSV(46, 0);
2842 sv_setsv(val, *++MARK);
2843 else if (ckWARN(WARN_UNSAFE))
2844 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2845 (void)hv_store_ent(hv,key,val,0);
2854 djSP; dMARK; dORIGMARK;
2855 register AV *ary = (AV*)*++MARK;
2859 register I32 offset;
2860 register I32 length;
2867 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2868 *MARK-- = SvTIED_obj((SV*)ary, mg);
2872 call_method("SPLICE",GIMME_V);
2881 offset = i = SvIVx(*MARK);
2883 offset += AvFILLp(ary) + 1;
2885 offset -= PL_curcop->cop_arybase;
2887 DIE(aTHX_ PL_no_aelem, i);
2889 length = SvIVx(*MARK++);
2891 length += AvFILLp(ary) - offset + 1;
2897 length = AvMAX(ary) + 1; /* close enough to infinity */
2901 length = AvMAX(ary) + 1;
2903 if (offset > AvFILLp(ary) + 1)
2904 offset = AvFILLp(ary) + 1;
2905 after = AvFILLp(ary) + 1 - (offset + length);
2906 if (after < 0) { /* not that much array */
2907 length += after; /* offset+length now in array */
2913 /* At this point, MARK .. SP-1 is our new LIST */
2916 diff = newlen - length;
2917 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2920 if (diff < 0) { /* shrinking the area */
2922 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2923 Copy(MARK, tmparyval, newlen, SV*);
2926 MARK = ORIGMARK + 1;
2927 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2928 MEXTEND(MARK, length);
2929 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2931 EXTEND_MORTAL(length);
2932 for (i = length, dst = MARK; i; i--) {
2933 sv_2mortal(*dst); /* free them eventualy */
2940 *MARK = AvARRAY(ary)[offset+length-1];
2943 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2944 SvREFCNT_dec(*dst++); /* free them now */
2947 AvFILLp(ary) += diff;
2949 /* pull up or down? */
2951 if (offset < after) { /* easier to pull up */
2952 if (offset) { /* esp. if nothing to pull */
2953 src = &AvARRAY(ary)[offset-1];
2954 dst = src - diff; /* diff is negative */
2955 for (i = offset; i > 0; i--) /* can't trust Copy */
2959 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2963 if (after) { /* anything to pull down? */
2964 src = AvARRAY(ary) + offset + length;
2965 dst = src + diff; /* diff is negative */
2966 Move(src, dst, after, SV*);
2968 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2969 /* avoid later double free */
2973 dst[--i] = &PL_sv_undef;
2976 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2978 *dst = NEWSV(46, 0);
2979 sv_setsv(*dst++, *src++);
2981 Safefree(tmparyval);
2984 else { /* no, expanding (or same) */
2986 New(452, tmparyval, length, SV*); /* so remember deletion */
2987 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2990 if (diff > 0) { /* expanding */
2992 /* push up or down? */
2994 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2998 Move(src, dst, offset, SV*);
3000 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3002 AvFILLp(ary) += diff;
3005 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3006 av_extend(ary, AvFILLp(ary) + diff);
3007 AvFILLp(ary) += diff;
3010 dst = AvARRAY(ary) + AvFILLp(ary);
3012 for (i = after; i; i--) {
3019 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3020 *dst = NEWSV(46, 0);
3021 sv_setsv(*dst++, *src++);
3023 MARK = ORIGMARK + 1;
3024 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3026 Copy(tmparyval, MARK, length, SV*);
3028 EXTEND_MORTAL(length);
3029 for (i = length, dst = MARK; i; i--) {
3030 sv_2mortal(*dst); /* free them eventualy */
3034 Safefree(tmparyval);
3038 else if (length--) {
3039 *MARK = tmparyval[length];
3042 while (length-- > 0)
3043 SvREFCNT_dec(tmparyval[length]);
3045 Safefree(tmparyval);
3048 *MARK = &PL_sv_undef;
3056 djSP; dMARK; dORIGMARK; dTARGET;
3057 register AV *ary = (AV*)*++MARK;
3058 register SV *sv = &PL_sv_undef;
3061 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3062 *MARK-- = SvTIED_obj((SV*)ary, mg);
3066 call_method("PUSH",G_SCALAR|G_DISCARD);
3071 /* Why no pre-extend of ary here ? */
3072 for (++MARK; MARK <= SP; MARK++) {
3075 sv_setsv(sv, *MARK);
3080 PUSHi( AvFILL(ary) + 1 );
3088 SV *sv = av_pop(av);
3090 (void)sv_2mortal(sv);
3099 SV *sv = av_shift(av);
3104 (void)sv_2mortal(sv);
3111 djSP; dMARK; dORIGMARK; dTARGET;
3112 register AV *ary = (AV*)*++MARK;
3117 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3118 *MARK-- = SvTIED_obj((SV*)ary, mg);
3122 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3127 av_unshift(ary, SP - MARK);
3130 sv_setsv(sv, *++MARK);
3131 (void)av_store(ary, i++, sv);
3135 PUSHi( AvFILL(ary) + 1 );
3145 if (GIMME == G_ARRAY) {
3156 register char *down;
3162 do_join(TARG, &PL_sv_no, MARK, SP);
3164 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3165 up = SvPV_force(TARG, len);
3167 if (IN_UTF8) { /* first reverse each character */
3168 U8* s = (U8*)SvPVX(TARG);
3169 U8* send = (U8*)(s + len);
3178 down = (char*)(s - 1);
3179 if (s > send || !((*down & 0xc0) == 0x80)) {
3180 if (ckWARN_d(WARN_UTF8))
3181 Perl_warner(aTHX_ WARN_UTF8,
3182 "Malformed UTF-8 character");
3194 down = SvPVX(TARG) + len - 1;
3200 (void)SvPOK_only(TARG);
3209 S_mul128(pTHX_ SV *sv, U8 m)
3212 char *s = SvPV(sv, len);
3216 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3217 SV *tmpNew = newSVpvn("0000000000", 10);
3219 sv_catsv(tmpNew, sv);
3220 SvREFCNT_dec(sv); /* free old sv */
3225 while (!*t) /* trailing '\0'? */
3228 i = ((*t - '0') << 7) + m;
3229 *(t--) = '0' + (i % 10);
3235 /* Explosives and implosives. */
3237 #if 'I' == 73 && 'J' == 74
3238 /* On an ASCII/ISO kind of system */
3239 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3242 Some other sort of character set - use memchr() so we don't match
3245 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3253 I32 gimme = GIMME_V;
3257 register char *pat = SvPV(left, llen);
3258 register char *s = SvPV(right, rlen);
3259 char *strend = s + rlen;
3261 register char *patend = pat + llen;
3266 /* These must not be in registers: */
3283 register U32 culong;
3286 #ifdef PERL_NATINT_PACK
3287 int natint; /* native integer */
3288 int unatint; /* unsigned native integer */
3291 if (gimme != G_ARRAY) { /* arrange to do first one only */
3293 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3294 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3296 while (isDIGIT(*patend) || *patend == '*')
3302 while (pat < patend) {
3304 datumtype = *pat++ & 0xFF;
3305 #ifdef PERL_NATINT_PACK
3308 if (isSPACE(datumtype))
3311 char *natstr = "sSiIlL";
3313 if (strchr(natstr, datumtype)) {
3314 #ifdef PERL_NATINT_PACK
3320 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
3324 else if (*pat == '*') {
3325 len = strend - strbeg; /* long enough */
3328 else if (isDIGIT(*pat)) {
3330 while (isDIGIT(*pat)) {
3331 len = (len * 10) + (*pat++ - '0');
3333 Perl_croak(aTHX_ "Repeat count in unpack overflows");
3337 len = (datumtype != '@');
3340 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3341 case ',': /* grandfather in commas but with a warning */
3342 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3343 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3346 if (len == 1 && pat[-1] != '1')
3355 if (len > strend - strbeg)
3356 DIE(aTHX_ "@ outside of string");
3360 if (len > s - strbeg)
3361 DIE(aTHX_ "X outside of string");
3365 if (len > strend - s)
3366 DIE(aTHX_ "x outside of string");
3371 DIE(aTHX_ "# must follow a numeric type");
3372 if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
3373 DIE(aTHX_ "# must be followed by a, A or Z");
3376 pat++; /* ignore '*' for compatibility with pack */
3378 DIE(aTHX_ "# cannot take a count" );
3384 if (len > strend - s)
3387 goto uchar_checksum;
3388 sv = NEWSV(35, len);
3389 sv_setpvn(sv, s, len);
3391 if (datumtype == 'A' || datumtype == 'Z') {
3392 aptr = s; /* borrow register */
3393 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3398 else { /* 'A' strips both nulls and spaces */
3399 s = SvPVX(sv) + len - 1;
3400 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3404 SvCUR_set(sv, s - SvPVX(sv));
3405 s = aptr; /* unborrow register */
3407 XPUSHs(sv_2mortal(sv));
3411 if (pat[-1] == '*' || len > (strend - s) * 8)
3412 len = (strend - s) * 8;
3415 Newz(601, PL_bitcount, 256, char);
3416 for (bits = 1; bits < 256; bits++) {
3417 if (bits & 1) PL_bitcount[bits]++;
3418 if (bits & 2) PL_bitcount[bits]++;
3419 if (bits & 4) PL_bitcount[bits]++;
3420 if (bits & 8) PL_bitcount[bits]++;
3421 if (bits & 16) PL_bitcount[bits]++;
3422 if (bits & 32) PL_bitcount[bits]++;
3423 if (bits & 64) PL_bitcount[bits]++;
3424 if (bits & 128) PL_bitcount[bits]++;
3428 culong += PL_bitcount[*(unsigned char*)s++];
3433 if (datumtype == 'b') {
3435 if (bits & 1) culong++;
3441 if (bits & 128) culong++;
3448 sv = NEWSV(35, len + 1);
3451 aptr = pat; /* borrow register */
3453 if (datumtype == 'b') {
3455 for (len = 0; len < aint; len++) {
3456 if (len & 7) /*SUPPRESS 595*/
3460 *pat++ = '0' + (bits & 1);
3465 for (len = 0; len < aint; len++) {
3470 *pat++ = '0' + ((bits & 128) != 0);
3474 pat = aptr; /* unborrow register */
3475 XPUSHs(sv_2mortal(sv));
3479 if (pat[-1] == '*' || len > (strend - s) * 2)
3480 len = (strend - s) * 2;
3481 sv = NEWSV(35, len + 1);
3484 aptr = pat; /* borrow register */
3486 if (datumtype == 'h') {
3488 for (len = 0; len < aint; len++) {
3493 *pat++ = PL_hexdigit[bits & 15];
3498 for (len = 0; len < aint; len++) {
3503 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3507 pat = aptr; /* unborrow register */
3508 XPUSHs(sv_2mortal(sv));
3511 if (len > strend - s)
3516 if (aint >= 128) /* fake up signed chars */
3526 if (aint >= 128) /* fake up signed chars */
3529 sv_setiv(sv, (IV)aint);
3530 PUSHs(sv_2mortal(sv));
3535 if (len > strend - s)
3550 sv_setiv(sv, (IV)auint);
3551 PUSHs(sv_2mortal(sv));
3556 if (len > strend - s)
3559 while (len-- > 0 && s < strend) {
3560 auint = utf8_to_uv((U8*)s, &along);
3563 cdouble += (NV)auint;
3571 while (len-- > 0 && s < strend) {
3572 auint = utf8_to_uv((U8*)s, &along);
3575 sv_setuv(sv, (UV)auint);
3576 PUSHs(sv_2mortal(sv));
3581 #if SHORTSIZE == SIZE16
3582 along = (strend - s) / SIZE16;
3584 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3589 #if SHORTSIZE != SIZE16
3593 COPYNN(s, &ashort, sizeof(short));
3604 #if SHORTSIZE > SIZE16
3616 #if SHORTSIZE != SIZE16
3620 COPYNN(s, &ashort, sizeof(short));
3623 sv_setiv(sv, (IV)ashort);
3624 PUSHs(sv_2mortal(sv));
3632 #if SHORTSIZE > SIZE16
3638 sv_setiv(sv, (IV)ashort);
3639 PUSHs(sv_2mortal(sv));
3647 #if SHORTSIZE == SIZE16
3648 along = (strend - s) / SIZE16;
3650 unatint = natint && datumtype == 'S';
3651 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3656 #if SHORTSIZE != SIZE16
3658 unsigned short aushort;
3660 COPYNN(s, &aushort, sizeof(unsigned short));
3661 s += sizeof(unsigned short);
3669 COPY16(s, &aushort);
3672 if (datumtype == 'n')
3673 aushort = PerlSock_ntohs(aushort);
3676 if (datumtype == 'v')
3677 aushort = vtohs(aushort);
3686 #if SHORTSIZE != SIZE16
3688 unsigned short aushort;
3690 COPYNN(s, &aushort, sizeof(unsigned short));
3691 s += sizeof(unsigned short);
3693 sv_setiv(sv, (UV)aushort);
3694 PUSHs(sv_2mortal(sv));
3701 COPY16(s, &aushort);
3705 if (datumtype == 'n')
3706 aushort = PerlSock_ntohs(aushort);
3709 if (datumtype == 'v')
3710 aushort = vtohs(aushort);
3712 sv_setiv(sv, (UV)aushort);
3713 PUSHs(sv_2mortal(sv));
3719 along = (strend - s) / sizeof(int);
3724 Copy(s, &aint, 1, int);
3727 cdouble += (NV)aint;
3736 Copy(s, &aint, 1, int);
3740 /* Without the dummy below unpack("i", pack("i",-1))
3741 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3742 * cc with optimization turned on.
3744 * The bug was detected in
3745 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3746 * with optimization (-O4) turned on.
3747 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3748 * does not have this problem even with -O4.
3750 * This bug was reported as DECC_BUGS 1431
3751 * and tracked internally as GEM_BUGS 7775.
3753 * The bug is fixed in
3754 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3755 * UNIX V4.0F support: DEC C V5.9-006 or later
3756 * UNIX V4.0E support: DEC C V5.8-011 or later
3759 * See also few lines later for the same bug.
3762 sv_setiv(sv, (IV)aint) :
3764 sv_setiv(sv, (IV)aint);
3765 PUSHs(sv_2mortal(sv));
3770 along = (strend - s) / sizeof(unsigned int);
3775 Copy(s, &auint, 1, unsigned int);
3776 s += sizeof(unsigned int);
3778 cdouble += (NV)auint;
3787 Copy(s, &auint, 1, unsigned int);
3788 s += sizeof(unsigned int);
3791 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3792 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3793 * See details few lines earlier. */
3795 sv_setuv(sv, (UV)auint) :
3797 sv_setuv(sv, (UV)auint);
3798 PUSHs(sv_2mortal(sv));
3803 #if LONGSIZE == SIZE32
3804 along = (strend - s) / SIZE32;
3806 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3811 #if LONGSIZE != SIZE32
3815 COPYNN(s, &along, sizeof(long));
3818 cdouble += (NV)along;
3828 #if LONGSIZE > SIZE32
3829 if (along > 2147483647)
3830 along -= 4294967296;
3834 cdouble += (NV)along;
3843 #if LONGSIZE != SIZE32
3847 COPYNN(s, &along, sizeof(long));
3850 sv_setiv(sv, (IV)along);
3851 PUSHs(sv_2mortal(sv));
3859 #if LONGSIZE > SIZE32
3860 if (along > 2147483647)
3861 along -= 4294967296;
3865 sv_setiv(sv, (IV)along);
3866 PUSHs(sv_2mortal(sv));
3874 #if LONGSIZE == SIZE32
3875 along = (strend - s) / SIZE32;
3877 unatint = natint && datumtype == 'L';
3878 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3883 #if LONGSIZE != SIZE32
3885 unsigned long aulong;
3887 COPYNN(s, &aulong, sizeof(unsigned long));
3888 s += sizeof(unsigned long);
3890 cdouble += (NV)aulong;
3902 if (datumtype == 'N')
3903 aulong = PerlSock_ntohl(aulong);
3906 if (datumtype == 'V')
3907 aulong = vtohl(aulong);
3910 cdouble += (NV)aulong;
3919 #if LONGSIZE != SIZE32
3921 unsigned long aulong;
3923 COPYNN(s, &aulong, sizeof(unsigned long));
3924 s += sizeof(unsigned long);
3926 sv_setuv(sv, (UV)aulong);
3927 PUSHs(sv_2mortal(sv));
3937 if (datumtype == 'N')
3938 aulong = PerlSock_ntohl(aulong);
3941 if (datumtype == 'V')
3942 aulong = vtohl(aulong);
3945 sv_setuv(sv, (UV)aulong);
3946 PUSHs(sv_2mortal(sv));
3952 along = (strend - s) / sizeof(char*);
3958 if (sizeof(char*) > strend - s)
3961 Copy(s, &aptr, 1, char*);
3967 PUSHs(sv_2mortal(sv));
3977 while ((len > 0) && (s < strend)) {
3978 auv = (auv << 7) | (*s & 0x7f);
3979 if (!(*s++ & 0x80)) {
3983 PUSHs(sv_2mortal(sv));
3987 else if (++bytes >= sizeof(UV)) { /* promote to string */
3991 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3992 while (s < strend) {
3993 sv = mul128(sv, *s & 0x7f);
3994 if (!(*s++ & 0x80)) {
4003 PUSHs(sv_2mortal(sv));
4008 if ((s >= strend) && bytes)
4009 Perl_croak(aTHX_ "Unterminated compressed integer");
4014 if (sizeof(char*) > strend - s)
4017 Copy(s, &aptr, 1, char*);
4022 sv_setpvn(sv, aptr, len);
4023 PUSHs(sv_2mortal(sv));
4027 along = (strend - s) / sizeof(Quad_t);
4033 if (s + sizeof(Quad_t) > strend)
4036 Copy(s, &aquad, 1, Quad_t);
4037 s += sizeof(Quad_t);
4040 if (aquad >= IV_MIN && aquad <= IV_MAX)
4041 sv_setiv(sv, (IV)aquad);
4043 sv_setnv(sv, (NV)aquad);
4044 PUSHs(sv_2mortal(sv));
4048 along = (strend - s) / sizeof(Quad_t);
4054 if (s + sizeof(Uquad_t) > strend)
4057 Copy(s, &auquad, 1, Uquad_t);
4058 s += sizeof(Uquad_t);
4061 if (auquad <= UV_MAX)
4062 sv_setuv(sv, (UV)auquad);
4064 sv_setnv(sv, (NV)auquad);
4065 PUSHs(sv_2mortal(sv));
4069 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4072 along = (strend - s) / sizeof(float);
4077 Copy(s, &afloat, 1, float);
4086 Copy(s, &afloat, 1, float);
4089 sv_setnv(sv, (NV)afloat);
4090 PUSHs(sv_2mortal(sv));
4096 along = (strend - s) / sizeof(double);
4101 Copy(s, &adouble, 1, double);
4102 s += sizeof(double);
4110 Copy(s, &adouble, 1, double);
4111 s += sizeof(double);
4113 sv_setnv(sv, (NV)adouble);
4114 PUSHs(sv_2mortal(sv));
4120 * Initialise the decode mapping. By using a table driven
4121 * algorithm, the code will be character-set independent
4122 * (and just as fast as doing character arithmetic)
4124 if (PL_uudmap['M'] == 0) {
4127 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4128 PL_uudmap[PL_uuemap[i]] = i;
4130 * Because ' ' and '`' map to the same value,
4131 * we need to decode them both the same.
4136 along = (strend - s) * 3 / 4;
4137 sv = NEWSV(42, along);
4140 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4145 len = PL_uudmap[*s++] & 077;
4147 if (s < strend && ISUUCHAR(*s))
4148 a = PL_uudmap[*s++] & 077;
4151 if (s < strend && ISUUCHAR(*s))
4152 b = PL_uudmap[*s++] & 077;
4155 if (s < strend && ISUUCHAR(*s))
4156 c = PL_uudmap[*s++] & 077;
4159 if (s < strend && ISUUCHAR(*s))
4160 d = PL_uudmap[*s++] & 077;
4163 hunk[0] = (a << 2) | (b >> 4);
4164 hunk[1] = (b << 4) | (c >> 2);
4165 hunk[2] = (c << 6) | d;
4166 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4171 else if (s[1] == '\n') /* possible checksum byte */
4174 XPUSHs(sv_2mortal(sv));
4179 if (strchr("fFdD", datumtype) ||
4180 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4184 while (checksum >= 16) {
4188 while (checksum >= 4) {
4194 along = (1 << checksum) - 1;
4195 while (cdouble < 0.0)
4197 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4198 sv_setnv(sv, cdouble);
4201 if (checksum < 32) {
4202 aulong = (1 << checksum) - 1;
4205 sv_setuv(sv, (UV)culong);
4207 XPUSHs(sv_2mortal(sv));
4211 if (SP == oldsp && gimme == G_SCALAR)
4212 PUSHs(&PL_sv_undef);
4217 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4221 *hunk = PL_uuemap[len];
4222 sv_catpvn(sv, hunk, 1);
4225 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4226 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4227 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4228 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4229 sv_catpvn(sv, hunk, 4);
4234 char r = (len > 1 ? s[1] : '\0');
4235 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4236 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4237 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4238 hunk[3] = PL_uuemap[0];
4239 sv_catpvn(sv, hunk, 4);
4241 sv_catpvn(sv, "\n", 1);
4245 S_is_an_int(pTHX_ char *s, STRLEN l)
4248 SV *result = newSVpvn(s, l);
4249 char *result_c = SvPV(result, n_a); /* convenience */
4250 char *out = result_c;
4260 SvREFCNT_dec(result);
4283 SvREFCNT_dec(result);
4289 SvCUR_set(result, out - result_c);
4293 /* pnum must be '\0' terminated */
4295 S_div128(pTHX_ SV *pnum, bool *done)
4298 char *s = SvPV(pnum, len);
4307 i = m * 10 + (*t - '0');
4309 r = (i >> 7); /* r < 10 */
4316 SvCUR_set(pnum, (STRLEN) (t - s));
4323 djSP; dMARK; dORIGMARK; dTARGET;
4324 register SV *cat = TARG;
4327 register char *pat = SvPVx(*++MARK, fromlen);
4328 register char *patend = pat + fromlen;
4333 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4334 static char *space10 = " ";
4336 /* These must not be in registers: */
4351 #ifdef PERL_NATINT_PACK
4352 int natint; /* native integer */
4357 sv_setpvn(cat, "", 0);
4358 while (pat < patend) {
4359 SV *lengthcode = Nullsv;
4360 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4361 datumtype = *pat++ & 0xFF;
4362 #ifdef PERL_NATINT_PACK
4365 if (isSPACE(datumtype))
4368 char *natstr = "sSiIlL";
4370 if (strchr(natstr, datumtype)) {
4371 #ifdef PERL_NATINT_PACK
4377 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
4380 len = strchr("@Xxu", datumtype) ? 0 : items;
4383 else if (isDIGIT(*pat)) {
4385 while (isDIGIT(*pat)) {
4386 len = (len * 10) + (*pat++ - '0');
4388 Perl_croak(aTHX_ "Repeat count in pack overflows");
4395 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4396 DIE(aTHX_ "# must be followed by a*, A* or Z*");
4397 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4398 ? *MARK : &PL_sv_no)));
4402 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4403 case ',': /* grandfather in commas but with a warning */
4404 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4405 Perl_warner(aTHX_ WARN_UNSAFE,
4406 "Invalid type in pack: '%c'", (int)datumtype);
4409 DIE(aTHX_ "%% may only be used in unpack");
4420 if (SvCUR(cat) < len)
4421 DIE(aTHX_ "X outside of string");
4428 sv_catpvn(cat, null10, 10);
4431 sv_catpvn(cat, null10, len);
4437 aptr = SvPV(fromstr, fromlen);
4441 sv_catpvn(cat, aptr, len);
4443 sv_catpvn(cat, aptr, fromlen);
4445 if (datumtype == 'A') {
4447 sv_catpvn(cat, space10, 10);
4450 sv_catpvn(cat, space10, len);
4454 sv_catpvn(cat, null10, 10);
4457 sv_catpvn(cat, null10, len);
4464 char *savepat = pat;
4469 aptr = SvPV(fromstr, fromlen);
4474 SvCUR(cat) += (len+7)/8;
4475 SvGROW(cat, SvCUR(cat) + 1);
4476 aptr = SvPVX(cat) + aint;
4481 if (datumtype == 'B') {
4482 for (len = 0; len++ < aint;) {
4483 items |= *pat++ & 1;
4487 *aptr++ = items & 0xff;
4493 for (len = 0; len++ < aint;) {
4499 *aptr++ = items & 0xff;
4505 if (datumtype == 'B')
4506 items <<= 7 - (aint & 7);
4508 items >>= 7 - (aint & 7);
4509 *aptr++ = items & 0xff;
4511 pat = SvPVX(cat) + SvCUR(cat);
4522 char *savepat = pat;
4527 aptr = SvPV(fromstr, fromlen);
4532 SvCUR(cat) += (len+1)/2;
4533 SvGROW(cat, SvCUR(cat) + 1);
4534 aptr = SvPVX(cat) + aint;
4539 if (datumtype == 'H') {
4540 for (len = 0; len++ < aint;) {
4542 items |= ((*pat++ & 15) + 9) & 15;
4544 items |= *pat++ & 15;
4548 *aptr++ = items & 0xff;
4554 for (len = 0; len++ < aint;) {
4556 items |= (((*pat++ & 15) + 9) & 15) << 4;
4558 items |= (*pat++ & 15) << 4;
4562 *aptr++ = items & 0xff;
4568 *aptr++ = items & 0xff;
4569 pat = SvPVX(cat) + SvCUR(cat);
4581 aint = SvIV(fromstr);
4583 sv_catpvn(cat, &achar, sizeof(char));
4589 auint = SvUV(fromstr);
4590 SvGROW(cat, SvCUR(cat) + 10);
4591 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4596 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4601 afloat = (float)SvNV(fromstr);
4602 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4609 adouble = (double)SvNV(fromstr);
4610 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4616 ashort = (I16)SvIV(fromstr);
4618 ashort = PerlSock_htons(ashort);
4620 CAT16(cat, &ashort);
4626 ashort = (I16)SvIV(fromstr);
4628 ashort = htovs(ashort);
4630 CAT16(cat, &ashort);
4634 #if SHORTSIZE != SIZE16
4636 unsigned short aushort;
4640 aushort = SvUV(fromstr);
4641 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4651 aushort = (U16)SvUV(fromstr);
4652 CAT16(cat, &aushort);
4658 #if SHORTSIZE != SIZE16
4664 ashort = SvIV(fromstr);
4665 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4673 ashort = (I16)SvIV(fromstr);
4674 CAT16(cat, &ashort);
4681 auint = SvUV(fromstr);
4682 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4688 adouble = Perl_floor(SvNV(fromstr));
4691 Perl_croak(aTHX_ "Cannot compress negative numbers");
4697 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4698 adouble <= UV_MAX_cxux
4705 char buf[1 + sizeof(UV)];
4706 char *in = buf + sizeof(buf);
4707 UV auv = U_V(adouble);
4710 *--in = (auv & 0x7f) | 0x80;
4713 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4714 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4716 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4717 char *from, *result, *in;
4722 /* Copy string and check for compliance */
4723 from = SvPV(fromstr, len);
4724 if ((norm = is_an_int(from, len)) == NULL)
4725 Perl_croak(aTHX_ "can compress only unsigned integer");
4727 New('w', result, len, char);
4731 *--in = div128(norm, &done) | 0x80;
4732 result[len - 1] &= 0x7F; /* clear continue bit */
4733 sv_catpvn(cat, in, (result + len) - in);
4735 SvREFCNT_dec(norm); /* free norm */
4737 else if (SvNOKp(fromstr)) {
4738 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4739 char *in = buf + sizeof(buf);
4742 double next = floor(adouble / 128);
4743 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4744 if (--in < buf) /* this cannot happen ;-) */
4745 Perl_croak(aTHX_ "Cannot compress integer");
4747 } while (adouble > 0);
4748 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4749 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4752 Perl_croak(aTHX_ "Cannot compress non integer");
4758 aint = SvIV(fromstr);
4759 sv_catpvn(cat, (char*)&aint, sizeof(int));
4765 aulong = SvUV(fromstr);
4767 aulong = PerlSock_htonl(aulong);
4769 CAT32(cat, &aulong);
4775 aulong = SvUV(fromstr);
4777 aulong = htovl(aulong);
4779 CAT32(cat, &aulong);
4783 #if LONGSIZE != SIZE32
4785 unsigned long aulong;
4789 aulong = SvUV(fromstr);
4790 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4798 aulong = SvUV(fromstr);
4799 CAT32(cat, &aulong);
4804 #if LONGSIZE != SIZE32
4810 along = SvIV(fromstr);
4811 sv_catpvn(cat, (char *)&along, sizeof(long));
4819 along = SvIV(fromstr);
4828 auquad = (Uquad_t)SvUV(fromstr);
4829 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4835 aquad = (Quad_t)SvIV(fromstr);
4836 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4839 #endif /* HAS_QUAD */
4841 len = 1; /* assume SV is correct length */
4846 if (fromstr == &PL_sv_undef)
4850 /* XXX better yet, could spirit away the string to
4851 * a safe spot and hang on to it until the result
4852 * of pack() (and all copies of the result) are
4855 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4856 Perl_warner(aTHX_ WARN_UNSAFE,
4857 "Attempt to pack pointer to temporary value");
4858 if (SvPOK(fromstr) || SvNIOK(fromstr))
4859 aptr = SvPV(fromstr,n_a);
4861 aptr = SvPV_force(fromstr,n_a);
4863 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4868 aptr = SvPV(fromstr, fromlen);
4869 SvGROW(cat, fromlen * 4 / 3);
4874 while (fromlen > 0) {
4881 doencodes(cat, aptr, todo);
4900 register I32 limit = POPi; /* note, negative is forever */
4903 register char *s = SvPV(sv, len);
4904 char *strend = s + len;
4906 register REGEXP *rx;
4910 I32 maxiters = (strend - s) + 10;
4913 I32 origlimit = limit;
4916 AV *oldstack = PL_curstack;
4917 I32 gimme = GIMME_V;
4918 I32 oldsave = PL_savestack_ix;
4919 I32 make_mortal = 1;
4920 MAGIC *mg = (MAGIC *) NULL;
4923 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4928 DIE(aTHX_ "panic: do_split");
4929 rx = pm->op_pmregexp;
4931 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4932 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4934 if (pm->op_pmreplroot)
4935 ary = GvAVn((GV*)pm->op_pmreplroot);
4936 else if (gimme != G_ARRAY)
4938 ary = (AV*)PL_curpad[0];
4940 ary = GvAVn(PL_defgv);
4941 #endif /* USE_THREADS */
4944 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4950 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4952 XPUSHs(SvTIED_obj((SV*)ary, mg));
4957 for (i = AvFILLp(ary); i >= 0; i--)
4958 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4960 /* temporarily switch stacks */
4961 SWITCHSTACK(PL_curstack, ary);
4965 base = SP - PL_stack_base;
4967 if (pm->op_pmflags & PMf_SKIPWHITE) {
4968 if (pm->op_pmflags & PMf_LOCALE) {
4969 while (isSPACE_LC(*s))
4977 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4978 SAVEINT(PL_multiline);
4979 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4983 limit = maxiters + 2;
4984 if (pm->op_pmflags & PMf_WHITE) {
4987 while (m < strend &&
4988 !((pm->op_pmflags & PMf_LOCALE)
4989 ? isSPACE_LC(*m) : isSPACE(*m)))
4994 dstr = NEWSV(30, m-s);
4995 sv_setpvn(dstr, s, m-s);
5001 while (s < strend &&
5002 ((pm->op_pmflags & PMf_LOCALE)
5003 ? isSPACE_LC(*s) : isSPACE(*s)))
5007 else if (rx->prelen == 1 && *rx->precomp == '^') {
5008 if (!(pm->op_pmflags & PMf_MULTILINE)
5009 && !(pm->op_pmregexp->reganch & ROPT_WARNED)) {
5010 if (ckWARN(WARN_DEPRECATED))
5011 Perl_warner(aTHX_ WARN_DEPRECATED,
5012 "split /^/ better written as split /^/m");
5013 pm->op_pmregexp->reganch |= ROPT_WARNED;
5017 for (m = s; m < strend && *m != '\n'; m++) ;
5021 dstr = NEWSV(30, m-s);
5022 sv_setpvn(dstr, s, m-s);
5029 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5030 && (rx->reganch & ROPT_CHECK_ALL)
5031 && !(rx->reganch & ROPT_ANCH)) {
5032 int tail = (rx->reganch & RE_INTUIT_TAIL);
5033 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5037 if (len == 1 && !tail) {
5041 for (m = s; m < strend && *m != c; m++) ;
5044 dstr = NEWSV(30, m-s);
5045 sv_setpvn(dstr, s, m-s);
5054 while (s < strend && --limit &&
5055 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5056 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5059 dstr = NEWSV(31, m-s);
5060 sv_setpvn(dstr, s, m-s);
5064 s = m + len; /* Fake \n at the end */
5069 maxiters += (strend - s) * rx->nparens;
5070 while (s < strend && --limit
5071 /* && (!rx->check_substr
5072 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5074 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5075 1 /* minend */, sv, NULL, 0))
5077 TAINT_IF(RX_MATCH_TAINTED(rx));
5078 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5083 strend = s + (strend - m);
5085 m = rx->startp[0] + orig;
5086 dstr = NEWSV(32, m-s);
5087 sv_setpvn(dstr, s, m-s);
5092 for (i = 1; i <= rx->nparens; i++) {
5093 s = rx->startp[i] + orig;
5094 m = rx->endp[i] + orig;
5096 dstr = NEWSV(33, m-s);
5097 sv_setpvn(dstr, s, m-s);
5100 dstr = NEWSV(33, 0);
5106 s = rx->endp[0] + orig;
5110 LEAVE_SCOPE(oldsave);
5111 iters = (SP - PL_stack_base) - base;
5112 if (iters > maxiters)
5113 DIE(aTHX_ "Split loop");
5115 /* keep field after final delim? */
5116 if (s < strend || (iters && origlimit)) {
5117 dstr = NEWSV(34, strend-s);
5118 sv_setpvn(dstr, s, strend-s);
5124 else if (!origlimit) {
5125 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5131 SWITCHSTACK(ary, oldstack);
5132 if (SvSMAGICAL(ary)) {
5137 if (gimme == G_ARRAY) {
5139 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5147 call_method("PUSH",G_SCALAR|G_DISCARD);
5150 if (gimme == G_ARRAY) {
5151 /* EXTEND should not be needed - we just popped them */
5153 for (i=0; i < iters; i++) {
5154 SV **svp = av_fetch(ary, i, FALSE);
5155 PUSHs((svp) ? *svp : &PL_sv_undef);
5162 if (gimme == G_ARRAY)
5165 if (iters || !pm->op_pmreplroot) {
5175 Perl_unlock_condpair(pTHX_ void *svv)
5178 MAGIC *mg = mg_find((SV*)svv, 'm');
5181 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5182 MUTEX_LOCK(MgMUTEXP(mg));
5183 if (MgOWNER(mg) != thr)
5184 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5186 COND_SIGNAL(MgOWNERCONDP(mg));
5187 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5188 (unsigned long)thr, (unsigned long)svv);)
5189 MUTEX_UNLOCK(MgMUTEXP(mg));
5191 #endif /* USE_THREADS */
5204 mg = condpair_magic(sv);
5205 MUTEX_LOCK(MgMUTEXP(mg));
5206 if (MgOWNER(mg) == thr)
5207 MUTEX_UNLOCK(MgMUTEXP(mg));
5210 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5212 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5213 (unsigned long)thr, (unsigned long)sv);)
5214 MUTEX_UNLOCK(MgMUTEXP(mg));
5215 SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
5217 #endif /* USE_THREADS */
5218 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5219 || SvTYPE(retsv) == SVt_PVCV) {
5220 retsv = refto(retsv);
5231 if (PL_op->op_private & OPpLVAL_INTRO)
5232 PUSHs(*save_threadsv(PL_op->op_targ));
5234 PUSHs(THREADSV(PL_op->op_targ));
5237 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5238 #endif /* USE_THREADS */