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);
905 SETn( left * right );
912 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
917 DIE(aTHX_ "Illegal division by zero");
919 /* insure that 20./5. == 4. */
922 if ((NV)I_V(left) == left &&
923 (NV)I_V(right) == right &&
924 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
928 value = left / right;
932 value = left / right;
941 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
951 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
953 right = (right_neg = (i < 0)) ? -i : i;
958 right_neg = dright < 0;
963 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
965 left = (left_neg = (i < 0)) ? -i : i;
973 left_neg = dleft < 0;
982 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
984 # define CAST_D2UV(d) U_V(d)
986 # define CAST_D2UV(d) ((UV)(d))
988 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
989 * or, in other words, precision of UV more than of NV.
990 * But in fact the approach below turned out to be an
991 * optimization - floor() may be slow */
992 if (dright <= UV_MAX && dleft <= UV_MAX) {
993 right = CAST_D2UV(dright);
994 left = CAST_D2UV(dleft);
999 /* Backward-compatibility clause: */
1000 dright = floor(dright + 0.5);
1001 dleft = floor(dleft + 0.5);
1004 DIE(aTHX_ "Illegal modulus zero");
1006 dans = Perl_fmod(dleft, dright);
1007 if ((left_neg != right_neg) && dans)
1008 dans = dright - dans;
1011 sv_setnv(TARG, dans);
1018 DIE(aTHX_ "Illegal modulus zero");
1021 if ((left_neg != right_neg) && ans)
1024 /* XXX may warn: unary minus operator applied to unsigned type */
1025 /* could change -foo to be (~foo)+1 instead */
1026 if (ans <= ~((UV)IV_MAX)+1)
1027 sv_setiv(TARG, ~ans+1);
1029 sv_setnv(TARG, -(NV)ans);
1032 sv_setuv(TARG, ans);
1041 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1043 register I32 count = POPi;
1044 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1046 I32 items = SP - MARK;
1049 max = items * count;
1058 repeatcpy((char*)(MARK + items), (char*)MARK,
1059 items * sizeof(SV*), count - 1);
1062 else if (count <= 0)
1065 else { /* Note: mark already snarfed by pp_list */
1070 SvSetSV(TARG, tmpstr);
1071 SvPV_force(TARG, len);
1076 SvGROW(TARG, (count * len) + 1);
1077 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1078 SvCUR(TARG) *= count;
1080 *SvEND(TARG) = '\0';
1082 (void)SvPOK_only(TARG);
1091 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1094 SETn( left - right );
1101 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1104 if (PL_op->op_private & HINT_INTEGER)
1105 SETi(TOPi << shift);
1107 SETu(TOPu << shift);
1114 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1117 if (PL_op->op_private & HINT_INTEGER)
1118 SETi(TOPi >> shift);
1120 SETu(TOPu >> shift);
1127 djSP; tryAMAGICbinSET(lt,0);
1130 SETs(boolSV(TOPn < value));
1137 djSP; tryAMAGICbinSET(gt,0);
1140 SETs(boolSV(TOPn > value));
1147 djSP; tryAMAGICbinSET(le,0);
1150 SETs(boolSV(TOPn <= value));
1157 djSP; tryAMAGICbinSET(ge,0);
1160 SETs(boolSV(TOPn >= value));
1167 djSP; tryAMAGICbinSET(ne,0);
1170 SETs(boolSV(TOPn != value));
1177 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1184 else if (left < right)
1186 else if (left > right)
1199 djSP; tryAMAGICbinSET(slt,0);
1202 int cmp = ((PL_op->op_private & OPpLOCALE)
1203 ? sv_cmp_locale(left, right)
1204 : sv_cmp(left, right));
1205 SETs(boolSV(cmp < 0));
1212 djSP; tryAMAGICbinSET(sgt,0);
1215 int cmp = ((PL_op->op_private & OPpLOCALE)
1216 ? sv_cmp_locale(left, right)
1217 : sv_cmp(left, right));
1218 SETs(boolSV(cmp > 0));
1225 djSP; tryAMAGICbinSET(sle,0);
1228 int cmp = ((PL_op->op_private & OPpLOCALE)
1229 ? sv_cmp_locale(left, right)
1230 : sv_cmp(left, right));
1231 SETs(boolSV(cmp <= 0));
1238 djSP; tryAMAGICbinSET(sge,0);
1241 int cmp = ((PL_op->op_private & OPpLOCALE)
1242 ? sv_cmp_locale(left, right)
1243 : sv_cmp(left, right));
1244 SETs(boolSV(cmp >= 0));
1251 djSP; tryAMAGICbinSET(seq,0);
1254 SETs(boolSV(sv_eq(left, right)));
1261 djSP; tryAMAGICbinSET(sne,0);
1264 SETs(boolSV(!sv_eq(left, right)));
1271 djSP; dTARGET; tryAMAGICbin(scmp,0);
1274 int cmp = ((PL_op->op_private & OPpLOCALE)
1275 ? sv_cmp_locale(left, right)
1276 : sv_cmp(left, right));
1284 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1287 if (SvNIOKp(left) || SvNIOKp(right)) {
1288 if (PL_op->op_private & HINT_INTEGER)
1289 SETi( SvIV(left) & SvIV(right) );
1291 SETu( SvUV(left) & SvUV(right) );
1294 do_vop(PL_op->op_type, TARG, left, right);
1303 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1306 if (SvNIOKp(left) || SvNIOKp(right)) {
1307 if (PL_op->op_private & HINT_INTEGER)
1308 SETi( (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right) );
1310 SETu( (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right) );
1313 do_vop(PL_op->op_type, TARG, left, right);
1322 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1325 if (SvNIOKp(left) || SvNIOKp(right)) {
1326 if (PL_op->op_private & HINT_INTEGER)
1327 SETi( (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right) );
1329 SETu( (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right) );
1332 do_vop(PL_op->op_type, TARG, left, right);
1341 djSP; dTARGET; tryAMAGICun(neg);
1346 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1348 else if (SvNIOKp(sv))
1350 else if (SvPOKp(sv)) {
1352 char *s = SvPV(sv, len);
1353 if (isIDFIRST(*s)) {
1354 sv_setpvn(TARG, "-", 1);
1357 else if (*s == '+' || *s == '-') {
1359 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1361 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1362 sv_setpvn(TARG, "-", 1);
1366 sv_setnv(TARG, -SvNV(sv));
1377 djSP; tryAMAGICunSET(not);
1378 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1384 djSP; dTARGET; tryAMAGICun(compl);
1388 if (PL_op->op_private & HINT_INTEGER)
1394 register char *tmps;
1395 register long *tmpl;
1400 tmps = SvPV_force(TARG, len);
1403 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1406 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1410 for ( ; anum > 0; anum--, tmps++)
1419 /* integer versions of some of the above */
1423 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1426 SETi( left * right );
1433 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1437 DIE(aTHX_ "Illegal division by zero");
1438 value = POPi / value;
1446 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1450 DIE(aTHX_ "Illegal modulus zero");
1451 SETi( left % right );
1458 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1461 SETi( left + right );
1468 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1471 SETi( left - right );
1478 djSP; tryAMAGICbinSET(lt,0);
1481 SETs(boolSV(left < right));
1488 djSP; tryAMAGICbinSET(gt,0);
1491 SETs(boolSV(left > right));
1498 djSP; tryAMAGICbinSET(le,0);
1501 SETs(boolSV(left <= right));
1508 djSP; tryAMAGICbinSET(ge,0);
1511 SETs(boolSV(left >= right));
1518 djSP; tryAMAGICbinSET(eq,0);
1521 SETs(boolSV(left == right));
1528 djSP; tryAMAGICbinSET(ne,0);
1531 SETs(boolSV(left != right));
1538 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1545 else if (left < right)
1556 djSP; dTARGET; tryAMAGICun(neg);
1561 /* High falutin' math. */
1565 djSP; dTARGET; tryAMAGICbin(atan2,0);
1568 SETn(Perl_atan2(left, right));
1575 djSP; dTARGET; tryAMAGICun(sin);
1579 value = Perl_sin(value);
1587 djSP; dTARGET; tryAMAGICun(cos);
1591 value = Perl_cos(value);
1597 /* Support Configure command-line overrides for rand() functions.
1598 After 5.005, perhaps we should replace this by Configure support
1599 for drand48(), random(), or rand(). For 5.005, though, maintain
1600 compatibility by calling rand() but allow the user to override it.
1601 See INSTALL for details. --Andy Dougherty 15 July 1998
1603 /* Now it's after 5.005, and Configure supports drand48() and random(),
1604 in addition to rand(). So the overrides should not be needed any more.
1605 --Jarkko Hietaniemi 27 September 1998
1608 #ifndef HAS_DRAND48_PROTO
1609 extern double drand48 (void);
1622 if (!PL_srand_called) {
1623 (void)seedDrand01((Rand_seed_t)seed());
1624 PL_srand_called = TRUE;
1639 (void)seedDrand01((Rand_seed_t)anum);
1640 PL_srand_called = TRUE;
1649 * This is really just a quick hack which grabs various garbage
1650 * values. It really should be a real hash algorithm which
1651 * spreads the effect of every input bit onto every output bit,
1652 * if someone who knows about such things would bother to write it.
1653 * Might be a good idea to add that function to CORE as well.
1654 * No numbers below come from careful analysis or anything here,
1655 * except they are primes and SEED_C1 > 1E6 to get a full-width
1656 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1657 * probably be bigger too.
1660 # define SEED_C1 1000003
1661 #define SEED_C4 73819
1663 # define SEED_C1 25747
1664 #define SEED_C4 20639
1668 #define SEED_C5 26107
1671 #ifndef PERL_NO_DEV_RANDOM
1676 # include <starlet.h>
1677 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1678 * in 100-ns units, typically incremented ever 10 ms. */
1679 unsigned int when[2];
1681 # ifdef HAS_GETTIMEOFDAY
1682 struct timeval when;
1688 /* This test is an escape hatch, this symbol isn't set by Configure. */
1689 #ifndef PERL_NO_DEV_RANDOM
1690 #ifndef PERL_RANDOM_DEVICE
1691 /* /dev/random isn't used by default because reads from it will block
1692 * if there isn't enough entropy available. You can compile with
1693 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1694 * is enough real entropy to fill the seed. */
1695 # define PERL_RANDOM_DEVICE "/dev/urandom"
1697 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1699 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1708 _ckvmssts(sys$gettim(when));
1709 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1711 # ifdef HAS_GETTIMEOFDAY
1712 gettimeofday(&when,(struct timezone *) 0);
1713 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1716 u = (U32)SEED_C1 * when;
1719 u += SEED_C3 * (U32)getpid();
1720 u += SEED_C4 * (U32)(UV)PL_stack_sp;
1721 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1722 u += SEED_C5 * (U32)(UV)&when;
1729 djSP; dTARGET; tryAMAGICun(exp);
1733 value = Perl_exp(value);
1741 djSP; dTARGET; tryAMAGICun(log);
1746 RESTORE_NUMERIC_STANDARD();
1747 DIE(aTHX_ "Can't take log of %g", value);
1749 value = Perl_log(value);
1757 djSP; dTARGET; tryAMAGICun(sqrt);
1762 RESTORE_NUMERIC_STANDARD();
1763 DIE(aTHX_ "Can't take sqrt of %g", value);
1765 value = Perl_sqrt(value);
1778 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1784 (void)Perl_modf(value, &value);
1786 (void)Perl_modf(-value, &value);
1801 djSP; dTARGET; tryAMAGICun(abs);
1806 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1807 (iv = SvIVX(TOPs)) != IV_MIN) {
1829 XPUSHn(scan_hex(tmps, 99, &argtype));
1842 while (*tmps && isSPACE(*tmps))
1847 value = scan_hex(++tmps, 99, &argtype);
1848 else if (*tmps == 'b')
1849 value = scan_bin(++tmps, 99, &argtype);
1851 value = scan_oct(tmps, 99, &argtype);
1863 SETi( sv_len_utf8(TOPs) );
1867 SETi( sv_len(TOPs) );
1881 I32 lvalue = PL_op->op_flags & OPf_MOD;
1883 I32 arybase = PL_curcop->cop_arybase;
1887 SvTAINTED_off(TARG); /* decontaminate */
1891 repl = SvPV(sv, repl_len);
1898 tmps = SvPV(sv, curlen);
1900 utfcurlen = sv_len_utf8(sv);
1901 if (utfcurlen == curlen)
1909 if (pos >= arybase) {
1927 else if (len >= 0) {
1929 if (rem > (I32)curlen)
1943 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
1944 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
1949 sv_pos_u2b(sv, &pos, &rem);
1951 sv_setpvn(TARG, tmps, rem);
1952 if (lvalue) { /* it's an lvalue! */
1953 if (!SvGMAGICAL(sv)) {
1957 if (ckWARN(WARN_SUBSTR))
1958 Perl_warner(aTHX_ WARN_SUBSTR,
1959 "Attempt to use reference as lvalue in substr");
1961 if (SvOK(sv)) /* is it defined ? */
1962 (void)SvPOK_only(sv);
1964 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1967 if (SvTYPE(TARG) < SVt_PVLV) {
1968 sv_upgrade(TARG, SVt_PVLV);
1969 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1973 if (LvTARG(TARG) != sv) {
1975 SvREFCNT_dec(LvTARG(TARG));
1976 LvTARG(TARG) = SvREFCNT_inc(sv);
1978 LvTARGOFF(TARG) = pos;
1979 LvTARGLEN(TARG) = rem;
1982 sv_insert(sv, pos, rem, repl, repl_len);
1985 PUSHs(TARG); /* avoid SvSETMAGIC here */
1992 register I32 size = POPi;
1993 register I32 offset = POPi;
1994 register SV *src = POPs;
1995 I32 lvalue = PL_op->op_flags & OPf_MOD;
1997 SvTAINTED_off(TARG); /* decontaminate */
1998 if (lvalue) { /* it's an lvalue! */
1999 if (SvTYPE(TARG) < SVt_PVLV) {
2000 sv_upgrade(TARG, SVt_PVLV);
2001 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2004 if (LvTARG(TARG) != src) {
2006 SvREFCNT_dec(LvTARG(TARG));
2007 LvTARG(TARG) = SvREFCNT_inc(src);
2009 LvTARGOFF(TARG) = offset;
2010 LvTARGLEN(TARG) = size;
2013 sv_setuv(TARG, do_vecget(src, offset, size));
2028 I32 arybase = PL_curcop->cop_arybase;
2033 offset = POPi - arybase;
2036 tmps = SvPV(big, biglen);
2037 if (IN_UTF8 && offset > 0)
2038 sv_pos_u2b(big, &offset, 0);
2041 else if (offset > biglen)
2043 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2044 (unsigned char*)tmps + biglen, little, 0)))
2047 retval = tmps2 - tmps;
2048 if (IN_UTF8 && retval > 0)
2049 sv_pos_b2u(big, &retval);
2050 PUSHi(retval + arybase);
2065 I32 arybase = PL_curcop->cop_arybase;
2071 tmps2 = SvPV(little, llen);
2072 tmps = SvPV(big, blen);
2076 if (IN_UTF8 && offset > 0)
2077 sv_pos_u2b(big, &offset, 0);
2078 offset = offset - arybase + llen;
2082 else if (offset > blen)
2084 if (!(tmps2 = rninstr(tmps, tmps + offset,
2085 tmps2, tmps2 + llen)))
2088 retval = tmps2 - tmps;
2089 if (IN_UTF8 && retval > 0)
2090 sv_pos_b2u(big, &retval);
2091 PUSHi(retval + arybase);
2097 djSP; dMARK; dORIGMARK; dTARGET;
2098 do_sprintf(TARG, SP-MARK, MARK+1);
2099 TAINT_IF(SvTAINTED(TARG));
2110 U8 *tmps = (U8*)POPpx;
2113 if (IN_UTF8 && (*tmps & 0x80))
2114 value = utf8_to_uv(tmps, &retlen);
2116 value = (UV)(*tmps & 255);
2127 (void)SvUPGRADE(TARG,SVt_PV);
2129 if (IN_UTF8 && value >= 128) {
2132 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2133 SvCUR_set(TARG, tmps - SvPVX(TARG));
2135 (void)SvPOK_only(TARG);
2145 (void)SvPOK_only(TARG);
2152 djSP; dTARGET; dPOPTOPssrl;
2155 char *tmps = SvPV(left, n_a);
2157 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2159 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2163 "The crypt() function is unimplemented due to excessive paranoia.");
2176 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2180 UV uv = utf8_to_uv(s, &ulen);
2182 if (PL_op->op_private & OPpLOCALE) {
2185 uv = toTITLE_LC_uni(uv);
2188 uv = toTITLE_utf8(s);
2190 tend = uv_to_utf8(tmpbuf, uv);
2192 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2194 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2195 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2199 s = (U8*)SvPV_force(sv, slen);
2200 Copy(tmpbuf, s, ulen, U8);
2204 if (!SvPADTMP(sv)) {
2210 s = (U8*)SvPV_force(sv, slen);
2212 if (PL_op->op_private & OPpLOCALE) {
2215 *s = toUPPER_LC(*s);
2233 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2237 UV uv = utf8_to_uv(s, &ulen);
2239 if (PL_op->op_private & OPpLOCALE) {
2242 uv = toLOWER_LC_uni(uv);
2245 uv = toLOWER_utf8(s);
2247 tend = uv_to_utf8(tmpbuf, uv);
2249 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2251 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2252 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2256 s = (U8*)SvPV_force(sv, slen);
2257 Copy(tmpbuf, s, ulen, U8);
2261 if (!SvPADTMP(sv)) {
2267 s = (U8*)SvPV_force(sv, slen);
2269 if (PL_op->op_private & OPpLOCALE) {
2272 *s = toLOWER_LC(*s);
2297 s = (U8*)SvPV(sv,len);
2299 sv_setpvn(TARG, "", 0);
2303 (void)SvUPGRADE(TARG, SVt_PV);
2304 SvGROW(TARG, (len * 2) + 1);
2305 (void)SvPOK_only(TARG);
2306 d = (U8*)SvPVX(TARG);
2308 if (PL_op->op_private & OPpLOCALE) {
2312 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2318 d = uv_to_utf8(d, toUPPER_utf8( s ));
2323 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2328 if (!SvPADTMP(sv)) {
2334 s = (U8*)SvPV_force(sv, len);
2336 register U8 *send = s + len;
2338 if (PL_op->op_private & OPpLOCALE) {
2341 for (; s < send; s++)
2342 *s = toUPPER_LC(*s);
2345 for (; s < send; s++)
2368 s = (U8*)SvPV(sv,len);
2370 sv_setpvn(TARG, "", 0);
2374 (void)SvUPGRADE(TARG, SVt_PV);
2375 SvGROW(TARG, (len * 2) + 1);
2376 (void)SvPOK_only(TARG);
2377 d = (U8*)SvPVX(TARG);
2379 if (PL_op->op_private & OPpLOCALE) {
2383 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2389 d = uv_to_utf8(d, toLOWER_utf8(s));
2394 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2399 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 = toLOWER_LC(*s);
2417 for (; s < send; s++)
2432 register char *s = SvPV(sv,len);
2436 (void)SvUPGRADE(TARG, SVt_PV);
2437 SvGROW(TARG, (len * 2) + 1);
2442 STRLEN ulen = UTF8SKIP(s);
2465 SvCUR_set(TARG, d - SvPVX(TARG));
2466 (void)SvPOK_only(TARG);
2469 sv_setpvn(TARG, s, len);
2471 if (SvSMAGICAL(TARG))
2480 djSP; dMARK; dORIGMARK;
2482 register AV* av = (AV*)POPs;
2483 register I32 lval = PL_op->op_flags & OPf_MOD;
2484 I32 arybase = PL_curcop->cop_arybase;
2487 if (SvTYPE(av) == SVt_PVAV) {
2488 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2490 for (svp = MARK + 1; svp <= SP; svp++) {
2495 if (max > AvMAX(av))
2498 while (++MARK <= SP) {
2499 elem = SvIVx(*MARK);
2503 svp = av_fetch(av, elem, lval);
2505 if (!svp || *svp == &PL_sv_undef)
2506 DIE(aTHX_ PL_no_aelem, elem);
2507 if (PL_op->op_private & OPpLVAL_INTRO)
2508 save_aelem(av, elem, svp);
2510 *MARK = svp ? *svp : &PL_sv_undef;
2513 if (GIMME != G_ARRAY) {
2521 /* Associative arrays. */
2526 HV *hash = (HV*)POPs;
2528 I32 gimme = GIMME_V;
2529 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2532 /* might clobber stack_sp */
2533 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2538 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2539 if (gimme == G_ARRAY) {
2542 /* might clobber stack_sp */
2544 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2549 else if (gimme == G_SCALAR)
2568 I32 gimme = GIMME_V;
2569 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2573 if (PL_op->op_private & OPpSLICE) {
2577 hvtype = SvTYPE(hv);
2578 while (++MARK <= SP) {
2579 if (hvtype == SVt_PVHV)
2580 sv = hv_delete_ent(hv, *MARK, discard, 0);
2582 DIE(aTHX_ "Not a HASH reference");
2583 *MARK = sv ? sv : &PL_sv_undef;
2587 else if (gimme == G_SCALAR) {
2596 if (SvTYPE(hv) == SVt_PVHV)
2597 sv = hv_delete_ent(hv, keysv, discard, 0);
2599 DIE(aTHX_ "Not a HASH reference");
2613 if (SvTYPE(hv) == SVt_PVHV) {
2614 if (hv_exists_ent(hv, tmpsv, 0))
2617 else if (SvTYPE(hv) == SVt_PVAV) {
2618 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2622 DIE(aTHX_ "Not a HASH reference");
2629 djSP; dMARK; dORIGMARK;
2630 register HV *hv = (HV*)POPs;
2631 register I32 lval = PL_op->op_flags & OPf_MOD;
2632 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2634 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2635 DIE(aTHX_ "Can't localize pseudo-hash element");
2637 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2638 while (++MARK <= SP) {
2642 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2643 svp = he ? &HeVAL(he) : 0;
2646 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2649 if (!svp || *svp == &PL_sv_undef) {
2651 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2653 if (PL_op->op_private & OPpLVAL_INTRO)
2654 save_helem(hv, keysv, svp);
2656 *MARK = svp ? *svp : &PL_sv_undef;
2659 if (GIMME != G_ARRAY) {
2667 /* List operators. */
2672 if (GIMME != G_ARRAY) {
2674 *MARK = *SP; /* unwanted list, return last item */
2676 *MARK = &PL_sv_undef;
2685 SV **lastrelem = PL_stack_sp;
2686 SV **lastlelem = PL_stack_base + POPMARK;
2687 SV **firstlelem = PL_stack_base + POPMARK + 1;
2688 register SV **firstrelem = lastlelem + 1;
2689 I32 arybase = PL_curcop->cop_arybase;
2690 I32 lval = PL_op->op_flags & OPf_MOD;
2691 I32 is_something_there = lval;
2693 register I32 max = lastrelem - lastlelem;
2694 register SV **lelem;
2697 if (GIMME != G_ARRAY) {
2698 ix = SvIVx(*lastlelem);
2703 if (ix < 0 || ix >= max)
2704 *firstlelem = &PL_sv_undef;
2706 *firstlelem = firstrelem[ix];
2712 SP = firstlelem - 1;
2716 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2722 if (ix < 0 || ix >= max)
2723 *lelem = &PL_sv_undef;
2725 is_something_there = TRUE;
2726 if (!(*lelem = firstrelem[ix]))
2727 *lelem = &PL_sv_undef;
2730 if (is_something_there)
2733 SP = firstlelem - 1;
2739 djSP; dMARK; dORIGMARK;
2740 I32 items = SP - MARK;
2741 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2742 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2749 djSP; dMARK; dORIGMARK;
2750 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2754 SV *val = NEWSV(46, 0);
2756 sv_setsv(val, *++MARK);
2757 else if (ckWARN(WARN_UNSAFE))
2758 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2759 (void)hv_store_ent(hv,key,val,0);
2768 djSP; dMARK; dORIGMARK;
2769 register AV *ary = (AV*)*++MARK;
2773 register I32 offset;
2774 register I32 length;
2781 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2782 *MARK-- = SvTIED_obj((SV*)ary, mg);
2786 call_method("SPLICE",GIMME_V);
2795 offset = i = SvIVx(*MARK);
2797 offset += AvFILLp(ary) + 1;
2799 offset -= PL_curcop->cop_arybase;
2801 DIE(aTHX_ PL_no_aelem, i);
2803 length = SvIVx(*MARK++);
2805 length += AvFILLp(ary) - offset + 1;
2811 length = AvMAX(ary) + 1; /* close enough to infinity */
2815 length = AvMAX(ary) + 1;
2817 if (offset > AvFILLp(ary) + 1)
2818 offset = AvFILLp(ary) + 1;
2819 after = AvFILLp(ary) + 1 - (offset + length);
2820 if (after < 0) { /* not that much array */
2821 length += after; /* offset+length now in array */
2827 /* At this point, MARK .. SP-1 is our new LIST */
2830 diff = newlen - length;
2831 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2834 if (diff < 0) { /* shrinking the area */
2836 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2837 Copy(MARK, tmparyval, newlen, SV*);
2840 MARK = ORIGMARK + 1;
2841 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2842 MEXTEND(MARK, length);
2843 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2845 EXTEND_MORTAL(length);
2846 for (i = length, dst = MARK; i; i--) {
2847 sv_2mortal(*dst); /* free them eventualy */
2854 *MARK = AvARRAY(ary)[offset+length-1];
2857 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2858 SvREFCNT_dec(*dst++); /* free them now */
2861 AvFILLp(ary) += diff;
2863 /* pull up or down? */
2865 if (offset < after) { /* easier to pull up */
2866 if (offset) { /* esp. if nothing to pull */
2867 src = &AvARRAY(ary)[offset-1];
2868 dst = src - diff; /* diff is negative */
2869 for (i = offset; i > 0; i--) /* can't trust Copy */
2873 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2877 if (after) { /* anything to pull down? */
2878 src = AvARRAY(ary) + offset + length;
2879 dst = src + diff; /* diff is negative */
2880 Move(src, dst, after, SV*);
2882 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2883 /* avoid later double free */
2887 dst[--i] = &PL_sv_undef;
2890 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2892 *dst = NEWSV(46, 0);
2893 sv_setsv(*dst++, *src++);
2895 Safefree(tmparyval);
2898 else { /* no, expanding (or same) */
2900 New(452, tmparyval, length, SV*); /* so remember deletion */
2901 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2904 if (diff > 0) { /* expanding */
2906 /* push up or down? */
2908 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2912 Move(src, dst, offset, SV*);
2914 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2916 AvFILLp(ary) += diff;
2919 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2920 av_extend(ary, AvFILLp(ary) + diff);
2921 AvFILLp(ary) += diff;
2924 dst = AvARRAY(ary) + AvFILLp(ary);
2926 for (i = after; i; i--) {
2933 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2934 *dst = NEWSV(46, 0);
2935 sv_setsv(*dst++, *src++);
2937 MARK = ORIGMARK + 1;
2938 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2940 Copy(tmparyval, MARK, length, SV*);
2942 EXTEND_MORTAL(length);
2943 for (i = length, dst = MARK; i; i--) {
2944 sv_2mortal(*dst); /* free them eventualy */
2948 Safefree(tmparyval);
2952 else if (length--) {
2953 *MARK = tmparyval[length];
2956 while (length-- > 0)
2957 SvREFCNT_dec(tmparyval[length]);
2959 Safefree(tmparyval);
2962 *MARK = &PL_sv_undef;
2970 djSP; dMARK; dORIGMARK; dTARGET;
2971 register AV *ary = (AV*)*++MARK;
2972 register SV *sv = &PL_sv_undef;
2975 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2976 *MARK-- = SvTIED_obj((SV*)ary, mg);
2980 call_method("PUSH",G_SCALAR|G_DISCARD);
2985 /* Why no pre-extend of ary here ? */
2986 for (++MARK; MARK <= SP; MARK++) {
2989 sv_setsv(sv, *MARK);
2994 PUSHi( AvFILL(ary) + 1 );
3002 SV *sv = av_pop(av);
3004 (void)sv_2mortal(sv);
3013 SV *sv = av_shift(av);
3018 (void)sv_2mortal(sv);
3025 djSP; dMARK; dORIGMARK; dTARGET;
3026 register AV *ary = (AV*)*++MARK;
3031 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3032 *MARK-- = SvTIED_obj((SV*)ary, mg);
3036 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3041 av_unshift(ary, SP - MARK);
3044 sv_setsv(sv, *++MARK);
3045 (void)av_store(ary, i++, sv);
3049 PUSHi( AvFILL(ary) + 1 );
3059 if (GIMME == G_ARRAY) {
3070 register char *down;
3076 do_join(TARG, &PL_sv_no, MARK, SP);
3078 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3079 up = SvPV_force(TARG, len);
3081 if (IN_UTF8) { /* first reverse each character */
3082 U8* s = (U8*)SvPVX(TARG);
3083 U8* send = (U8*)(s + len);
3092 down = (char*)(s - 1);
3093 if (s > send || !((*down & 0xc0) == 0x80)) {
3094 if (ckWARN_d(WARN_UTF8))
3095 Perl_warner(aTHX_ WARN_UTF8,
3096 "Malformed UTF-8 character");
3108 down = SvPVX(TARG) + len - 1;
3114 (void)SvPOK_only(TARG);
3123 S_mul128(pTHX_ SV *sv, U8 m)
3126 char *s = SvPV(sv, len);
3130 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3131 SV *tmpNew = newSVpvn("0000000000", 10);
3133 sv_catsv(tmpNew, sv);
3134 SvREFCNT_dec(sv); /* free old sv */
3139 while (!*t) /* trailing '\0'? */
3142 i = ((*t - '0') << 7) + m;
3143 *(t--) = '0' + (i % 10);
3149 /* Explosives and implosives. */
3151 #if 'I' == 73 && 'J' == 74
3152 /* On an ASCII/ISO kind of system */
3153 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3156 Some other sort of character set - use memchr() so we don't match
3159 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3167 I32 gimme = GIMME_V;
3171 register char *pat = SvPV(left, llen);
3172 register char *s = SvPV(right, rlen);
3173 char *strend = s + rlen;
3175 register char *patend = pat + llen;
3180 /* These must not be in registers: */
3197 register U32 culong;
3200 #ifdef PERL_NATINT_PACK
3201 int natint; /* native integer */
3202 int unatint; /* unsigned native integer */
3205 if (gimme != G_ARRAY) { /* arrange to do first one only */
3207 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3208 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3210 while (isDIGIT(*patend) || *patend == '*')
3216 while (pat < patend) {
3218 datumtype = *pat++ & 0xFF;
3219 #ifdef PERL_NATINT_PACK
3222 if (isSPACE(datumtype))
3225 char *natstr = "sSiIlL";
3227 if (strchr(natstr, datumtype)) {
3228 #ifdef PERL_NATINT_PACK
3234 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
3238 else if (*pat == '*') {
3239 len = strend - strbeg; /* long enough */
3242 else if (isDIGIT(*pat)) {
3244 while (isDIGIT(*pat)) {
3245 len = (len * 10) + (*pat++ - '0');
3247 Perl_croak(aTHX_ "Repeat count in unpack overflows");
3251 len = (datumtype != '@');
3254 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3255 case ',': /* grandfather in commas but with a warning */
3256 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3257 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
3260 if (len == 1 && pat[-1] != '1')
3269 if (len > strend - strbeg)
3270 DIE(aTHX_ "@ outside of string");
3274 if (len > s - strbeg)
3275 DIE(aTHX_ "X outside of string");
3279 if (len > strend - s)
3280 DIE(aTHX_ "x outside of string");
3285 DIE(aTHX_ "# must follow a numeric type");
3286 if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
3287 DIE(aTHX_ "# must be followed by a, A or Z");
3290 pat++; /* ignore '*' for compatibility with pack */
3292 DIE(aTHX_ "# cannot take a count" );
3298 if (len > strend - s)
3301 goto uchar_checksum;
3302 sv = NEWSV(35, len);
3303 sv_setpvn(sv, s, len);
3305 if (datumtype == 'A' || datumtype == 'Z') {
3306 aptr = s; /* borrow register */
3307 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3312 else { /* 'A' strips both nulls and spaces */
3313 s = SvPVX(sv) + len - 1;
3314 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3318 SvCUR_set(sv, s - SvPVX(sv));
3319 s = aptr; /* unborrow register */
3321 XPUSHs(sv_2mortal(sv));
3325 if (pat[-1] == '*' || len > (strend - s) * 8)
3326 len = (strend - s) * 8;
3329 Newz(601, PL_bitcount, 256, char);
3330 for (bits = 1; bits < 256; bits++) {
3331 if (bits & 1) PL_bitcount[bits]++;
3332 if (bits & 2) PL_bitcount[bits]++;
3333 if (bits & 4) PL_bitcount[bits]++;
3334 if (bits & 8) PL_bitcount[bits]++;
3335 if (bits & 16) PL_bitcount[bits]++;
3336 if (bits & 32) PL_bitcount[bits]++;
3337 if (bits & 64) PL_bitcount[bits]++;
3338 if (bits & 128) PL_bitcount[bits]++;
3342 culong += PL_bitcount[*(unsigned char*)s++];
3347 if (datumtype == 'b') {
3349 if (bits & 1) culong++;
3355 if (bits & 128) culong++;
3362 sv = NEWSV(35, len + 1);
3365 aptr = pat; /* borrow register */
3367 if (datumtype == 'b') {
3369 for (len = 0; len < aint; len++) {
3370 if (len & 7) /*SUPPRESS 595*/
3374 *pat++ = '0' + (bits & 1);
3379 for (len = 0; len < aint; len++) {
3384 *pat++ = '0' + ((bits & 128) != 0);
3388 pat = aptr; /* unborrow register */
3389 XPUSHs(sv_2mortal(sv));
3393 if (pat[-1] == '*' || len > (strend - s) * 2)
3394 len = (strend - s) * 2;
3395 sv = NEWSV(35, len + 1);
3398 aptr = pat; /* borrow register */
3400 if (datumtype == 'h') {
3402 for (len = 0; len < aint; len++) {
3407 *pat++ = PL_hexdigit[bits & 15];
3412 for (len = 0; len < aint; len++) {
3417 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3421 pat = aptr; /* unborrow register */
3422 XPUSHs(sv_2mortal(sv));
3425 if (len > strend - s)
3430 if (aint >= 128) /* fake up signed chars */
3440 if (aint >= 128) /* fake up signed chars */
3443 sv_setiv(sv, (IV)aint);
3444 PUSHs(sv_2mortal(sv));
3449 if (len > strend - s)
3464 sv_setiv(sv, (IV)auint);
3465 PUSHs(sv_2mortal(sv));
3470 if (len > strend - s)
3473 while (len-- > 0 && s < strend) {
3474 auint = utf8_to_uv((U8*)s, &along);
3477 cdouble += (NV)auint;
3485 while (len-- > 0 && s < strend) {
3486 auint = utf8_to_uv((U8*)s, &along);
3489 sv_setuv(sv, (UV)auint);
3490 PUSHs(sv_2mortal(sv));
3495 #if SHORTSIZE == SIZE16
3496 along = (strend - s) / SIZE16;
3498 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3503 #if SHORTSIZE != SIZE16
3507 COPYNN(s, &ashort, sizeof(short));
3518 #if SHORTSIZE > SIZE16
3530 #if SHORTSIZE != SIZE16
3534 COPYNN(s, &ashort, sizeof(short));
3537 sv_setiv(sv, (IV)ashort);
3538 PUSHs(sv_2mortal(sv));
3546 #if SHORTSIZE > SIZE16
3552 sv_setiv(sv, (IV)ashort);
3553 PUSHs(sv_2mortal(sv));
3561 #if SHORTSIZE == SIZE16
3562 along = (strend - s) / SIZE16;
3564 unatint = natint && datumtype == 'S';
3565 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3570 #if SHORTSIZE != SIZE16
3572 unsigned short aushort;
3574 COPYNN(s, &aushort, sizeof(unsigned short));
3575 s += sizeof(unsigned short);
3583 COPY16(s, &aushort);
3586 if (datumtype == 'n')
3587 aushort = PerlSock_ntohs(aushort);
3590 if (datumtype == 'v')
3591 aushort = vtohs(aushort);
3600 #if SHORTSIZE != SIZE16
3602 unsigned short aushort;
3604 COPYNN(s, &aushort, sizeof(unsigned short));
3605 s += sizeof(unsigned short);
3607 sv_setiv(sv, (UV)aushort);
3608 PUSHs(sv_2mortal(sv));
3615 COPY16(s, &aushort);
3619 if (datumtype == 'n')
3620 aushort = PerlSock_ntohs(aushort);
3623 if (datumtype == 'v')
3624 aushort = vtohs(aushort);
3626 sv_setiv(sv, (UV)aushort);
3627 PUSHs(sv_2mortal(sv));
3633 along = (strend - s) / sizeof(int);
3638 Copy(s, &aint, 1, int);
3641 cdouble += (NV)aint;
3650 Copy(s, &aint, 1, int);
3654 /* Without the dummy below unpack("i", pack("i",-1))
3655 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3656 * cc with optimization turned on.
3658 * The bug was detected in
3659 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3660 * with optimization (-O4) turned on.
3661 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3662 * does not have this problem even with -O4.
3664 * This bug was reported as DECC_BUGS 1431
3665 * and tracked internally as GEM_BUGS 7775.
3667 * The bug is fixed in
3668 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3669 * UNIX V4.0F support: DEC C V5.9-006 or later
3670 * UNIX V4.0E support: DEC C V5.8-011 or later
3673 * See also few lines later for the same bug.
3676 sv_setiv(sv, (IV)aint) :
3678 sv_setiv(sv, (IV)aint);
3679 PUSHs(sv_2mortal(sv));
3684 along = (strend - s) / sizeof(unsigned int);
3689 Copy(s, &auint, 1, unsigned int);
3690 s += sizeof(unsigned int);
3692 cdouble += (NV)auint;
3701 Copy(s, &auint, 1, unsigned int);
3702 s += sizeof(unsigned int);
3705 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3706 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3707 * See details few lines earlier. */
3709 sv_setuv(sv, (UV)auint) :
3711 sv_setuv(sv, (UV)auint);
3712 PUSHs(sv_2mortal(sv));
3717 #if LONGSIZE == SIZE32
3718 along = (strend - s) / SIZE32;
3720 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3725 #if LONGSIZE != SIZE32
3729 COPYNN(s, &along, sizeof(long));
3732 cdouble += (NV)along;
3742 #if LONGSIZE > SIZE32
3743 if (along > 2147483647)
3744 along -= 4294967296;
3748 cdouble += (NV)along;
3757 #if LONGSIZE != SIZE32
3761 COPYNN(s, &along, sizeof(long));
3764 sv_setiv(sv, (IV)along);
3765 PUSHs(sv_2mortal(sv));
3773 #if LONGSIZE > SIZE32
3774 if (along > 2147483647)
3775 along -= 4294967296;
3779 sv_setiv(sv, (IV)along);
3780 PUSHs(sv_2mortal(sv));
3788 #if LONGSIZE == SIZE32
3789 along = (strend - s) / SIZE32;
3791 unatint = natint && datumtype == 'L';
3792 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3797 #if LONGSIZE != SIZE32
3799 unsigned long aulong;
3801 COPYNN(s, &aulong, sizeof(unsigned long));
3802 s += sizeof(unsigned long);
3804 cdouble += (NV)aulong;
3816 if (datumtype == 'N')
3817 aulong = PerlSock_ntohl(aulong);
3820 if (datumtype == 'V')
3821 aulong = vtohl(aulong);
3824 cdouble += (NV)aulong;
3833 #if LONGSIZE != SIZE32
3835 unsigned long aulong;
3837 COPYNN(s, &aulong, sizeof(unsigned long));
3838 s += sizeof(unsigned long);
3840 sv_setuv(sv, (UV)aulong);
3841 PUSHs(sv_2mortal(sv));
3851 if (datumtype == 'N')
3852 aulong = PerlSock_ntohl(aulong);
3855 if (datumtype == 'V')
3856 aulong = vtohl(aulong);
3859 sv_setuv(sv, (UV)aulong);
3860 PUSHs(sv_2mortal(sv));
3866 along = (strend - s) / sizeof(char*);
3872 if (sizeof(char*) > strend - s)
3875 Copy(s, &aptr, 1, char*);
3881 PUSHs(sv_2mortal(sv));
3891 while ((len > 0) && (s < strend)) {
3892 auv = (auv << 7) | (*s & 0x7f);
3893 if (!(*s++ & 0x80)) {
3897 PUSHs(sv_2mortal(sv));
3901 else if (++bytes >= sizeof(UV)) { /* promote to string */
3905 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3906 while (s < strend) {
3907 sv = mul128(sv, *s & 0x7f);
3908 if (!(*s++ & 0x80)) {
3917 PUSHs(sv_2mortal(sv));
3922 if ((s >= strend) && bytes)
3923 Perl_croak(aTHX_ "Unterminated compressed integer");
3928 if (sizeof(char*) > strend - s)
3931 Copy(s, &aptr, 1, char*);
3936 sv_setpvn(sv, aptr, len);
3937 PUSHs(sv_2mortal(sv));
3941 along = (strend - s) / sizeof(Quad_t);
3947 if (s + sizeof(Quad_t) > strend)
3950 Copy(s, &aquad, 1, Quad_t);
3951 s += sizeof(Quad_t);
3954 if (aquad >= IV_MIN && aquad <= IV_MAX)
3955 sv_setiv(sv, (IV)aquad);
3957 sv_setnv(sv, (NV)aquad);
3958 PUSHs(sv_2mortal(sv));
3962 along = (strend - s) / sizeof(Quad_t);
3968 if (s + sizeof(Uquad_t) > strend)
3971 Copy(s, &auquad, 1, Uquad_t);
3972 s += sizeof(Uquad_t);
3975 if (auquad <= UV_MAX)
3976 sv_setuv(sv, (UV)auquad);
3978 sv_setnv(sv, (NV)auquad);
3979 PUSHs(sv_2mortal(sv));
3983 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3986 along = (strend - s) / sizeof(float);
3991 Copy(s, &afloat, 1, float);
4000 Copy(s, &afloat, 1, float);
4003 sv_setnv(sv, (NV)afloat);
4004 PUSHs(sv_2mortal(sv));
4010 along = (strend - s) / sizeof(double);
4015 Copy(s, &adouble, 1, double);
4016 s += sizeof(double);
4024 Copy(s, &adouble, 1, double);
4025 s += sizeof(double);
4027 sv_setnv(sv, (NV)adouble);
4028 PUSHs(sv_2mortal(sv));
4034 * Initialise the decode mapping. By using a table driven
4035 * algorithm, the code will be character-set independent
4036 * (and just as fast as doing character arithmetic)
4038 if (PL_uudmap['M'] == 0) {
4041 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4042 PL_uudmap[PL_uuemap[i]] = i;
4044 * Because ' ' and '`' map to the same value,
4045 * we need to decode them both the same.
4050 along = (strend - s) * 3 / 4;
4051 sv = NEWSV(42, along);
4054 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4059 len = PL_uudmap[*s++] & 077;
4061 if (s < strend && ISUUCHAR(*s))
4062 a = PL_uudmap[*s++] & 077;
4065 if (s < strend && ISUUCHAR(*s))
4066 b = PL_uudmap[*s++] & 077;
4069 if (s < strend && ISUUCHAR(*s))
4070 c = PL_uudmap[*s++] & 077;
4073 if (s < strend && ISUUCHAR(*s))
4074 d = PL_uudmap[*s++] & 077;
4077 hunk[0] = (a << 2) | (b >> 4);
4078 hunk[1] = (b << 4) | (c >> 2);
4079 hunk[2] = (c << 6) | d;
4080 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4085 else if (s[1] == '\n') /* possible checksum byte */
4088 XPUSHs(sv_2mortal(sv));
4093 if (strchr("fFdD", datumtype) ||
4094 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4098 while (checksum >= 16) {
4102 while (checksum >= 4) {
4108 along = (1 << checksum) - 1;
4109 while (cdouble < 0.0)
4111 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4112 sv_setnv(sv, cdouble);
4115 if (checksum < 32) {
4116 aulong = (1 << checksum) - 1;
4119 sv_setuv(sv, (UV)culong);
4121 XPUSHs(sv_2mortal(sv));
4125 if (SP == oldsp && gimme == G_SCALAR)
4126 PUSHs(&PL_sv_undef);
4131 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4135 *hunk = PL_uuemap[len];
4136 sv_catpvn(sv, hunk, 1);
4139 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4140 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4141 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4142 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4143 sv_catpvn(sv, hunk, 4);
4148 char r = (len > 1 ? s[1] : '\0');
4149 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4150 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4151 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4152 hunk[3] = PL_uuemap[0];
4153 sv_catpvn(sv, hunk, 4);
4155 sv_catpvn(sv, "\n", 1);
4159 S_is_an_int(pTHX_ char *s, STRLEN l)
4162 SV *result = newSVpvn(s, l);
4163 char *result_c = SvPV(result, n_a); /* convenience */
4164 char *out = result_c;
4174 SvREFCNT_dec(result);
4197 SvREFCNT_dec(result);
4203 SvCUR_set(result, out - result_c);
4207 /* pnum must be '\0' terminated */
4209 S_div128(pTHX_ SV *pnum, bool *done)
4212 char *s = SvPV(pnum, len);
4221 i = m * 10 + (*t - '0');
4223 r = (i >> 7); /* r < 10 */
4230 SvCUR_set(pnum, (STRLEN) (t - s));
4237 djSP; dMARK; dORIGMARK; dTARGET;
4238 register SV *cat = TARG;
4241 register char *pat = SvPVx(*++MARK, fromlen);
4242 register char *patend = pat + fromlen;
4247 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4248 static char *space10 = " ";
4250 /* These must not be in registers: */
4265 #ifdef PERL_NATINT_PACK
4266 int natint; /* native integer */
4271 sv_setpvn(cat, "", 0);
4272 while (pat < patend) {
4273 SV *lengthcode = Nullsv;
4274 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4275 datumtype = *pat++ & 0xFF;
4276 #ifdef PERL_NATINT_PACK
4279 if (isSPACE(datumtype))
4282 char *natstr = "sSiIlL";
4284 if (strchr(natstr, datumtype)) {
4285 #ifdef PERL_NATINT_PACK
4291 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
4294 len = strchr("@Xxu", datumtype) ? 0 : items;
4297 else if (isDIGIT(*pat)) {
4299 while (isDIGIT(*pat)) {
4300 len = (len * 10) + (*pat++ - '0');
4302 Perl_croak(aTHX_ "Repeat count in pack overflows");
4309 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4310 DIE(aTHX_ "# must be followed by a*, A* or Z*");
4311 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4312 ? *MARK : &PL_sv_no)));
4316 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4317 case ',': /* grandfather in commas but with a warning */
4318 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4319 Perl_warner(aTHX_ WARN_UNSAFE,
4320 "Invalid type in pack: '%c'", (int)datumtype);
4323 DIE(aTHX_ "%% may only be used in unpack");
4334 if (SvCUR(cat) < len)
4335 DIE(aTHX_ "X outside of string");
4342 sv_catpvn(cat, null10, 10);
4345 sv_catpvn(cat, null10, len);
4351 aptr = SvPV(fromstr, fromlen);
4355 sv_catpvn(cat, aptr, len);
4357 sv_catpvn(cat, aptr, fromlen);
4359 if (datumtype == 'A') {
4361 sv_catpvn(cat, space10, 10);
4364 sv_catpvn(cat, space10, len);
4368 sv_catpvn(cat, null10, 10);
4371 sv_catpvn(cat, null10, len);
4378 char *savepat = pat;
4383 aptr = SvPV(fromstr, fromlen);
4388 SvCUR(cat) += (len+7)/8;
4389 SvGROW(cat, SvCUR(cat) + 1);
4390 aptr = SvPVX(cat) + aint;
4395 if (datumtype == 'B') {
4396 for (len = 0; len++ < aint;) {
4397 items |= *pat++ & 1;
4401 *aptr++ = items & 0xff;
4407 for (len = 0; len++ < aint;) {
4413 *aptr++ = items & 0xff;
4419 if (datumtype == 'B')
4420 items <<= 7 - (aint & 7);
4422 items >>= 7 - (aint & 7);
4423 *aptr++ = items & 0xff;
4425 pat = SvPVX(cat) + SvCUR(cat);
4436 char *savepat = pat;
4441 aptr = SvPV(fromstr, fromlen);
4446 SvCUR(cat) += (len+1)/2;
4447 SvGROW(cat, SvCUR(cat) + 1);
4448 aptr = SvPVX(cat) + aint;
4453 if (datumtype == 'H') {
4454 for (len = 0; len++ < aint;) {
4456 items |= ((*pat++ & 15) + 9) & 15;
4458 items |= *pat++ & 15;
4462 *aptr++ = items & 0xff;
4468 for (len = 0; len++ < aint;) {
4470 items |= (((*pat++ & 15) + 9) & 15) << 4;
4472 items |= (*pat++ & 15) << 4;
4476 *aptr++ = items & 0xff;
4482 *aptr++ = items & 0xff;
4483 pat = SvPVX(cat) + SvCUR(cat);
4495 aint = SvIV(fromstr);
4497 sv_catpvn(cat, &achar, sizeof(char));
4503 auint = SvUV(fromstr);
4504 SvGROW(cat, SvCUR(cat) + 10);
4505 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4510 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4515 afloat = (float)SvNV(fromstr);
4516 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4523 adouble = (double)SvNV(fromstr);
4524 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4530 ashort = (I16)SvIV(fromstr);
4532 ashort = PerlSock_htons(ashort);
4534 CAT16(cat, &ashort);
4540 ashort = (I16)SvIV(fromstr);
4542 ashort = htovs(ashort);
4544 CAT16(cat, &ashort);
4548 #if SHORTSIZE != SIZE16
4550 unsigned short aushort;
4554 aushort = SvUV(fromstr);
4555 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4565 aushort = (U16)SvUV(fromstr);
4566 CAT16(cat, &aushort);
4572 #if SHORTSIZE != SIZE16
4578 ashort = SvIV(fromstr);
4579 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4587 ashort = (I16)SvIV(fromstr);
4588 CAT16(cat, &ashort);
4595 auint = SvUV(fromstr);
4596 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4602 adouble = Perl_floor(SvNV(fromstr));
4605 Perl_croak(aTHX_ "Cannot compress negative numbers");
4611 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4612 adouble <= UV_MAX_cxux
4619 char buf[1 + sizeof(UV)];
4620 char *in = buf + sizeof(buf);
4621 UV auv = U_V(adouble);
4624 *--in = (auv & 0x7f) | 0x80;
4627 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4628 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4630 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4631 char *from, *result, *in;
4636 /* Copy string and check for compliance */
4637 from = SvPV(fromstr, len);
4638 if ((norm = is_an_int(from, len)) == NULL)
4639 Perl_croak(aTHX_ "can compress only unsigned integer");
4641 New('w', result, len, char);
4645 *--in = div128(norm, &done) | 0x80;
4646 result[len - 1] &= 0x7F; /* clear continue bit */
4647 sv_catpvn(cat, in, (result + len) - in);
4649 SvREFCNT_dec(norm); /* free norm */
4651 else if (SvNOKp(fromstr)) {
4652 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4653 char *in = buf + sizeof(buf);
4656 double next = floor(adouble / 128);
4657 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4658 if (--in < buf) /* this cannot happen ;-) */
4659 Perl_croak(aTHX_ "Cannot compress integer");
4661 } while (adouble > 0);
4662 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4663 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4666 Perl_croak(aTHX_ "Cannot compress non integer");
4672 aint = SvIV(fromstr);
4673 sv_catpvn(cat, (char*)&aint, sizeof(int));
4679 aulong = SvUV(fromstr);
4681 aulong = PerlSock_htonl(aulong);
4683 CAT32(cat, &aulong);
4689 aulong = SvUV(fromstr);
4691 aulong = htovl(aulong);
4693 CAT32(cat, &aulong);
4697 #if LONGSIZE != SIZE32
4699 unsigned long aulong;
4703 aulong = SvUV(fromstr);
4704 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4712 aulong = SvUV(fromstr);
4713 CAT32(cat, &aulong);
4718 #if LONGSIZE != SIZE32
4724 along = SvIV(fromstr);
4725 sv_catpvn(cat, (char *)&along, sizeof(long));
4733 along = SvIV(fromstr);
4742 auquad = (Uquad_t)SvUV(fromstr);
4743 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4749 aquad = (Quad_t)SvIV(fromstr);
4750 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4753 #endif /* HAS_QUAD */
4755 len = 1; /* assume SV is correct length */
4760 if (fromstr == &PL_sv_undef)
4764 /* XXX better yet, could spirit away the string to
4765 * a safe spot and hang on to it until the result
4766 * of pack() (and all copies of the result) are
4769 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4770 Perl_warner(aTHX_ WARN_UNSAFE,
4771 "Attempt to pack pointer to temporary value");
4772 if (SvPOK(fromstr) || SvNIOK(fromstr))
4773 aptr = SvPV(fromstr,n_a);
4775 aptr = SvPV_force(fromstr,n_a);
4777 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4782 aptr = SvPV(fromstr, fromlen);
4783 SvGROW(cat, fromlen * 4 / 3);
4788 while (fromlen > 0) {
4795 doencodes(cat, aptr, todo);
4814 register I32 limit = POPi; /* note, negative is forever */
4817 register char *s = SvPV(sv, len);
4818 char *strend = s + len;
4820 register REGEXP *rx;
4824 I32 maxiters = (strend - s) + 10;
4827 I32 origlimit = limit;
4830 AV *oldstack = PL_curstack;
4831 I32 gimme = GIMME_V;
4832 I32 oldsave = PL_savestack_ix;
4833 I32 make_mortal = 1;
4834 MAGIC *mg = (MAGIC *) NULL;
4837 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4842 DIE(aTHX_ "panic: do_split");
4843 rx = pm->op_pmregexp;
4845 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4846 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4848 if (pm->op_pmreplroot)
4849 ary = GvAVn((GV*)pm->op_pmreplroot);
4850 else if (gimme != G_ARRAY)
4852 ary = (AV*)PL_curpad[0];
4854 ary = GvAVn(PL_defgv);
4855 #endif /* USE_THREADS */
4858 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4864 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4866 XPUSHs(SvTIED_obj((SV*)ary, mg));
4871 for (i = AvFILLp(ary); i >= 0; i--)
4872 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4874 /* temporarily switch stacks */
4875 SWITCHSTACK(PL_curstack, ary);
4879 base = SP - PL_stack_base;
4881 if (pm->op_pmflags & PMf_SKIPWHITE) {
4882 if (pm->op_pmflags & PMf_LOCALE) {
4883 while (isSPACE_LC(*s))
4891 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4892 SAVEINT(PL_multiline);
4893 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4897 limit = maxiters + 2;
4898 if (pm->op_pmflags & PMf_WHITE) {
4901 while (m < strend &&
4902 !((pm->op_pmflags & PMf_LOCALE)
4903 ? isSPACE_LC(*m) : isSPACE(*m)))
4908 dstr = NEWSV(30, m-s);
4909 sv_setpvn(dstr, s, m-s);
4915 while (s < strend &&
4916 ((pm->op_pmflags & PMf_LOCALE)
4917 ? isSPACE_LC(*s) : isSPACE(*s)))
4921 else if (strEQ("^", rx->precomp)) {
4924 for (m = s; m < strend && *m != '\n'; m++) ;
4928 dstr = NEWSV(30, m-s);
4929 sv_setpvn(dstr, s, m-s);
4936 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
4937 && (rx->reganch & ROPT_CHECK_ALL)
4938 && !(rx->reganch & ROPT_ANCH)) {
4939 int tail = (rx->reganch & RE_INTUIT_TAIL);
4940 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4944 if (len == 1 && !tail) {
4948 for (m = s; m < strend && *m != c; m++) ;
4951 dstr = NEWSV(30, m-s);
4952 sv_setpvn(dstr, s, m-s);
4961 while (s < strend && --limit &&
4962 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4963 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4966 dstr = NEWSV(31, m-s);
4967 sv_setpvn(dstr, s, m-s);
4971 s = m + len; /* Fake \n at the end */
4976 maxiters += (strend - s) * rx->nparens;
4977 while (s < strend && --limit
4978 /* && (!rx->check_substr
4979 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4981 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4982 1 /* minend */, sv, NULL, 0))
4984 TAINT_IF(RX_MATCH_TAINTED(rx));
4985 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4990 strend = s + (strend - m);
4992 m = rx->startp[0] + orig;
4993 dstr = NEWSV(32, m-s);
4994 sv_setpvn(dstr, s, m-s);
4999 for (i = 1; i <= rx->nparens; i++) {
5000 s = rx->startp[i] + orig;
5001 m = rx->endp[i] + orig;
5003 dstr = NEWSV(33, m-s);
5004 sv_setpvn(dstr, s, m-s);
5007 dstr = NEWSV(33, 0);
5013 s = rx->endp[0] + orig;
5017 LEAVE_SCOPE(oldsave);
5018 iters = (SP - PL_stack_base) - base;
5019 if (iters > maxiters)
5020 DIE(aTHX_ "Split loop");
5022 /* keep field after final delim? */
5023 if (s < strend || (iters && origlimit)) {
5024 dstr = NEWSV(34, strend-s);
5025 sv_setpvn(dstr, s, strend-s);
5031 else if (!origlimit) {
5032 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5038 SWITCHSTACK(ary, oldstack);
5039 if (SvSMAGICAL(ary)) {
5044 if (gimme == G_ARRAY) {
5046 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5054 call_method("PUSH",G_SCALAR|G_DISCARD);
5057 if (gimme == G_ARRAY) {
5058 /* EXTEND should not be needed - we just popped them */
5060 for (i=0; i < iters; i++) {
5061 SV **svp = av_fetch(ary, i, FALSE);
5062 PUSHs((svp) ? *svp : &PL_sv_undef);
5069 if (gimme == G_ARRAY)
5072 if (iters || !pm->op_pmreplroot) {
5082 Perl_unlock_condpair(pTHX_ void *svv)
5085 MAGIC *mg = mg_find((SV*)svv, 'm');
5088 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5089 MUTEX_LOCK(MgMUTEXP(mg));
5090 if (MgOWNER(mg) != thr)
5091 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5093 COND_SIGNAL(MgOWNERCONDP(mg));
5094 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
5095 (unsigned long)thr, (unsigned long)svv);)
5096 MUTEX_UNLOCK(MgMUTEXP(mg));
5098 #endif /* USE_THREADS */
5111 mg = condpair_magic(sv);
5112 MUTEX_LOCK(MgMUTEXP(mg));
5113 if (MgOWNER(mg) == thr)
5114 MUTEX_UNLOCK(MgMUTEXP(mg));
5117 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5119 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
5120 (unsigned long)thr, (unsigned long)sv);)
5121 MUTEX_UNLOCK(MgMUTEXP(mg));
5122 SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
5124 #endif /* USE_THREADS */
5125 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5126 || SvTYPE(retsv) == SVt_PVCV) {
5127 retsv = refto(retsv);
5138 if (PL_op->op_private & OPpLVAL_INTRO)
5139 PUSHs(*save_threadsv(PL_op->op_targ));
5141 PUSHs(THREADSV(PL_op->op_targ));
5144 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5145 #endif /* USE_THREADS */