3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * 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 LONGSIZE > 4 && defined(_CRAY)
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 */
85 /* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
89 #ifdef NEED_GETPID_PROTO
90 extern Pid_t getpid (void);
96 if (GIMME_V == G_SCALAR)
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
114 if (PL_op->op_flags & OPf_REF) {
118 if (GIMME == G_ARRAY) {
119 I32 maxarg = AvFILL((AV*)TARG) + 1;
121 if (SvMAGICAL(TARG)) {
123 for (i=0; i < maxarg; i++) {
124 SV **svp = av_fetch((AV*)TARG, i, FALSE);
125 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
129 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
134 SV* sv = sv_newmortal();
135 I32 maxarg = AvFILL((AV*)TARG) + 1;
136 sv_setiv(sv, maxarg);
148 if (PL_op->op_private & OPpLVAL_INTRO)
149 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
150 if (PL_op->op_flags & OPf_REF)
153 if (gimme == G_ARRAY) {
156 else if (gimme == G_SCALAR) {
157 SV* sv = sv_newmortal();
158 if (HvFILL((HV*)TARG))
159 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
160 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
170 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
181 tryAMAGICunDEREF(to_gv);
184 if (SvTYPE(sv) == SVt_PVIO) {
185 GV *gv = (GV*) sv_newmortal();
186 gv_init(gv, 0, "", 0, 0);
187 GvIOp(gv) = (IO *)sv;
188 (void)SvREFCNT_inc(sv);
191 else if (SvTYPE(sv) != SVt_PVGV)
192 DIE(aTHX_ "Not a GLOB reference");
195 if (SvTYPE(sv) != SVt_PVGV) {
199 if (SvGMAGICAL(sv)) {
204 if (!SvOK(sv) && sv != &PL_sv_undef) {
205 /* If this is a 'my' scalar and flag is set then vivify
208 if (PL_op->op_private & OPpDEREF) {
211 if (cUNOP->op_targ) {
213 SV *namesv = PL_curpad[cUNOP->op_targ];
214 name = SvPV(namesv, len);
215 gv = (GV*)NEWSV(0,0);
216 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
219 name = CopSTASHPV(PL_curcop);
222 if (SvTYPE(sv) < SVt_RV)
223 sv_upgrade(sv, SVt_RV);
229 if (PL_op->op_flags & OPf_REF ||
230 PL_op->op_private & HINT_STRICT_REFS)
231 DIE(aTHX_ PL_no_usym, "a symbol");
232 if (ckWARN(WARN_UNINITIALIZED))
237 if ((PL_op->op_flags & OPf_SPECIAL) &&
238 !(PL_op->op_flags & OPf_MOD))
240 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
242 && (!is_gv_magical(sym,len,0)
243 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
249 if (PL_op->op_private & HINT_STRICT_REFS)
250 DIE(aTHX_ PL_no_symref, sym, "a symbol");
251 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
255 if (PL_op->op_private & OPpLVAL_INTRO)
256 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
267 tryAMAGICunDEREF(to_sv);
270 switch (SvTYPE(sv)) {
274 DIE(aTHX_ "Not a SCALAR reference");
282 if (SvTYPE(gv) != SVt_PVGV) {
283 if (SvGMAGICAL(sv)) {
289 if (PL_op->op_flags & OPf_REF ||
290 PL_op->op_private & HINT_STRICT_REFS)
291 DIE(aTHX_ PL_no_usym, "a SCALAR");
292 if (ckWARN(WARN_UNINITIALIZED))
297 if ((PL_op->op_flags & OPf_SPECIAL) &&
298 !(PL_op->op_flags & OPf_MOD))
300 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
302 && (!is_gv_magical(sym,len,0)
303 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
309 if (PL_op->op_private & HINT_STRICT_REFS)
310 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
311 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
316 if (PL_op->op_flags & OPf_MOD) {
317 if (PL_op->op_private & OPpLVAL_INTRO)
318 sv = save_scalar((GV*)TOPs);
319 else if (PL_op->op_private & OPpDEREF)
320 vivify_ref(sv, PL_op->op_private & OPpDEREF);
330 SV *sv = AvARYLEN(av);
332 AvARYLEN(av) = sv = NEWSV(0,0);
333 sv_upgrade(sv, SVt_IV);
334 sv_magic(sv, (SV*)av, '#', Nullch, 0);
342 djSP; dTARGET; dPOPss;
344 if (PL_op->op_flags & OPf_MOD) {
345 if (SvTYPE(TARG) < SVt_PVLV) {
346 sv_upgrade(TARG, SVt_PVLV);
347 sv_magic(TARG, Nullsv, '.', Nullch, 0);
351 if (LvTARG(TARG) != sv) {
353 SvREFCNT_dec(LvTARG(TARG));
354 LvTARG(TARG) = SvREFCNT_inc(sv);
356 PUSHs(TARG); /* no SvSETMAGIC */
362 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
363 mg = mg_find(sv, 'g');
364 if (mg && mg->mg_len >= 0) {
368 PUSHi(i + PL_curcop->cop_arybase);
382 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
383 /* (But not in defined().) */
384 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
387 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
388 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
389 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
392 cv = (CV*)&PL_sv_undef;
406 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
407 char *s = SvPVX(TOPs);
408 if (strnEQ(s, "CORE::", 6)) {
411 code = keyword(s + 6, SvCUR(TOPs) - 6);
412 if (code < 0) { /* Overridable. */
413 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
414 int i = 0, n = 0, seen_question = 0;
416 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
418 while (i < MAXO) { /* The slow way. */
419 if (strEQ(s + 6, PL_op_name[i])
420 || strEQ(s + 6, PL_op_desc[i]))
426 goto nonesuch; /* Should not happen... */
428 oa = PL_opargs[i] >> OASHIFT;
430 if (oa & OA_OPTIONAL) {
434 else if (n && str[0] == ';' && seen_question)
435 goto set; /* XXXX system, exec */
436 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
437 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
440 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
441 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
445 ret = sv_2mortal(newSVpvn(str, n - 1));
447 else if (code) /* Non-Overridable */
449 else { /* None such */
451 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
455 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
457 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
466 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
468 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
484 if (GIMME != G_ARRAY) {
488 *MARK = &PL_sv_undef;
489 *MARK = refto(*MARK);
493 EXTEND_MORTAL(SP - MARK);
495 *MARK = refto(*MARK);
500 S_refto(pTHX_ SV *sv)
504 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
507 if (!(sv = LvTARG(sv)))
510 (void)SvREFCNT_inc(sv);
512 else if (SvTYPE(sv) == SVt_PVAV) {
513 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
516 (void)SvREFCNT_inc(sv);
518 else if (SvPADTMP(sv))
522 (void)SvREFCNT_inc(sv);
525 sv_upgrade(rv, SVt_RV);
539 if (sv && SvGMAGICAL(sv))
542 if (!sv || !SvROK(sv))
546 pv = sv_reftype(sv,TRUE);
547 PUSHp(pv, strlen(pv));
557 stash = CopSTASH(PL_curcop);
563 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
564 Perl_croak(aTHX_ "Attempt to bless into a reference");
566 if (ckWARN(WARN_MISC) && len == 0)
567 Perl_warner(aTHX_ WARN_MISC,
568 "Explicit blessing to '' (assuming package main)");
569 stash = gv_stashpvn(ptr, len, TRUE);
572 (void)sv_bless(TOPs, stash);
586 elem = SvPV(sv, n_a);
590 switch (elem ? *elem : '\0')
593 if (strEQ(elem, "ARRAY"))
594 tmpRef = (SV*)GvAV(gv);
597 if (strEQ(elem, "CODE"))
598 tmpRef = (SV*)GvCVu(gv);
601 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
602 tmpRef = (SV*)GvIOp(gv);
604 if (strEQ(elem, "FORMAT"))
605 tmpRef = (SV*)GvFORM(gv);
608 if (strEQ(elem, "GLOB"))
612 if (strEQ(elem, "HASH"))
613 tmpRef = (SV*)GvHV(gv);
616 if (strEQ(elem, "IO"))
617 tmpRef = (SV*)GvIOp(gv);
620 if (strEQ(elem, "NAME"))
621 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
624 if (strEQ(elem, "PACKAGE"))
625 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
628 if (strEQ(elem, "SCALAR"))
642 /* Pattern matching */
647 register unsigned char *s;
650 register I32 *sfirst;
654 if (sv == PL_lastscream) {
660 SvSCREAM_off(PL_lastscream);
661 SvREFCNT_dec(PL_lastscream);
663 PL_lastscream = SvREFCNT_inc(sv);
666 s = (unsigned char*)(SvPV(sv, len));
670 if (pos > PL_maxscream) {
671 if (PL_maxscream < 0) {
672 PL_maxscream = pos + 80;
673 New(301, PL_screamfirst, 256, I32);
674 New(302, PL_screamnext, PL_maxscream, I32);
677 PL_maxscream = pos + pos / 4;
678 Renew(PL_screamnext, PL_maxscream, I32);
682 sfirst = PL_screamfirst;
683 snext = PL_screamnext;
685 if (!sfirst || !snext)
686 DIE(aTHX_ "do_study: out of memory");
688 for (ch = 256; ch; --ch)
695 snext[pos] = sfirst[ch] - pos;
702 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
711 if (PL_op->op_flags & OPf_STACKED)
717 TARG = sv_newmortal();
722 /* Lvalue operators. */
734 djSP; dMARK; dTARGET;
744 SETi(do_chomp(TOPs));
750 djSP; dMARK; dTARGET;
751 register I32 count = 0;
754 count += do_chomp(POPs);
765 if (!sv || !SvANY(sv))
767 switch (SvTYPE(sv)) {
769 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
773 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
777 if (CvROOT(sv) || CvXSUB(sv))
794 if (!PL_op->op_private) {
803 if (SvTHINKFIRST(sv))
806 switch (SvTYPE(sv)) {
816 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
817 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
818 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
822 /* let user-undef'd sub keep its identity */
823 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
830 SvSetMagicSV(sv, &PL_sv_undef);
834 Newz(602, gp, 1, GP);
835 GvGP(sv) = gp_ref(gp);
836 GvSV(sv) = NEWSV(72,0);
837 GvLINE(sv) = CopLINE(PL_curcop);
843 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
846 SvPV_set(sv, Nullch);
859 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
860 DIE(aTHX_ PL_no_modify);
861 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
862 SvIVX(TOPs) != IV_MIN)
865 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
876 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
877 DIE(aTHX_ PL_no_modify);
878 sv_setsv(TARG, TOPs);
879 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
880 SvIVX(TOPs) != IV_MAX)
883 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
897 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
898 DIE(aTHX_ PL_no_modify);
899 sv_setsv(TARG, TOPs);
900 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
901 SvIVX(TOPs) != IV_MIN)
904 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
913 /* Ordinary operators. */
917 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
920 SETn( Perl_pow( left, right) );
927 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
930 SETn( left * right );
937 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
942 DIE(aTHX_ "Illegal division by zero");
944 /* insure that 20./5. == 4. */
947 if ((NV)I_V(left) == left &&
948 (NV)I_V(right) == right &&
949 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
953 value = left / right;
957 value = left / right;
966 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
976 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
978 right = (right_neg = (i < 0)) ? -i : i;
983 right_neg = dright < 0;
988 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
990 left = (left_neg = (i < 0)) ? -i : i;
998 left_neg = dleft < 0;
1007 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1009 # define CAST_D2UV(d) U_V(d)
1011 # define CAST_D2UV(d) ((UV)(d))
1013 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1014 * or, in other words, precision of UV more than of NV.
1015 * But in fact the approach below turned out to be an
1016 * optimization - floor() may be slow */
1017 if (dright <= UV_MAX && dleft <= UV_MAX) {
1018 right = CAST_D2UV(dright);
1019 left = CAST_D2UV(dleft);
1024 /* Backward-compatibility clause: */
1025 dright = Perl_floor(dright + 0.5);
1026 dleft = Perl_floor(dleft + 0.5);
1029 DIE(aTHX_ "Illegal modulus zero");
1031 dans = Perl_fmod(dleft, dright);
1032 if ((left_neg != right_neg) && dans)
1033 dans = dright - dans;
1036 sv_setnv(TARG, dans);
1043 DIE(aTHX_ "Illegal modulus zero");
1046 if ((left_neg != right_neg) && ans)
1049 /* XXX may warn: unary minus operator applied to unsigned type */
1050 /* could change -foo to be (~foo)+1 instead */
1051 if (ans <= ~((UV)IV_MAX)+1)
1052 sv_setiv(TARG, ~ans+1);
1054 sv_setnv(TARG, -(NV)ans);
1057 sv_setuv(TARG, ans);
1066 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1068 register IV count = POPi;
1069 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1071 I32 items = SP - MARK;
1074 max = items * count;
1083 repeatcpy((char*)(MARK + items), (char*)MARK,
1084 items * sizeof(SV*), count - 1);
1087 else if (count <= 0)
1090 else { /* Note: mark already snarfed by pp_list */
1093 bool isutf = DO_UTF8(tmpstr);
1095 SvSetSV(TARG, tmpstr);
1096 SvPV_force(TARG, len);
1101 SvGROW(TARG, (count * len) + 1);
1102 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1103 SvCUR(TARG) *= count;
1105 *SvEND(TARG) = '\0';
1108 (void)SvPOK_only_UTF8(TARG);
1110 (void)SvPOK_only(TARG);
1119 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1122 SETn( left - right );
1129 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1132 if (PL_op->op_private & HINT_INTEGER) {
1146 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1149 if (PL_op->op_private & HINT_INTEGER) {
1163 djSP; tryAMAGICbinSET(lt,0);
1166 SETs(boolSV(TOPn < value));
1173 djSP; tryAMAGICbinSET(gt,0);
1176 SETs(boolSV(TOPn > value));
1183 djSP; tryAMAGICbinSET(le,0);
1186 SETs(boolSV(TOPn <= value));
1193 djSP; tryAMAGICbinSET(ge,0);
1196 SETs(boolSV(TOPn >= value));
1203 djSP; tryAMAGICbinSET(ne,0);
1206 SETs(boolSV(TOPn != value));
1213 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1219 if (Perl_isnan(left) || Perl_isnan(right)) {
1223 value = (left > right) - (left < right);
1227 else if (left < right)
1229 else if (left > right)
1243 djSP; tryAMAGICbinSET(slt,0);
1246 int cmp = ((PL_op->op_private & OPpLOCALE)
1247 ? sv_cmp_locale(left, right)
1248 : sv_cmp(left, right));
1249 SETs(boolSV(cmp < 0));
1256 djSP; tryAMAGICbinSET(sgt,0);
1259 int cmp = ((PL_op->op_private & OPpLOCALE)
1260 ? sv_cmp_locale(left, right)
1261 : sv_cmp(left, right));
1262 SETs(boolSV(cmp > 0));
1269 djSP; tryAMAGICbinSET(sle,0);
1272 int cmp = ((PL_op->op_private & OPpLOCALE)
1273 ? sv_cmp_locale(left, right)
1274 : sv_cmp(left, right));
1275 SETs(boolSV(cmp <= 0));
1282 djSP; tryAMAGICbinSET(sge,0);
1285 int cmp = ((PL_op->op_private & OPpLOCALE)
1286 ? sv_cmp_locale(left, right)
1287 : sv_cmp(left, right));
1288 SETs(boolSV(cmp >= 0));
1295 djSP; tryAMAGICbinSET(seq,0);
1298 SETs(boolSV(sv_eq(left, right)));
1305 djSP; tryAMAGICbinSET(sne,0);
1308 SETs(boolSV(!sv_eq(left, right)));
1315 djSP; dTARGET; tryAMAGICbin(scmp,0);
1318 int cmp = ((PL_op->op_private & OPpLOCALE)
1319 ? sv_cmp_locale(left, right)
1320 : sv_cmp(left, right));
1328 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1331 if (SvNIOKp(left) || SvNIOKp(right)) {
1332 if (PL_op->op_private & HINT_INTEGER) {
1333 IV i = SvIV(left) & SvIV(right);
1337 UV u = SvUV(left) & SvUV(right);
1342 do_vop(PL_op->op_type, TARG, left, right);
1351 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1354 if (SvNIOKp(left) || SvNIOKp(right)) {
1355 if (PL_op->op_private & HINT_INTEGER) {
1356 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1360 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1365 do_vop(PL_op->op_type, TARG, left, right);
1374 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1377 if (SvNIOKp(left) || SvNIOKp(right)) {
1378 if (PL_op->op_private & HINT_INTEGER) {
1379 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1383 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1388 do_vop(PL_op->op_type, TARG, left, right);
1397 djSP; dTARGET; tryAMAGICun(neg);
1402 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1404 if (SvIVX(sv) == IV_MIN) {
1405 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1408 else if (SvUVX(sv) <= IV_MAX) {
1413 else if (SvIVX(sv) != IV_MIN) {
1420 else if (SvPOKp(sv)) {
1422 char *s = SvPV(sv, len);
1423 if (isIDFIRST(*s)) {
1424 sv_setpvn(TARG, "-", 1);
1427 else if (*s == '+' || *s == '-') {
1429 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1431 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1432 sv_setpvn(TARG, "-", 1);
1436 sv_setnv(TARG, -SvNV(sv));
1447 djSP; tryAMAGICunSET(not);
1448 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1454 djSP; dTARGET; tryAMAGICun(compl);
1458 if (PL_op->op_private & HINT_INTEGER) {
1473 tmps = (U8*)SvPV_force(TARG, len);
1476 /* Calculate exact length, let's not estimate. */
1485 while (tmps < send) {
1486 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1487 tmps += UTF8SKIP(tmps);
1488 targlen += UNISKIP(~c);
1494 /* Now rewind strings and write them. */
1498 Newz(0, result, targlen + 1, U8);
1499 while (tmps < send) {
1500 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1501 tmps += UTF8SKIP(tmps);
1502 result = uv_to_utf8(result, ~c);
1506 sv_setpvn(TARG, (char*)result, targlen);
1510 Newz(0, result, nchar + 1, U8);
1511 while (tmps < send) {
1512 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
1513 tmps += UTF8SKIP(tmps);
1518 sv_setpvn(TARG, (char*)result, nchar);
1526 register long *tmpl;
1527 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1530 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1535 for ( ; anum > 0; anum--, tmps++)
1544 /* integer versions of some of the above */
1548 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1551 SETi( left * right );
1558 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1562 DIE(aTHX_ "Illegal division by zero");
1563 value = POPi / value;
1571 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1575 DIE(aTHX_ "Illegal modulus zero");
1576 SETi( left % right );
1583 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1586 SETi( left + right );
1593 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1596 SETi( left - right );
1603 djSP; tryAMAGICbinSET(lt,0);
1606 SETs(boolSV(left < right));
1613 djSP; tryAMAGICbinSET(gt,0);
1616 SETs(boolSV(left > right));
1623 djSP; tryAMAGICbinSET(le,0);
1626 SETs(boolSV(left <= right));
1633 djSP; tryAMAGICbinSET(ge,0);
1636 SETs(boolSV(left >= right));
1643 djSP; tryAMAGICbinSET(eq,0);
1646 SETs(boolSV(left == right));
1653 djSP; tryAMAGICbinSET(ne,0);
1656 SETs(boolSV(left != right));
1663 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1670 else if (left < right)
1681 djSP; dTARGET; tryAMAGICun(neg);
1686 /* High falutin' math. */
1690 djSP; dTARGET; tryAMAGICbin(atan2,0);
1693 SETn(Perl_atan2(left, right));
1700 djSP; dTARGET; tryAMAGICun(sin);
1704 value = Perl_sin(value);
1712 djSP; dTARGET; tryAMAGICun(cos);
1716 value = Perl_cos(value);
1722 /* Support Configure command-line overrides for rand() functions.
1723 After 5.005, perhaps we should replace this by Configure support
1724 for drand48(), random(), or rand(). For 5.005, though, maintain
1725 compatibility by calling rand() but allow the user to override it.
1726 See INSTALL for details. --Andy Dougherty 15 July 1998
1728 /* Now it's after 5.005, and Configure supports drand48() and random(),
1729 in addition to rand(). So the overrides should not be needed any more.
1730 --Jarkko Hietaniemi 27 September 1998
1733 #ifndef HAS_DRAND48_PROTO
1734 extern double drand48 (void);
1747 if (!PL_srand_called) {
1748 (void)seedDrand01((Rand_seed_t)seed());
1749 PL_srand_called = TRUE;
1764 (void)seedDrand01((Rand_seed_t)anum);
1765 PL_srand_called = TRUE;
1774 * This is really just a quick hack which grabs various garbage
1775 * values. It really should be a real hash algorithm which
1776 * spreads the effect of every input bit onto every output bit,
1777 * if someone who knows about such things would bother to write it.
1778 * Might be a good idea to add that function to CORE as well.
1779 * No numbers below come from careful analysis or anything here,
1780 * except they are primes and SEED_C1 > 1E6 to get a full-width
1781 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1782 * probably be bigger too.
1785 # define SEED_C1 1000003
1786 #define SEED_C4 73819
1788 # define SEED_C1 25747
1789 #define SEED_C4 20639
1793 #define SEED_C5 26107
1796 #ifndef PERL_NO_DEV_RANDOM
1801 # include <starlet.h>
1802 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1803 * in 100-ns units, typically incremented ever 10 ms. */
1804 unsigned int when[2];
1806 # ifdef HAS_GETTIMEOFDAY
1807 struct timeval when;
1813 /* This test is an escape hatch, this symbol isn't set by Configure. */
1814 #ifndef PERL_NO_DEV_RANDOM
1815 #ifndef PERL_RANDOM_DEVICE
1816 /* /dev/random isn't used by default because reads from it will block
1817 * if there isn't enough entropy available. You can compile with
1818 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1819 * is enough real entropy to fill the seed. */
1820 # define PERL_RANDOM_DEVICE "/dev/urandom"
1822 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1824 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1833 _ckvmssts(sys$gettim(when));
1834 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1836 # ifdef HAS_GETTIMEOFDAY
1837 gettimeofday(&when,(struct timezone *) 0);
1838 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1841 u = (U32)SEED_C1 * when;
1844 u += SEED_C3 * (U32)PerlProc_getpid();
1845 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1846 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1847 u += SEED_C5 * (U32)PTR2UV(&when);
1854 djSP; dTARGET; tryAMAGICun(exp);
1858 value = Perl_exp(value);
1866 djSP; dTARGET; tryAMAGICun(log);
1871 SET_NUMERIC_STANDARD();
1872 DIE(aTHX_ "Can't take log of %g", value);
1874 value = Perl_log(value);
1882 djSP; dTARGET; tryAMAGICun(sqrt);
1887 SET_NUMERIC_STANDARD();
1888 DIE(aTHX_ "Can't take sqrt of %g", value);
1890 value = Perl_sqrt(value);
1903 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1909 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1910 (void)Perl_modf(value, &value);
1912 double tmp = (double)value;
1913 (void)Perl_modf(tmp, &tmp);
1918 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1919 (void)Perl_modf(-value, &value);
1922 double tmp = (double)value;
1923 (void)Perl_modf(-tmp, &tmp);
1939 djSP; dTARGET; tryAMAGICun(abs);
1944 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1945 (iv = SvIVX(TOPs)) != IV_MIN) {
1967 argtype = 1; /* allow underscores */
1968 XPUSHn(scan_hex(tmps, 99, &argtype));
1981 while (*tmps && isSPACE(*tmps))
1985 argtype = 1; /* allow underscores */
1987 value = scan_hex(++tmps, 99, &argtype);
1988 else if (*tmps == 'b')
1989 value = scan_bin(++tmps, 99, &argtype);
1991 value = scan_oct(tmps, 99, &argtype);
2004 SETi(sv_len_utf8(sv));
2020 I32 lvalue = PL_op->op_flags & OPf_MOD;
2022 I32 arybase = PL_curcop->cop_arybase;
2026 SvTAINTED_off(TARG); /* decontaminate */
2027 SvUTF8_off(TARG); /* decontaminate */
2031 repl = SvPV(sv, repl_len);
2038 tmps = SvPV(sv, curlen);
2040 utfcurlen = sv_len_utf8(sv);
2041 if (utfcurlen == curlen)
2049 if (pos >= arybase) {
2067 else if (len >= 0) {
2069 if (rem > (I32)curlen)
2084 Perl_croak(aTHX_ "substr outside of string");
2085 if (ckWARN(WARN_SUBSTR))
2086 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2091 sv_pos_u2b(sv, &pos, &rem);
2093 sv_setpvn(TARG, tmps, rem);
2097 sv_insert(sv, pos, rem, repl, repl_len);
2098 else if (lvalue) { /* it's an lvalue! */
2099 if (!SvGMAGICAL(sv)) {
2103 if (ckWARN(WARN_SUBSTR))
2104 Perl_warner(aTHX_ WARN_SUBSTR,
2105 "Attempt to use reference as lvalue in substr");
2107 if (SvOK(sv)) /* is it defined ? */
2108 (void)SvPOK_only_UTF8(sv);
2110 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2113 if (SvTYPE(TARG) < SVt_PVLV) {
2114 sv_upgrade(TARG, SVt_PVLV);
2115 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2119 if (LvTARG(TARG) != sv) {
2121 SvREFCNT_dec(LvTARG(TARG));
2122 LvTARG(TARG) = SvREFCNT_inc(sv);
2124 LvTARGOFF(TARG) = pos;
2125 LvTARGLEN(TARG) = rem;
2129 PUSHs(TARG); /* avoid SvSETMAGIC here */
2136 register IV size = POPi;
2137 register IV offset = POPi;
2138 register SV *src = POPs;
2139 I32 lvalue = PL_op->op_flags & OPf_MOD;
2141 SvTAINTED_off(TARG); /* decontaminate */
2142 if (lvalue) { /* it's an lvalue! */
2143 if (SvTYPE(TARG) < SVt_PVLV) {
2144 sv_upgrade(TARG, SVt_PVLV);
2145 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2148 if (LvTARG(TARG) != src) {
2150 SvREFCNT_dec(LvTARG(TARG));
2151 LvTARG(TARG) = SvREFCNT_inc(src);
2153 LvTARGOFF(TARG) = offset;
2154 LvTARGLEN(TARG) = size;
2157 sv_setuv(TARG, do_vecget(src, offset, size));
2172 I32 arybase = PL_curcop->cop_arybase;
2177 offset = POPi - arybase;
2180 tmps = SvPV(big, biglen);
2181 if (offset > 0 && DO_UTF8(big))
2182 sv_pos_u2b(big, &offset, 0);
2185 else if (offset > biglen)
2187 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2188 (unsigned char*)tmps + biglen, little, 0)))
2191 retval = tmps2 - tmps;
2192 if (retval > 0 && DO_UTF8(big))
2193 sv_pos_b2u(big, &retval);
2194 PUSHi(retval + arybase);
2209 I32 arybase = PL_curcop->cop_arybase;
2215 tmps2 = SvPV(little, llen);
2216 tmps = SvPV(big, blen);
2220 if (offset > 0 && DO_UTF8(big))
2221 sv_pos_u2b(big, &offset, 0);
2222 offset = offset - arybase + llen;
2226 else if (offset > blen)
2228 if (!(tmps2 = rninstr(tmps, tmps + offset,
2229 tmps2, tmps2 + llen)))
2232 retval = tmps2 - tmps;
2233 if (retval > 0 && DO_UTF8(big))
2234 sv_pos_b2u(big, &retval);
2235 PUSHi(retval + arybase);
2241 djSP; dMARK; dORIGMARK; dTARGET;
2242 do_sprintf(TARG, SP-MARK, MARK+1);
2243 TAINT_IF(SvTAINTED(TARG));
2255 U8 *tmps = (U8*)SvPVx(tmpsv, len);
2258 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
2259 value = utf8_to_uv(tmps, len, &retlen, 0);
2261 value = (UV)(*tmps & 255);
2272 (void)SvUPGRADE(TARG,SVt_PV);
2274 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
2275 SvGROW(TARG, UTF8_MAXLEN+1);
2277 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2278 SvCUR_set(TARG, tmps - SvPVX(TARG));
2280 (void)SvPOK_only(TARG);
2291 (void)SvPOK_only(TARG);
2298 djSP; dTARGET; dPOPTOPssrl;
2301 char *tmps = SvPV(left, n_a);
2303 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2305 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2309 "The crypt() function is unimplemented due to excessive paranoia.");
2322 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2324 U8 tmpbuf[UTF8_MAXLEN+1];
2326 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2328 if (PL_op->op_private & OPpLOCALE) {
2331 uv = toTITLE_LC_uni(uv);
2334 uv = toTITLE_utf8(s);
2336 tend = uv_to_utf8(tmpbuf, uv);
2338 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2340 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2341 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2346 s = (U8*)SvPV_force(sv, slen);
2347 Copy(tmpbuf, s, ulen, U8);
2351 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2353 SvUTF8_off(TARG); /* decontaminate */
2358 s = (U8*)SvPV_force(sv, slen);
2360 if (PL_op->op_private & OPpLOCALE) {
2363 *s = toUPPER_LC(*s);
2381 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2383 U8 tmpbuf[UTF8_MAXLEN+1];
2385 UV uv = utf8_to_uv(s, slen, &ulen, 0);
2387 if (PL_op->op_private & OPpLOCALE) {
2390 uv = toLOWER_LC_uni(uv);
2393 uv = toLOWER_utf8(s);
2395 tend = uv_to_utf8(tmpbuf, uv);
2397 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
2399 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2400 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2405 s = (U8*)SvPV_force(sv, slen);
2406 Copy(tmpbuf, s, ulen, U8);
2410 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2412 SvUTF8_off(TARG); /* decontaminate */
2417 s = (U8*)SvPV_force(sv, slen);
2419 if (PL_op->op_private & OPpLOCALE) {
2422 *s = toLOWER_LC(*s);
2446 s = (U8*)SvPV(sv,len);
2448 SvUTF8_off(TARG); /* decontaminate */
2449 sv_setpvn(TARG, "", 0);
2453 (void)SvUPGRADE(TARG, SVt_PV);
2454 SvGROW(TARG, (len * 2) + 1);
2455 (void)SvPOK_only(TARG);
2456 d = (U8*)SvPVX(TARG);
2458 if (PL_op->op_private & OPpLOCALE) {
2462 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2468 d = uv_to_utf8(d, toUPPER_utf8( s ));
2474 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2479 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2481 SvUTF8_off(TARG); /* decontaminate */
2486 s = (U8*)SvPV_force(sv, len);
2488 register U8 *send = s + len;
2490 if (PL_op->op_private & OPpLOCALE) {
2493 for (; s < send; s++)
2494 *s = toUPPER_LC(*s);
2497 for (; s < send; s++)
2520 s = (U8*)SvPV(sv,len);
2522 SvUTF8_off(TARG); /* decontaminate */
2523 sv_setpvn(TARG, "", 0);
2527 (void)SvUPGRADE(TARG, SVt_PV);
2528 SvGROW(TARG, (len * 2) + 1);
2529 (void)SvPOK_only(TARG);
2530 d = (U8*)SvPVX(TARG);
2532 if (PL_op->op_private & OPpLOCALE) {
2536 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
2542 d = uv_to_utf8(d, toLOWER_utf8(s));
2548 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2553 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
2555 SvUTF8_off(TARG); /* decontaminate */
2561 s = (U8*)SvPV_force(sv, len);
2563 register U8 *send = s + len;
2565 if (PL_op->op_private & OPpLOCALE) {
2568 for (; s < send; s++)
2569 *s = toLOWER_LC(*s);
2572 for (; s < send; s++)
2587 register char *s = SvPV(sv,len);
2590 SvUTF8_off(TARG); /* decontaminate */
2592 (void)SvUPGRADE(TARG, SVt_PV);
2593 SvGROW(TARG, (len * 2) + 1);
2598 STRLEN ulen = UTF8SKIP(s);
2622 SvCUR_set(TARG, d - SvPVX(TARG));
2623 (void)SvPOK_only_UTF8(TARG);
2626 sv_setpvn(TARG, s, len);
2628 if (SvSMAGICAL(TARG))
2637 djSP; dMARK; dORIGMARK;
2639 register AV* av = (AV*)POPs;
2640 register I32 lval = PL_op->op_flags & OPf_MOD;
2641 I32 arybase = PL_curcop->cop_arybase;
2644 if (SvTYPE(av) == SVt_PVAV) {
2645 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2647 for (svp = MARK + 1; svp <= SP; svp++) {
2652 if (max > AvMAX(av))
2655 while (++MARK <= SP) {
2656 elem = SvIVx(*MARK);
2660 svp = av_fetch(av, elem, lval);
2662 if (!svp || *svp == &PL_sv_undef)
2663 DIE(aTHX_ PL_no_aelem, elem);
2664 if (PL_op->op_private & OPpLVAL_INTRO)
2665 save_aelem(av, elem, svp);
2667 *MARK = svp ? *svp : &PL_sv_undef;
2670 if (GIMME != G_ARRAY) {
2678 /* Associative arrays. */
2683 HV *hash = (HV*)POPs;
2685 I32 gimme = GIMME_V;
2686 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2689 /* might clobber stack_sp */
2690 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2695 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2696 if (SvUTF8((SV*)hash))
2698 if (gimme == G_ARRAY) {
2701 /* might clobber stack_sp */
2703 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2708 else if (gimme == G_SCALAR)
2727 I32 gimme = GIMME_V;
2728 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2732 if (PL_op->op_private & OPpSLICE) {
2736 hvtype = SvTYPE(hv);
2737 if (hvtype == SVt_PVHV) { /* hash element */
2738 while (++MARK <= SP) {
2739 sv = hv_delete_ent(hv, *MARK, discard, 0);
2740 *MARK = sv ? sv : &PL_sv_undef;
2743 else if (hvtype == SVt_PVAV) {
2744 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2745 while (++MARK <= SP) {
2746 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2747 *MARK = sv ? sv : &PL_sv_undef;
2750 else { /* pseudo-hash element */
2751 while (++MARK <= SP) {
2752 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2753 *MARK = sv ? sv : &PL_sv_undef;
2758 DIE(aTHX_ "Not a HASH reference");
2761 else if (gimme == G_SCALAR) {
2770 if (SvTYPE(hv) == SVt_PVHV)
2771 sv = hv_delete_ent(hv, keysv, discard, 0);
2772 else if (SvTYPE(hv) == SVt_PVAV) {
2773 if (PL_op->op_flags & OPf_SPECIAL)
2774 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2776 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2779 DIE(aTHX_ "Not a HASH reference");
2794 if (PL_op->op_private & OPpEXISTS_SUB) {
2798 cv = sv_2cv(sv, &hv, &gv, FALSE);
2801 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2807 if (SvTYPE(hv) == SVt_PVHV) {
2808 if (hv_exists_ent(hv, tmpsv, 0))
2811 else if (SvTYPE(hv) == SVt_PVAV) {
2812 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2813 if (av_exists((AV*)hv, SvIV(tmpsv)))
2816 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
2820 DIE(aTHX_ "Not a HASH reference");
2827 djSP; dMARK; dORIGMARK;
2828 register HV *hv = (HV*)POPs;
2829 register I32 lval = PL_op->op_flags & OPf_MOD;
2830 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2832 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2833 DIE(aTHX_ "Can't localize pseudo-hash element");
2835 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2836 while (++MARK <= SP) {
2840 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2841 svp = he ? &HeVAL(he) : 0;
2844 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2847 if (!svp || *svp == &PL_sv_undef) {
2849 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2851 if (PL_op->op_private & OPpLVAL_INTRO)
2852 save_helem(hv, keysv, svp);
2854 *MARK = svp ? *svp : &PL_sv_undef;
2857 if (GIMME != G_ARRAY) {
2865 /* List operators. */
2870 if (GIMME != G_ARRAY) {
2872 *MARK = *SP; /* unwanted list, return last item */
2874 *MARK = &PL_sv_undef;
2883 SV **lastrelem = PL_stack_sp;
2884 SV **lastlelem = PL_stack_base + POPMARK;
2885 SV **firstlelem = PL_stack_base + POPMARK + 1;
2886 register SV **firstrelem = lastlelem + 1;
2887 I32 arybase = PL_curcop->cop_arybase;
2888 I32 lval = PL_op->op_flags & OPf_MOD;
2889 I32 is_something_there = lval;
2891 register I32 max = lastrelem - lastlelem;
2892 register SV **lelem;
2895 if (GIMME != G_ARRAY) {
2896 ix = SvIVx(*lastlelem);
2901 if (ix < 0 || ix >= max)
2902 *firstlelem = &PL_sv_undef;
2904 *firstlelem = firstrelem[ix];
2910 SP = firstlelem - 1;
2914 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2920 if (ix < 0 || ix >= max)
2921 *lelem = &PL_sv_undef;
2923 is_something_there = TRUE;
2924 if (!(*lelem = firstrelem[ix]))
2925 *lelem = &PL_sv_undef;
2928 if (is_something_there)
2931 SP = firstlelem - 1;
2937 djSP; dMARK; dORIGMARK;
2938 I32 items = SP - MARK;
2939 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2940 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2947 djSP; dMARK; dORIGMARK;
2948 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2952 SV *val = NEWSV(46, 0);
2954 sv_setsv(val, *++MARK);
2955 else if (ckWARN(WARN_MISC))
2956 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
2957 (void)hv_store_ent(hv,key,val,0);
2966 djSP; dMARK; dORIGMARK;
2967 register AV *ary = (AV*)*++MARK;
2971 register I32 offset;
2972 register I32 length;
2979 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
2980 *MARK-- = SvTIED_obj((SV*)ary, mg);
2984 call_method("SPLICE",GIMME_V);
2993 offset = i = SvIVx(*MARK);
2995 offset += AvFILLp(ary) + 1;
2997 offset -= PL_curcop->cop_arybase;
2999 DIE(aTHX_ PL_no_aelem, i);
3001 length = SvIVx(*MARK++);
3003 length += AvFILLp(ary) - offset + 1;
3009 length = AvMAX(ary) + 1; /* close enough to infinity */
3013 length = AvMAX(ary) + 1;
3015 if (offset > AvFILLp(ary) + 1)
3016 offset = AvFILLp(ary) + 1;
3017 after = AvFILLp(ary) + 1 - (offset + length);
3018 if (after < 0) { /* not that much array */
3019 length += after; /* offset+length now in array */
3025 /* At this point, MARK .. SP-1 is our new LIST */
3028 diff = newlen - length;
3029 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3032 if (diff < 0) { /* shrinking the area */
3034 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3035 Copy(MARK, tmparyval, newlen, SV*);
3038 MARK = ORIGMARK + 1;
3039 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3040 MEXTEND(MARK, length);
3041 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3043 EXTEND_MORTAL(length);
3044 for (i = length, dst = MARK; i; i--) {
3045 sv_2mortal(*dst); /* free them eventualy */
3052 *MARK = AvARRAY(ary)[offset+length-1];
3055 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3056 SvREFCNT_dec(*dst++); /* free them now */
3059 AvFILLp(ary) += diff;
3061 /* pull up or down? */
3063 if (offset < after) { /* easier to pull up */
3064 if (offset) { /* esp. if nothing to pull */
3065 src = &AvARRAY(ary)[offset-1];
3066 dst = src - diff; /* diff is negative */
3067 for (i = offset; i > 0; i--) /* can't trust Copy */
3071 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3075 if (after) { /* anything to pull down? */
3076 src = AvARRAY(ary) + offset + length;
3077 dst = src + diff; /* diff is negative */
3078 Move(src, dst, after, SV*);
3080 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
3081 /* avoid later double free */
3085 dst[--i] = &PL_sv_undef;
3088 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3090 *dst = NEWSV(46, 0);
3091 sv_setsv(*dst++, *src++);
3093 Safefree(tmparyval);
3096 else { /* no, expanding (or same) */
3098 New(452, tmparyval, length, SV*); /* so remember deletion */
3099 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3102 if (diff > 0) { /* expanding */
3104 /* push up or down? */
3106 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3110 Move(src, dst, offset, SV*);
3112 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3114 AvFILLp(ary) += diff;
3117 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3118 av_extend(ary, AvFILLp(ary) + diff);
3119 AvFILLp(ary) += diff;
3122 dst = AvARRAY(ary) + AvFILLp(ary);
3124 for (i = after; i; i--) {
3131 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3132 *dst = NEWSV(46, 0);
3133 sv_setsv(*dst++, *src++);
3135 MARK = ORIGMARK + 1;
3136 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3138 Copy(tmparyval, MARK, length, SV*);
3140 EXTEND_MORTAL(length);
3141 for (i = length, dst = MARK; i; i--) {
3142 sv_2mortal(*dst); /* free them eventualy */
3146 Safefree(tmparyval);
3150 else if (length--) {
3151 *MARK = tmparyval[length];
3154 while (length-- > 0)
3155 SvREFCNT_dec(tmparyval[length]);
3157 Safefree(tmparyval);
3160 *MARK = &PL_sv_undef;
3168 djSP; dMARK; dORIGMARK; dTARGET;
3169 register AV *ary = (AV*)*++MARK;
3170 register SV *sv = &PL_sv_undef;
3173 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3174 *MARK-- = SvTIED_obj((SV*)ary, mg);
3178 call_method("PUSH",G_SCALAR|G_DISCARD);
3183 /* Why no pre-extend of ary here ? */
3184 for (++MARK; MARK <= SP; MARK++) {
3187 sv_setsv(sv, *MARK);
3192 PUSHi( AvFILL(ary) + 1 );
3200 SV *sv = av_pop(av);
3202 (void)sv_2mortal(sv);
3211 SV *sv = av_shift(av);
3216 (void)sv_2mortal(sv);
3223 djSP; dMARK; dORIGMARK; dTARGET;
3224 register AV *ary = (AV*)*++MARK;
3229 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
3230 *MARK-- = SvTIED_obj((SV*)ary, mg);
3234 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3239 av_unshift(ary, SP - MARK);
3242 sv_setsv(sv, *++MARK);
3243 (void)av_store(ary, i++, sv);
3247 PUSHi( AvFILL(ary) + 1 );
3257 if (GIMME == G_ARRAY) {
3264 /* safe as long as stack cannot get extended in the above */
3269 register char *down;
3274 SvUTF8_off(TARG); /* decontaminate */
3276 do_join(TARG, &PL_sv_no, MARK, SP);
3278 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3279 up = SvPV_force(TARG, len);
3281 if (DO_UTF8(TARG)) { /* first reverse each character */
3282 U8* s = (U8*)SvPVX(TARG);
3283 U8* send = (U8*)(s + len);
3292 down = (char*)(s - 1);
3293 if (s > send || !((*down & 0xc0) == 0x80)) {
3294 if (ckWARN_d(WARN_UTF8))
3295 Perl_warner(aTHX_ WARN_UTF8,
3296 "Malformed UTF-8 character");
3308 down = SvPVX(TARG) + len - 1;
3314 (void)SvPOK_only_UTF8(TARG);
3323 S_mul128(pTHX_ SV *sv, U8 m)
3326 char *s = SvPV(sv, len);
3330 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3331 SV *tmpNew = newSVpvn("0000000000", 10);
3333 sv_catsv(tmpNew, sv);
3334 SvREFCNT_dec(sv); /* free old sv */
3339 while (!*t) /* trailing '\0'? */
3342 i = ((*t - '0') << 7) + m;
3343 *(t--) = '0' + (i % 10);
3349 /* Explosives and implosives. */
3351 #if 'I' == 73 && 'J' == 74
3352 /* On an ASCII/ISO kind of system */
3353 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3356 Some other sort of character set - use memchr() so we don't match
3359 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3366 I32 start_sp_offset = SP - PL_stack_base;
3367 I32 gimme = GIMME_V;
3371 register char *pat = SvPV(left, llen);
3372 register char *s = SvPV(right, rlen);
3373 char *strend = s + rlen;
3375 register char *patend = pat + llen;
3381 /* These must not be in registers: */
3398 register U32 culong;
3402 #ifdef PERL_NATINT_PACK
3403 int natint; /* native integer */
3404 int unatint; /* unsigned native integer */
3407 if (gimme != G_ARRAY) { /* arrange to do first one only */
3409 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3410 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3412 while (isDIGIT(*patend) || *patend == '*')
3418 while (pat < patend) {
3420 datumtype = *pat++ & 0xFF;
3421 #ifdef PERL_NATINT_PACK
3424 if (isSPACE(datumtype))
3426 if (datumtype == '#') {
3427 while (pat < patend && *pat != '\n')
3432 char *natstr = "sSiIlL";
3434 if (strchr(natstr, datumtype)) {
3435 #ifdef PERL_NATINT_PACK
3441 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3446 else if (*pat == '*') {
3447 len = strend - strbeg; /* long enough */
3451 else if (isDIGIT(*pat)) {
3453 while (isDIGIT(*pat)) {
3454 len = (len * 10) + (*pat++ - '0');
3456 DIE(aTHX_ "Repeat count in unpack overflows");
3460 len = (datumtype != '@');
3464 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3465 case ',': /* grandfather in commas but with a warning */
3466 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3467 Perl_warner(aTHX_ WARN_UNPACK,
3468 "Invalid type in unpack: '%c'", (int)datumtype);
3471 if (len == 1 && pat[-1] != '1')
3480 if (len > strend - strbeg)
3481 DIE(aTHX_ "@ outside of string");
3485 if (len > s - strbeg)
3486 DIE(aTHX_ "X outside of string");
3490 if (len > strend - s)
3491 DIE(aTHX_ "x outside of string");
3495 if (start_sp_offset >= SP - PL_stack_base)
3496 DIE(aTHX_ "/ must follow a numeric type");
3499 pat++; /* ignore '*' for compatibility with pack */
3501 DIE(aTHX_ "/ cannot take a count" );
3508 if (len > strend - s)
3511 goto uchar_checksum;
3512 sv = NEWSV(35, len);
3513 sv_setpvn(sv, s, len);
3515 if (datumtype == 'A' || datumtype == 'Z') {
3516 aptr = s; /* borrow register */
3517 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3522 else { /* 'A' strips both nulls and spaces */
3523 s = SvPVX(sv) + len - 1;
3524 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3528 SvCUR_set(sv, s - SvPVX(sv));
3529 s = aptr; /* unborrow register */
3531 XPUSHs(sv_2mortal(sv));
3535 if (star || len > (strend - s) * 8)
3536 len = (strend - s) * 8;
3539 Newz(601, PL_bitcount, 256, char);
3540 for (bits = 1; bits < 256; bits++) {
3541 if (bits & 1) PL_bitcount[bits]++;
3542 if (bits & 2) PL_bitcount[bits]++;
3543 if (bits & 4) PL_bitcount[bits]++;
3544 if (bits & 8) PL_bitcount[bits]++;
3545 if (bits & 16) PL_bitcount[bits]++;
3546 if (bits & 32) PL_bitcount[bits]++;
3547 if (bits & 64) PL_bitcount[bits]++;
3548 if (bits & 128) PL_bitcount[bits]++;
3552 culong += PL_bitcount[*(unsigned char*)s++];
3557 if (datumtype == 'b') {
3559 if (bits & 1) culong++;
3565 if (bits & 128) culong++;
3572 sv = NEWSV(35, len + 1);
3576 if (datumtype == 'b') {
3578 for (len = 0; len < aint; len++) {
3579 if (len & 7) /*SUPPRESS 595*/
3583 *str++ = '0' + (bits & 1);
3588 for (len = 0; len < aint; len++) {
3593 *str++ = '0' + ((bits & 128) != 0);
3597 XPUSHs(sv_2mortal(sv));
3601 if (star || len > (strend - s) * 2)
3602 len = (strend - s) * 2;
3603 sv = NEWSV(35, len + 1);
3607 if (datumtype == 'h') {
3609 for (len = 0; len < aint; len++) {
3614 *str++ = PL_hexdigit[bits & 15];
3619 for (len = 0; len < aint; len++) {
3624 *str++ = PL_hexdigit[(bits >> 4) & 15];
3628 XPUSHs(sv_2mortal(sv));
3631 if (len > strend - s)
3636 if (aint >= 128) /* fake up signed chars */
3646 if (aint >= 128) /* fake up signed chars */
3649 sv_setiv(sv, (IV)aint);
3650 PUSHs(sv_2mortal(sv));
3655 if (len > strend - s)
3670 sv_setiv(sv, (IV)auint);
3671 PUSHs(sv_2mortal(sv));
3676 if (len > strend - s)
3679 while (len-- > 0 && s < strend) {
3681 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3685 cdouble += (NV)auint;
3693 while (len-- > 0 && s < strend) {
3695 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3699 sv_setuv(sv, (UV)auint);
3700 PUSHs(sv_2mortal(sv));
3705 #if SHORTSIZE == SIZE16
3706 along = (strend - s) / SIZE16;
3708 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3713 #if SHORTSIZE != SIZE16
3717 COPYNN(s, &ashort, sizeof(short));
3728 #if SHORTSIZE > SIZE16
3740 #if SHORTSIZE != SIZE16
3744 COPYNN(s, &ashort, sizeof(short));
3747 sv_setiv(sv, (IV)ashort);
3748 PUSHs(sv_2mortal(sv));
3756 #if SHORTSIZE > SIZE16
3762 sv_setiv(sv, (IV)ashort);
3763 PUSHs(sv_2mortal(sv));
3771 #if SHORTSIZE == SIZE16
3772 along = (strend - s) / SIZE16;
3774 unatint = natint && datumtype == 'S';
3775 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3780 #if SHORTSIZE != SIZE16
3782 unsigned short aushort;
3784 COPYNN(s, &aushort, sizeof(unsigned short));
3785 s += sizeof(unsigned short);
3793 COPY16(s, &aushort);
3796 if (datumtype == 'n')
3797 aushort = PerlSock_ntohs(aushort);
3800 if (datumtype == 'v')
3801 aushort = vtohs(aushort);
3810 #if SHORTSIZE != SIZE16
3812 unsigned short aushort;
3814 COPYNN(s, &aushort, sizeof(unsigned short));
3815 s += sizeof(unsigned short);
3817 sv_setiv(sv, (UV)aushort);
3818 PUSHs(sv_2mortal(sv));
3825 COPY16(s, &aushort);
3829 if (datumtype == 'n')
3830 aushort = PerlSock_ntohs(aushort);
3833 if (datumtype == 'v')
3834 aushort = vtohs(aushort);
3836 sv_setiv(sv, (UV)aushort);
3837 PUSHs(sv_2mortal(sv));
3843 along = (strend - s) / sizeof(int);
3848 Copy(s, &aint, 1, int);
3851 cdouble += (NV)aint;
3860 Copy(s, &aint, 1, int);
3864 /* Without the dummy below unpack("i", pack("i",-1))
3865 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3866 * cc with optimization turned on.
3868 * The bug was detected in
3869 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3870 * with optimization (-O4) turned on.
3871 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3872 * does not have this problem even with -O4.
3874 * This bug was reported as DECC_BUGS 1431
3875 * and tracked internally as GEM_BUGS 7775.
3877 * The bug is fixed in
3878 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3879 * UNIX V4.0F support: DEC C V5.9-006 or later
3880 * UNIX V4.0E support: DEC C V5.8-011 or later
3883 * See also few lines later for the same bug.
3886 sv_setiv(sv, (IV)aint) :
3888 sv_setiv(sv, (IV)aint);
3889 PUSHs(sv_2mortal(sv));
3894 along = (strend - s) / sizeof(unsigned int);
3899 Copy(s, &auint, 1, unsigned int);
3900 s += sizeof(unsigned int);
3902 cdouble += (NV)auint;
3911 Copy(s, &auint, 1, unsigned int);
3912 s += sizeof(unsigned int);
3915 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3916 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3917 * See details few lines earlier. */
3919 sv_setuv(sv, (UV)auint) :
3921 sv_setuv(sv, (UV)auint);
3922 PUSHs(sv_2mortal(sv));
3927 #if LONGSIZE == SIZE32
3928 along = (strend - s) / SIZE32;
3930 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3935 #if LONGSIZE != SIZE32
3938 COPYNN(s, &along, sizeof(long));
3941 cdouble += (NV)along;
3950 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3954 #if LONGSIZE > SIZE32
3955 if (along > 2147483647)
3956 along -= 4294967296;
3960 cdouble += (NV)along;
3969 #if LONGSIZE != SIZE32
3972 COPYNN(s, &along, sizeof(long));
3975 sv_setiv(sv, (IV)along);
3976 PUSHs(sv_2mortal(sv));
3983 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3987 #if LONGSIZE > SIZE32
3988 if (along > 2147483647)
3989 along -= 4294967296;
3993 sv_setiv(sv, (IV)along);
3994 PUSHs(sv_2mortal(sv));
4002 #if LONGSIZE == SIZE32
4003 along = (strend - s) / SIZE32;
4005 unatint = natint && datumtype == 'L';
4006 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
4011 #if LONGSIZE != SIZE32
4013 unsigned long aulong;
4015 COPYNN(s, &aulong, sizeof(unsigned long));
4016 s += sizeof(unsigned long);
4018 cdouble += (NV)aulong;
4030 if (datumtype == 'N')
4031 aulong = PerlSock_ntohl(aulong);
4034 if (datumtype == 'V')
4035 aulong = vtohl(aulong);
4038 cdouble += (NV)aulong;
4047 #if LONGSIZE != SIZE32
4049 unsigned long aulong;
4051 COPYNN(s, &aulong, sizeof(unsigned long));
4052 s += sizeof(unsigned long);
4054 sv_setuv(sv, (UV)aulong);
4055 PUSHs(sv_2mortal(sv));
4065 if (datumtype == 'N')
4066 aulong = PerlSock_ntohl(aulong);
4069 if (datumtype == 'V')
4070 aulong = vtohl(aulong);
4073 sv_setuv(sv, (UV)aulong);
4074 PUSHs(sv_2mortal(sv));
4080 along = (strend - s) / sizeof(char*);
4086 if (sizeof(char*) > strend - s)
4089 Copy(s, &aptr, 1, char*);
4095 PUSHs(sv_2mortal(sv));
4105 while ((len > 0) && (s < strend)) {
4106 auv = (auv << 7) | (*s & 0x7f);
4107 if (!(*s++ & 0x80)) {
4111 PUSHs(sv_2mortal(sv));
4115 else if (++bytes >= sizeof(UV)) { /* promote to string */
4119 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
4120 while (s < strend) {
4121 sv = mul128(sv, *s & 0x7f);
4122 if (!(*s++ & 0x80)) {
4131 PUSHs(sv_2mortal(sv));
4136 if ((s >= strend) && bytes)
4137 DIE(aTHX_ "Unterminated compressed integer");
4142 if (sizeof(char*) > strend - s)
4145 Copy(s, &aptr, 1, char*);
4150 sv_setpvn(sv, aptr, len);
4151 PUSHs(sv_2mortal(sv));
4155 along = (strend - s) / sizeof(Quad_t);
4161 if (s + sizeof(Quad_t) > strend)
4164 Copy(s, &aquad, 1, Quad_t);
4165 s += sizeof(Quad_t);
4168 if (aquad >= IV_MIN && aquad <= IV_MAX)
4169 sv_setiv(sv, (IV)aquad);
4171 sv_setnv(sv, (NV)aquad);
4172 PUSHs(sv_2mortal(sv));
4176 along = (strend - s) / sizeof(Quad_t);
4182 if (s + sizeof(Uquad_t) > strend)
4185 Copy(s, &auquad, 1, Uquad_t);
4186 s += sizeof(Uquad_t);
4189 if (auquad <= UV_MAX)
4190 sv_setuv(sv, (UV)auquad);
4192 sv_setnv(sv, (NV)auquad);
4193 PUSHs(sv_2mortal(sv));
4197 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4200 along = (strend - s) / sizeof(float);
4205 Copy(s, &afloat, 1, float);
4214 Copy(s, &afloat, 1, float);
4217 sv_setnv(sv, (NV)afloat);
4218 PUSHs(sv_2mortal(sv));
4224 along = (strend - s) / sizeof(double);
4229 Copy(s, &adouble, 1, double);
4230 s += sizeof(double);
4238 Copy(s, &adouble, 1, double);
4239 s += sizeof(double);
4241 sv_setnv(sv, (NV)adouble);
4242 PUSHs(sv_2mortal(sv));
4248 * Initialise the decode mapping. By using a table driven
4249 * algorithm, the code will be character-set independent
4250 * (and just as fast as doing character arithmetic)
4252 if (PL_uudmap['M'] == 0) {
4255 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4256 PL_uudmap[(U8)PL_uuemap[i]] = i;
4258 * Because ' ' and '`' map to the same value,
4259 * we need to decode them both the same.
4264 along = (strend - s) * 3 / 4;
4265 sv = NEWSV(42, along);
4268 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4273 len = PL_uudmap[*(U8*)s++] & 077;
4275 if (s < strend && ISUUCHAR(*s))
4276 a = PL_uudmap[*(U8*)s++] & 077;
4279 if (s < strend && ISUUCHAR(*s))
4280 b = PL_uudmap[*(U8*)s++] & 077;
4283 if (s < strend && ISUUCHAR(*s))
4284 c = PL_uudmap[*(U8*)s++] & 077;
4287 if (s < strend && ISUUCHAR(*s))
4288 d = PL_uudmap[*(U8*)s++] & 077;
4291 hunk[0] = (a << 2) | (b >> 4);
4292 hunk[1] = (b << 4) | (c >> 2);
4293 hunk[2] = (c << 6) | d;
4294 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4299 else if (s[1] == '\n') /* possible checksum byte */
4302 XPUSHs(sv_2mortal(sv));
4307 if (strchr("fFdD", datumtype) ||
4308 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4312 while (checksum >= 16) {
4316 while (checksum >= 4) {
4322 along = (1 << checksum) - 1;
4323 while (cdouble < 0.0)
4325 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4326 sv_setnv(sv, cdouble);
4329 if (checksum < 32) {
4330 aulong = (1 << checksum) - 1;
4333 sv_setuv(sv, (UV)culong);
4335 XPUSHs(sv_2mortal(sv));
4339 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4340 PUSHs(&PL_sv_undef);
4345 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4349 *hunk = PL_uuemap[len];
4350 sv_catpvn(sv, hunk, 1);
4353 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4354 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4355 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4356 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4357 sv_catpvn(sv, hunk, 4);
4362 char r = (len > 1 ? s[1] : '\0');
4363 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4364 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4365 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4366 hunk[3] = PL_uuemap[0];
4367 sv_catpvn(sv, hunk, 4);
4369 sv_catpvn(sv, "\n", 1);
4373 S_is_an_int(pTHX_ char *s, STRLEN l)
4376 SV *result = newSVpvn(s, l);
4377 char *result_c = SvPV(result, n_a); /* convenience */
4378 char *out = result_c;
4388 SvREFCNT_dec(result);
4411 SvREFCNT_dec(result);
4417 SvCUR_set(result, out - result_c);
4421 /* pnum must be '\0' terminated */
4423 S_div128(pTHX_ SV *pnum, bool *done)
4426 char *s = SvPV(pnum, len);
4435 i = m * 10 + (*t - '0');
4437 r = (i >> 7); /* r < 10 */
4444 SvCUR_set(pnum, (STRLEN) (t - s));
4451 djSP; dMARK; dORIGMARK; dTARGET;
4452 register SV *cat = TARG;
4455 register char *pat = SvPVx(*++MARK, fromlen);
4457 register char *patend = pat + fromlen;
4462 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4463 static char *space10 = " ";
4465 /* These must not be in registers: */
4480 #ifdef PERL_NATINT_PACK
4481 int natint; /* native integer */
4486 sv_setpvn(cat, "", 0);
4488 while (pat < patend) {
4489 SV *lengthcode = Nullsv;
4490 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4491 datumtype = *pat++ & 0xFF;
4492 #ifdef PERL_NATINT_PACK
4495 if (isSPACE(datumtype)) {
4499 if (datumtype == 'U' && pat == patcopy+1)
4501 if (datumtype == '#') {
4502 while (pat < patend && *pat != '\n')
4507 char *natstr = "sSiIlL";
4509 if (strchr(natstr, datumtype)) {
4510 #ifdef PERL_NATINT_PACK
4516 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4519 len = strchr("@Xxu", datumtype) ? 0 : items;
4522 else if (isDIGIT(*pat)) {
4524 while (isDIGIT(*pat)) {
4525 len = (len * 10) + (*pat++ - '0');
4527 DIE(aTHX_ "Repeat count in pack overflows");
4534 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
4535 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4536 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4537 ? *MARK : &PL_sv_no)
4538 + (*pat == 'Z' ? 1 : 0)));
4542 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4543 case ',': /* grandfather in commas but with a warning */
4544 if (commas++ == 0 && ckWARN(WARN_PACK))
4545 Perl_warner(aTHX_ WARN_PACK,
4546 "Invalid type in pack: '%c'", (int)datumtype);
4549 DIE(aTHX_ "%% may only be used in unpack");
4560 if (SvCUR(cat) < len)
4561 DIE(aTHX_ "X outside of string");
4568 sv_catpvn(cat, null10, 10);
4571 sv_catpvn(cat, null10, len);
4577 aptr = SvPV(fromstr, fromlen);
4578 if (pat[-1] == '*') {
4580 if (datumtype == 'Z')
4583 if (fromlen >= len) {
4584 sv_catpvn(cat, aptr, len);
4585 if (datumtype == 'Z')
4586 *(SvEND(cat)-1) = '\0';
4589 sv_catpvn(cat, aptr, fromlen);
4591 if (datumtype == 'A') {
4593 sv_catpvn(cat, space10, 10);
4596 sv_catpvn(cat, space10, len);
4600 sv_catpvn(cat, null10, 10);
4603 sv_catpvn(cat, null10, len);
4615 str = SvPV(fromstr, fromlen);
4619 SvCUR(cat) += (len+7)/8;
4620 SvGROW(cat, SvCUR(cat) + 1);
4621 aptr = SvPVX(cat) + aint;
4626 if (datumtype == 'B') {
4627 for (len = 0; len++ < aint;) {
4628 items |= *str++ & 1;
4632 *aptr++ = items & 0xff;
4638 for (len = 0; len++ < aint;) {
4644 *aptr++ = items & 0xff;
4650 if (datumtype == 'B')
4651 items <<= 7 - (aint & 7);
4653 items >>= 7 - (aint & 7);
4654 *aptr++ = items & 0xff;
4656 str = SvPVX(cat) + SvCUR(cat);
4671 str = SvPV(fromstr, fromlen);
4675 SvCUR(cat) += (len+1)/2;
4676 SvGROW(cat, SvCUR(cat) + 1);
4677 aptr = SvPVX(cat) + aint;
4682 if (datumtype == 'H') {
4683 for (len = 0; len++ < aint;) {
4685 items |= ((*str++ & 15) + 9) & 15;
4687 items |= *str++ & 15;
4691 *aptr++ = items & 0xff;
4697 for (len = 0; len++ < aint;) {
4699 items |= (((*str++ & 15) + 9) & 15) << 4;
4701 items |= (*str++ & 15) << 4;
4705 *aptr++ = items & 0xff;
4711 *aptr++ = items & 0xff;
4712 str = SvPVX(cat) + SvCUR(cat);
4723 aint = SvIV(fromstr);
4725 sv_catpvn(cat, &achar, sizeof(char));
4731 auint = SvUV(fromstr);
4732 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
4733 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4738 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4743 afloat = (float)SvNV(fromstr);
4744 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4751 adouble = (double)SvNV(fromstr);
4752 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4758 ashort = (I16)SvIV(fromstr);
4760 ashort = PerlSock_htons(ashort);
4762 CAT16(cat, &ashort);
4768 ashort = (I16)SvIV(fromstr);
4770 ashort = htovs(ashort);
4772 CAT16(cat, &ashort);
4776 #if SHORTSIZE != SIZE16
4778 unsigned short aushort;
4782 aushort = SvUV(fromstr);
4783 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4793 aushort = (U16)SvUV(fromstr);
4794 CAT16(cat, &aushort);
4800 #if SHORTSIZE != SIZE16
4806 ashort = SvIV(fromstr);
4807 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4815 ashort = (I16)SvIV(fromstr);
4816 CAT16(cat, &ashort);
4823 auint = SvUV(fromstr);
4824 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4830 adouble = Perl_floor(SvNV(fromstr));
4833 DIE(aTHX_ "Cannot compress negative numbers");
4836 #if UVSIZE > 4 && UVSIZE >= NVSIZE
4837 adouble <= 0xffffffff
4839 # ifdef CXUX_BROKEN_CONSTANT_CONVERT
4840 adouble <= UV_MAX_cxux
4847 char buf[1 + sizeof(UV)];
4848 char *in = buf + sizeof(buf);
4849 UV auv = U_V(adouble);
4852 *--in = (auv & 0x7f) | 0x80;
4855 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4856 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4858 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4859 char *from, *result, *in;
4864 /* Copy string and check for compliance */
4865 from = SvPV(fromstr, len);
4866 if ((norm = is_an_int(from, len)) == NULL)
4867 DIE(aTHX_ "can compress only unsigned integer");
4869 New('w', result, len, char);
4873 *--in = div128(norm, &done) | 0x80;
4874 result[len - 1] &= 0x7F; /* clear continue bit */
4875 sv_catpvn(cat, in, (result + len) - in);
4877 SvREFCNT_dec(norm); /* free norm */
4879 else if (SvNOKp(fromstr)) {
4880 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4881 char *in = buf + sizeof(buf);
4884 double next = floor(adouble / 128);
4885 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4886 if (in <= buf) /* this cannot happen ;-) */
4887 DIE(aTHX_ "Cannot compress integer");
4890 } while (adouble > 0);
4891 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4892 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4895 DIE(aTHX_ "Cannot compress non integer");
4901 aint = SvIV(fromstr);
4902 sv_catpvn(cat, (char*)&aint, sizeof(int));
4908 aulong = SvUV(fromstr);
4910 aulong = PerlSock_htonl(aulong);
4912 CAT32(cat, &aulong);
4918 aulong = SvUV(fromstr);
4920 aulong = htovl(aulong);
4922 CAT32(cat, &aulong);
4926 #if LONGSIZE != SIZE32
4928 unsigned long aulong;
4932 aulong = SvUV(fromstr);
4933 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4941 aulong = SvUV(fromstr);
4942 CAT32(cat, &aulong);
4947 #if LONGSIZE != SIZE32
4953 along = SvIV(fromstr);
4954 sv_catpvn(cat, (char *)&along, sizeof(long));
4962 along = SvIV(fromstr);
4971 auquad = (Uquad_t)SvUV(fromstr);
4972 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4978 aquad = (Quad_t)SvIV(fromstr);
4979 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4984 len = 1; /* assume SV is correct length */
4989 if (fromstr == &PL_sv_undef)
4993 /* XXX better yet, could spirit away the string to
4994 * a safe spot and hang on to it until the result
4995 * of pack() (and all copies of the result) are
4998 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
4999 || (SvPADTMP(fromstr)
5000 && !SvREADONLY(fromstr))))
5002 Perl_warner(aTHX_ WARN_PACK,
5003 "Attempt to pack pointer to temporary value");
5005 if (SvPOK(fromstr) || SvNIOK(fromstr))
5006 aptr = SvPV(fromstr,n_a);
5008 aptr = SvPV_force(fromstr,n_a);
5010 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5015 aptr = SvPV(fromstr, fromlen);
5016 SvGROW(cat, fromlen * 4 / 3);
5021 while (fromlen > 0) {
5028 doencodes(cat, aptr, todo);
5047 register IV limit = POPi; /* note, negative is forever */
5049 bool doutf8 = DO_UTF8(sv);
5051 register char *s = SvPV(sv, len);
5052 char *strend = s + len;
5054 register REGEXP *rx;
5058 I32 maxiters = (strend - s) + 10;
5061 I32 origlimit = limit;
5064 AV *oldstack = PL_curstack;
5065 I32 gimme = GIMME_V;
5066 I32 oldsave = PL_savestack_ix;
5067 I32 make_mortal = 1;
5068 MAGIC *mg = (MAGIC *) NULL;
5071 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5076 DIE(aTHX_ "panic: do_split");
5077 rx = pm->op_pmregexp;
5079 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5080 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5082 if (pm->op_pmreplroot) {
5084 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5086 ary = GvAVn((GV*)pm->op_pmreplroot);
5089 else if (gimme != G_ARRAY)
5091 ary = (AV*)PL_curpad[0];
5093 ary = GvAVn(PL_defgv);
5094 #endif /* USE_THREADS */
5097 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5103 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
5105 XPUSHs(SvTIED_obj((SV*)ary, mg));
5111 for (i = AvFILLp(ary); i >= 0; i--)
5112 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5114 /* temporarily switch stacks */
5115 SWITCHSTACK(PL_curstack, ary);
5119 base = SP - PL_stack_base;
5121 if (pm->op_pmflags & PMf_SKIPWHITE) {
5122 if (pm->op_pmflags & PMf_LOCALE) {
5123 while (isSPACE_LC(*s))
5131 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
5132 SAVEINT(PL_multiline);
5133 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
5137 limit = maxiters + 2;
5138 if (pm->op_pmflags & PMf_WHITE) {
5141 while (m < strend &&
5142 !((pm->op_pmflags & PMf_LOCALE)
5143 ? isSPACE_LC(*m) : isSPACE(*m)))
5148 dstr = NEWSV(30, m-s);
5149 sv_setpvn(dstr, s, m-s);
5153 (void)SvUTF8_on(dstr);
5157 while (s < strend &&
5158 ((pm->op_pmflags & PMf_LOCALE)
5159 ? isSPACE_LC(*s) : isSPACE(*s)))
5163 else if (strEQ("^", rx->precomp)) {
5166 for (m = s; m < strend && *m != '\n'; m++) ;
5170 dstr = NEWSV(30, m-s);
5171 sv_setpvn(dstr, s, m-s);
5175 (void)SvUTF8_on(dstr);
5180 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5181 && (rx->reganch & ROPT_CHECK_ALL)
5182 && !(rx->reganch & ROPT_ANCH)) {
5183 int tail = (rx->reganch & RE_INTUIT_TAIL);
5184 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5187 if (len == 1 && !tail) {
5189 char c = *SvPV(csv, n_a);
5192 for (m = s; m < strend && *m != c; m++) ;
5195 dstr = NEWSV(30, m-s);
5196 sv_setpvn(dstr, s, m-s);
5200 (void)SvUTF8_on(dstr);
5202 /* The rx->minlen is in characters but we want to step
5203 * s ahead by bytes. */
5204 s = m + (doutf8 ? SvCUR(csv) : len);
5209 while (s < strend && --limit &&
5210 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5211 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5214 dstr = NEWSV(31, m-s);
5215 sv_setpvn(dstr, s, m-s);
5219 (void)SvUTF8_on(dstr);
5221 /* The rx->minlen is in characters but we want to step
5222 * s ahead by bytes. */
5223 s = m + (doutf8 ? SvCUR(csv) : len); /* Fake \n at the end */
5228 maxiters += (strend - s) * rx->nparens;
5229 while (s < strend && --limit
5230 /* && (!rx->check_substr
5231 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5233 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5234 1 /* minend */, sv, NULL, 0))
5236 TAINT_IF(RX_MATCH_TAINTED(rx));
5237 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5242 strend = s + (strend - m);
5244 m = rx->startp[0] + orig;
5245 dstr = NEWSV(32, m-s);
5246 sv_setpvn(dstr, s, m-s);
5250 (void)SvUTF8_on(dstr);
5253 for (i = 1; i <= rx->nparens; i++) {
5254 s = rx->startp[i] + orig;
5255 m = rx->endp[i] + orig;
5257 dstr = NEWSV(33, m-s);
5258 sv_setpvn(dstr, s, m-s);
5261 dstr = NEWSV(33, 0);
5265 (void)SvUTF8_on(dstr);
5269 s = rx->endp[0] + orig;
5273 LEAVE_SCOPE(oldsave);
5274 iters = (SP - PL_stack_base) - base;
5275 if (iters > maxiters)
5276 DIE(aTHX_ "Split loop");
5278 /* keep field after final delim? */
5279 if (s < strend || (iters && origlimit)) {
5280 STRLEN l = strend - s;
5281 dstr = NEWSV(34, l);
5282 sv_setpvn(dstr, s, l);
5286 (void)SvUTF8_on(dstr);
5290 else if (!origlimit) {
5291 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5297 SWITCHSTACK(ary, oldstack);
5298 if (SvSMAGICAL(ary)) {
5303 if (gimme == G_ARRAY) {
5305 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5313 call_method("PUSH",G_SCALAR|G_DISCARD);
5316 if (gimme == G_ARRAY) {
5317 /* EXTEND should not be needed - we just popped them */
5319 for (i=0; i < iters; i++) {
5320 SV **svp = av_fetch(ary, i, FALSE);
5321 PUSHs((svp) ? *svp : &PL_sv_undef);
5328 if (gimme == G_ARRAY)
5331 if (iters || !pm->op_pmreplroot) {
5341 Perl_unlock_condpair(pTHX_ void *svv)
5344 MAGIC *mg = mg_find((SV*)svv, 'm');
5347 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5348 MUTEX_LOCK(MgMUTEXP(mg));
5349 if (MgOWNER(mg) != thr)
5350 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5352 COND_SIGNAL(MgOWNERCONDP(mg));
5353 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5354 PTR2UV(thr), PTR2UV(svv));)
5355 MUTEX_UNLOCK(MgMUTEXP(mg));
5357 #endif /* USE_THREADS */
5366 #endif /* USE_THREADS */
5367 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5368 || SvTYPE(retsv) == SVt_PVCV) {
5369 retsv = refto(retsv);
5380 if (PL_op->op_private & OPpLVAL_INTRO)
5381 PUSHs(*save_threadsv(PL_op->op_targ));
5383 PUSHs(THREADSV(PL_op->op_targ));
5386 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5387 #endif /* USE_THREADS */