3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
27 static double UV_MAX_cxux = ((double)UV_MAX);
31 * Types used in bitwise operations.
33 * Normally we'd just use IV and UV. However, some hardware and
34 * software combinations (e.g. Alpha and current OSF/1) don't have a
35 * floating-point type to use for NV that has adequate bits to fully
36 * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
38 * It just so happens that "int" is the right size almost everywhere.
44 * Mask used after bitwise operations.
46 * There is at least one realm (Cray word machines) that doesn't
47 * have an integral type (except char) small enough to be represented
48 * in a double without loss; that is, it has no 32-bit type.
50 #if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
52 # define BW_MASK ((1 << BW_BITS) - 1)
53 # define BW_SIGN (1 << (BW_BITS - 1))
54 # define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
55 # define BWu(u) ((u) & BW_MASK)
62 * Offset for integer pack/unpack.
64 * On architectures where I16 and I32 aren't really 16 and 32 bits,
65 * which for now are all Crays, pack and unpack have to play games.
69 * These values are required for portability of pack() output.
70 * If they're not right on your machine, then pack() and unpack()
71 * wouldn't work right anyway; you'll need to apply the Cray hack.
72 * (I'd like to check them with #if, but you can't use sizeof() in
73 * the preprocessor.) --???
76 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
77 defines are now in config.h. --Andy Dougherty April 1998
82 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
85 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
86 # define PERL_NATINT_PACK
89 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
90 # if BYTEORDER == 0x12345678
91 # define OFF16(p) (char*)(p)
92 # define OFF32(p) (char*)(p)
94 # if BYTEORDER == 0x87654321
95 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
96 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
98 }}}} bad cray byte order
101 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
102 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
103 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
104 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
105 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
107 # define COPY16(s,p) Copy(s, p, SIZE16, char)
108 # define COPY32(s,p) Copy(s, p, SIZE32, char)
109 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
110 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
111 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
114 /* variations on pp_null */
120 /* XXX I can't imagine anyone who doesn't have this actually _needs_
121 it, since pid_t is an integral type.
124 #ifdef NEED_GETPID_PROTO
125 extern Pid_t getpid (void);
131 if (GIMME_V == G_SCALAR)
132 XPUSHs(&PL_sv_undef);
146 if (PL_op->op_private & OPpLVAL_INTRO)
147 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
149 if (PL_op->op_flags & OPf_REF) {
153 if (GIMME == G_ARRAY) {
154 I32 maxarg = AvFILL((AV*)TARG) + 1;
156 if (SvMAGICAL(TARG)) {
158 for (i=0; i < maxarg; i++) {
159 SV **svp = av_fetch((AV*)TARG, i, FALSE);
160 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
164 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
169 SV* sv = sv_newmortal();
170 I32 maxarg = AvFILL((AV*)TARG) + 1;
171 sv_setiv(sv, maxarg);
183 if (PL_op->op_private & OPpLVAL_INTRO)
184 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
185 if (PL_op->op_flags & OPf_REF)
188 if (gimme == G_ARRAY) {
191 else if (gimme == G_SCALAR) {
192 SV* sv = sv_newmortal();
193 if (HvFILL((HV*)TARG))
194 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
195 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
205 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
216 tryAMAGICunDEREF(to_gv);
219 if (SvTYPE(sv) == SVt_PVIO) {
220 GV *gv = (GV*) sv_newmortal();
221 gv_init(gv, 0, "", 0, 0);
222 GvIOp(gv) = (IO *)sv;
223 (void)SvREFCNT_inc(sv);
226 else if (SvTYPE(sv) != SVt_PVGV)
227 DIE(aTHX_ "Not a GLOB reference");
230 if (SvTYPE(sv) != SVt_PVGV) {
234 if (SvGMAGICAL(sv)) {
240 /* If this is a 'my' scalar and flag is set then vivify
243 if (PL_op->op_private & OPpDEREF) {
244 GV *gv = (GV *) newSV(0);
247 if (cUNOP->op_first->op_type == OP_PADSV) {
248 SV **namep = av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
249 if (namep && *namep) {
250 name = SvPV(*namep,len);
257 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
258 sv_upgrade(sv, SVt_RV);
259 SvRV(sv) = (SV *) gv;
264 if (PL_op->op_flags & OPf_REF ||
265 PL_op->op_private & HINT_STRICT_REFS)
266 DIE(aTHX_ PL_no_usym, "a symbol");
267 if (ckWARN(WARN_UNINITIALIZED))
268 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
272 if ((PL_op->op_flags & OPf_SPECIAL) &&
273 !(PL_op->op_flags & OPf_MOD))
275 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
280 if (PL_op->op_private & HINT_STRICT_REFS)
281 DIE(aTHX_ PL_no_symref, sym, "a symbol");
282 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
286 if (PL_op->op_private & OPpLVAL_INTRO)
287 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
298 tryAMAGICunDEREF(to_sv);
301 switch (SvTYPE(sv)) {
305 DIE(aTHX_ "Not a SCALAR reference");
313 if (SvTYPE(gv) != SVt_PVGV) {
314 if (SvGMAGICAL(sv)) {
320 if (PL_op->op_flags & OPf_REF ||
321 PL_op->op_private & HINT_STRICT_REFS)
322 DIE(aTHX_ PL_no_usym, "a SCALAR");
323 if (ckWARN(WARN_UNINITIALIZED))
324 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
328 if ((PL_op->op_flags & OPf_SPECIAL) &&
329 !(PL_op->op_flags & OPf_MOD))
331 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
336 if (PL_op->op_private & HINT_STRICT_REFS)
337 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
338 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
343 if (PL_op->op_flags & OPf_MOD) {
344 if (PL_op->op_private & OPpLVAL_INTRO)
345 sv = save_scalar((GV*)TOPs);
346 else if (PL_op->op_private & OPpDEREF)
347 vivify_ref(sv, PL_op->op_private & OPpDEREF);
357 SV *sv = AvARYLEN(av);
359 AvARYLEN(av) = sv = NEWSV(0,0);
360 sv_upgrade(sv, SVt_IV);
361 sv_magic(sv, (SV*)av, '#', Nullch, 0);
369 djSP; dTARGET; dPOPss;
371 if (PL_op->op_flags & OPf_MOD) {
372 if (SvTYPE(TARG) < SVt_PVLV) {
373 sv_upgrade(TARG, SVt_PVLV);
374 sv_magic(TARG, Nullsv, '.', Nullch, 0);
378 if (LvTARG(TARG) != sv) {
380 SvREFCNT_dec(LvTARG(TARG));
381 LvTARG(TARG) = SvREFCNT_inc(sv);
383 PUSHs(TARG); /* no SvSETMAGIC */
389 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
390 mg = mg_find(sv, 'g');
391 if (mg && mg->mg_len >= 0) {
395 PUSHi(i + PL_curcop->cop_arybase);
409 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
410 /* (But not in defined().) */
411 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
414 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
415 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
416 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
419 cv = (CV*)&PL_sv_undef;
433 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
434 char *s = SvPVX(TOPs);
435 if (strnEQ(s, "CORE::", 6)) {
438 code = keyword(s + 6, SvCUR(TOPs) - 6);
439 if (code < 0) { /* Overridable. */
440 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
441 int i = 0, n = 0, seen_question = 0;
443 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
445 while (i < MAXO) { /* The slow way. */
446 if (strEQ(s + 6, PL_op_name[i])
447 || strEQ(s + 6, PL_op_desc[i]))
453 goto nonesuch; /* Should not happen... */
455 oa = PL_opargs[i] >> OASHIFT;
457 if (oa & OA_OPTIONAL) {
461 else if (seen_question)
462 goto set; /* XXXX system, exec */
463 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
464 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
467 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
468 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
472 ret = sv_2mortal(newSVpvn(str, n - 1));
474 else if (code) /* Non-Overridable */
476 else { /* None such */
478 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
482 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
484 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
493 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
495 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
511 if (GIMME != G_ARRAY) {
515 *MARK = &PL_sv_undef;
516 *MARK = refto(*MARK);
520 EXTEND_MORTAL(SP - MARK);
522 *MARK = refto(*MARK);
527 S_refto(pTHX_ SV *sv)
531 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
534 if (!(sv = LvTARG(sv)))
537 (void)SvREFCNT_inc(sv);
539 else if (SvTYPE(sv) == SVt_PVAV) {
540 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
543 (void)SvREFCNT_inc(sv);
545 else if (SvPADTMP(sv))
549 (void)SvREFCNT_inc(sv);
552 sv_upgrade(rv, SVt_RV);
566 if (sv && SvGMAGICAL(sv))
569 if (!sv || !SvROK(sv))
573 pv = sv_reftype(sv,TRUE);
574 PUSHp(pv, strlen(pv));
584 stash = CopSTASH(PL_curcop);
588 char *ptr = SvPV(ssv,len);
589 if (ckWARN(WARN_UNSAFE) && len == 0)
590 Perl_warner(aTHX_ WARN_UNSAFE,
591 "Explicit blessing to '' (assuming package main)");
592 stash = gv_stashpvn(ptr, len, TRUE);
595 (void)sv_bless(TOPs, stash);
609 elem = SvPV(sv, n_a);
613 switch (elem ? *elem : '\0')
616 if (strEQ(elem, "ARRAY"))
617 tmpRef = (SV*)GvAV(gv);
620 if (strEQ(elem, "CODE"))
621 tmpRef = (SV*)GvCVu(gv);
624 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
625 tmpRef = (SV*)GvIOp(gv);
628 if (strEQ(elem, "GLOB"))
632 if (strEQ(elem, "HASH"))
633 tmpRef = (SV*)GvHV(gv);
636 if (strEQ(elem, "IO"))
637 tmpRef = (SV*)GvIOp(gv);
640 if (strEQ(elem, "NAME"))
641 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
644 if (strEQ(elem, "PACKAGE"))
645 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
648 if (strEQ(elem, "SCALAR"))
662 /* Pattern matching */
667 register unsigned char *s;
670 register I32 *sfirst;
674 if (sv == PL_lastscream) {
680 SvSCREAM_off(PL_lastscream);
681 SvREFCNT_dec(PL_lastscream);
683 PL_lastscream = SvREFCNT_inc(sv);
686 s = (unsigned char*)(SvPV(sv, len));
690 if (pos > PL_maxscream) {
691 if (PL_maxscream < 0) {
692 PL_maxscream = pos + 80;
693 New(301, PL_screamfirst, 256, I32);
694 New(302, PL_screamnext, PL_maxscream, I32);
697 PL_maxscream = pos + pos / 4;
698 Renew(PL_screamnext, PL_maxscream, I32);
702 sfirst = PL_screamfirst;
703 snext = PL_screamnext;
705 if (!sfirst || !snext)
706 DIE(aTHX_ "do_study: out of memory");
708 for (ch = 256; ch; --ch)
715 snext[pos] = sfirst[ch] - pos;
722 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
731 if (PL_op->op_flags & OPf_STACKED)
737 TARG = sv_newmortal();
742 /* Lvalue operators. */
754 djSP; dMARK; dTARGET;
764 SETi(do_chomp(TOPs));
770 djSP; dMARK; dTARGET;
771 register I32 count = 0;
774 count += do_chomp(POPs);
785 if (!sv || !SvANY(sv))
787 switch (SvTYPE(sv)) {
789 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
793 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
797 if (CvROOT(sv) || CvXSUB(sv))
814 if (!PL_op->op_private) {
823 if (SvTHINKFIRST(sv))
826 switch (SvTYPE(sv)) {
836 if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
837 Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
838 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
842 /* let user-undef'd sub keep its identity */
843 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
850 SvSetMagicSV(sv, &PL_sv_undef);
854 Newz(602, gp, 1, GP);
855 GvGP(sv) = gp_ref(gp);
856 GvSV(sv) = NEWSV(72,0);
857 GvLINE(sv) = CopLINE(PL_curcop);
863 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
866 SvPV_set(sv, Nullch);
879 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
880 DIE(aTHX_ PL_no_modify);
881 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
882 SvIVX(TOPs) != IV_MIN)
885 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
896 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
897 DIE(aTHX_ PL_no_modify);
898 sv_setsv(TARG, TOPs);
899 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
900 SvIVX(TOPs) != IV_MAX)
903 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
917 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
918 DIE(aTHX_ PL_no_modify);
919 sv_setsv(TARG, TOPs);
920 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
921 SvIVX(TOPs) != IV_MIN)
924 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
933 /* Ordinary operators. */
937 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
940 SETn( pow( left, right) );
947 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
950 SETn( left * right );
957 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
962 DIE(aTHX_ "Illegal division by zero");
964 /* insure that 20./5. == 4. */
967 if ((NV)I_V(left) == left &&
968 (NV)I_V(right) == right &&
969 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
973 value = left / right;
977 value = left / right;
986 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
996 if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
998 right = (right_neg = (i < 0)) ? -i : i;
1003 right_neg = dright < 0;
1008 if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
1010 left = (left_neg = (i < 0)) ? -i : i;
1018 left_neg = dleft < 0;
1027 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1029 # define CAST_D2UV(d) U_V(d)
1031 # define CAST_D2UV(d) ((UV)(d))
1033 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1034 * or, in other words, precision of UV more than of NV.
1035 * But in fact the approach below turned out to be an
1036 * optimization - floor() may be slow */
1037 if (dright <= UV_MAX && dleft <= UV_MAX) {
1038 right = CAST_D2UV(dright);
1039 left = CAST_D2UV(dleft);
1044 /* Backward-compatibility clause: */
1045 dright = floor(dright + 0.5);
1046 dleft = floor(dleft + 0.5);
1049 DIE(aTHX_ "Illegal modulus zero");
1051 dans = Perl_fmod(dleft, dright);
1052 if ((left_neg != right_neg) && dans)
1053 dans = dright - dans;
1056 sv_setnv(TARG, dans);
1063 DIE(aTHX_ "Illegal modulus zero");
1066 if ((left_neg != right_neg) && ans)
1069 /* XXX may warn: unary minus operator applied to unsigned type */
1070 /* could change -foo to be (~foo)+1 instead */
1071 if (ans <= ~((UV)IV_MAX)+1)
1072 sv_setiv(TARG, ~ans+1);
1074 sv_setnv(TARG, -(NV)ans);
1077 sv_setuv(TARG, ans);
1086 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1088 register I32 count = POPi;
1089 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1091 I32 items = SP - MARK;
1094 max = items * count;
1103 repeatcpy((char*)(MARK + items), (char*)MARK,
1104 items * sizeof(SV*), count - 1);
1107 else if (count <= 0)
1110 else { /* Note: mark already snarfed by pp_list */
1115 SvSetSV(TARG, tmpstr);
1116 SvPV_force(TARG, len);
1121 SvGROW(TARG, (count * len) + 1);
1122 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1123 SvCUR(TARG) *= count;
1125 *SvEND(TARG) = '\0';
1127 (void)SvPOK_only(TARG);
1136 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1139 SETn( left - right );
1146 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1149 if (PL_op->op_private & HINT_INTEGER) {
1151 i = BWi(i) << shift;
1165 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1168 if (PL_op->op_private & HINT_INTEGER) {
1170 i = BWi(i) >> shift;
1184 djSP; tryAMAGICbinSET(lt,0);
1187 SETs(boolSV(TOPn < value));
1194 djSP; tryAMAGICbinSET(gt,0);
1197 SETs(boolSV(TOPn > value));
1204 djSP; tryAMAGICbinSET(le,0);
1207 SETs(boolSV(TOPn <= value));
1214 djSP; tryAMAGICbinSET(ge,0);
1217 SETs(boolSV(TOPn >= value));
1224 djSP; tryAMAGICbinSET(ne,0);
1227 SETs(boolSV(TOPn != value));
1234 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1241 else if (left < right)
1243 else if (left > right)
1256 djSP; tryAMAGICbinSET(slt,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(sgt,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(sle,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(sge,0);
1298 int cmp = ((PL_op->op_private & OPpLOCALE)
1299 ? sv_cmp_locale(left, right)
1300 : sv_cmp(left, right));
1301 SETs(boolSV(cmp >= 0));
1308 djSP; tryAMAGICbinSET(seq,0);
1311 SETs(boolSV(sv_eq(left, right)));
1318 djSP; tryAMAGICbinSET(sne,0);
1321 SETs(boolSV(!sv_eq(left, right)));
1328 djSP; dTARGET; tryAMAGICbin(scmp,0);
1331 int cmp = ((PL_op->op_private & OPpLOCALE)
1332 ? sv_cmp_locale(left, right)
1333 : sv_cmp(left, right));
1341 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1344 if (SvNIOKp(left) || SvNIOKp(right)) {
1345 if (PL_op->op_private & HINT_INTEGER) {
1346 IBW value = SvIV(left) & SvIV(right);
1350 UBW value = SvUV(left) & SvUV(right);
1355 do_vop(PL_op->op_type, TARG, left, right);
1364 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1367 if (SvNIOKp(left) || SvNIOKp(right)) {
1368 if (PL_op->op_private & HINT_INTEGER) {
1369 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1373 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1378 do_vop(PL_op->op_type, TARG, left, right);
1387 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1390 if (SvNIOKp(left) || SvNIOKp(right)) {
1391 if (PL_op->op_private & HINT_INTEGER) {
1392 IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1396 UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1401 do_vop(PL_op->op_type, TARG, left, right);
1410 djSP; dTARGET; tryAMAGICun(neg);
1415 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1417 else if (SvNIOKp(sv))
1419 else if (SvPOKp(sv)) {
1421 char *s = SvPV(sv, len);
1422 if (isIDFIRST(*s)) {
1423 sv_setpvn(TARG, "-", 1);
1426 else if (*s == '+' || *s == '-') {
1428 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1430 else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
1431 sv_setpvn(TARG, "-", 1);
1435 sv_setnv(TARG, -SvNV(sv));
1446 djSP; tryAMAGICunSET(not);
1447 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
1453 djSP; dTARGET; tryAMAGICun(compl);
1457 if (PL_op->op_private & HINT_INTEGER) {
1458 IBW value = ~SvIV(sv);
1462 UBW value = ~SvUV(sv);
1467 register char *tmps;
1468 register long *tmpl;
1473 tmps = SvPV_force(TARG, len);
1476 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1479 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1483 for ( ; anum > 0; anum--, tmps++)
1492 /* integer versions of some of the above */
1496 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1499 SETi( left * right );
1506 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1510 DIE(aTHX_ "Illegal division by zero");
1511 value = POPi / value;
1519 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1523 DIE(aTHX_ "Illegal modulus zero");
1524 SETi( left % right );
1531 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1534 SETi( left + right );
1541 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1544 SETi( left - right );
1551 djSP; tryAMAGICbinSET(lt,0);
1554 SETs(boolSV(left < right));
1561 djSP; tryAMAGICbinSET(gt,0);
1564 SETs(boolSV(left > right));
1571 djSP; tryAMAGICbinSET(le,0);
1574 SETs(boolSV(left <= right));
1581 djSP; tryAMAGICbinSET(ge,0);
1584 SETs(boolSV(left >= right));
1591 djSP; tryAMAGICbinSET(eq,0);
1594 SETs(boolSV(left == right));
1601 djSP; tryAMAGICbinSET(ne,0);
1604 SETs(boolSV(left != right));
1611 djSP; dTARGET; tryAMAGICbin(ncmp,0);
1618 else if (left < right)
1629 djSP; dTARGET; tryAMAGICun(neg);
1634 /* High falutin' math. */
1638 djSP; dTARGET; tryAMAGICbin(atan2,0);
1641 SETn(Perl_atan2(left, right));
1648 djSP; dTARGET; tryAMAGICun(sin);
1652 value = Perl_sin(value);
1660 djSP; dTARGET; tryAMAGICun(cos);
1664 value = Perl_cos(value);
1670 /* Support Configure command-line overrides for rand() functions.
1671 After 5.005, perhaps we should replace this by Configure support
1672 for drand48(), random(), or rand(). For 5.005, though, maintain
1673 compatibility by calling rand() but allow the user to override it.
1674 See INSTALL for details. --Andy Dougherty 15 July 1998
1676 /* Now it's after 5.005, and Configure supports drand48() and random(),
1677 in addition to rand(). So the overrides should not be needed any more.
1678 --Jarkko Hietaniemi 27 September 1998
1681 #ifndef HAS_DRAND48_PROTO
1682 extern double drand48 (void);
1695 if (!PL_srand_called) {
1696 (void)seedDrand01((Rand_seed_t)seed());
1697 PL_srand_called = TRUE;
1712 (void)seedDrand01((Rand_seed_t)anum);
1713 PL_srand_called = TRUE;
1722 * This is really just a quick hack which grabs various garbage
1723 * values. It really should be a real hash algorithm which
1724 * spreads the effect of every input bit onto every output bit,
1725 * if someone who knows about such things would bother to write it.
1726 * Might be a good idea to add that function to CORE as well.
1727 * No numbers below come from careful analysis or anything here,
1728 * except they are primes and SEED_C1 > 1E6 to get a full-width
1729 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1730 * probably be bigger too.
1733 # define SEED_C1 1000003
1734 #define SEED_C4 73819
1736 # define SEED_C1 25747
1737 #define SEED_C4 20639
1741 #define SEED_C5 26107
1744 #ifndef PERL_NO_DEV_RANDOM
1749 # include <starlet.h>
1750 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1751 * in 100-ns units, typically incremented ever 10 ms. */
1752 unsigned int when[2];
1754 # ifdef HAS_GETTIMEOFDAY
1755 struct timeval when;
1761 /* This test is an escape hatch, this symbol isn't set by Configure. */
1762 #ifndef PERL_NO_DEV_RANDOM
1763 #ifndef PERL_RANDOM_DEVICE
1764 /* /dev/random isn't used by default because reads from it will block
1765 * if there isn't enough entropy available. You can compile with
1766 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1767 * is enough real entropy to fill the seed. */
1768 # define PERL_RANDOM_DEVICE "/dev/urandom"
1770 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1772 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1781 _ckvmssts(sys$gettim(when));
1782 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1784 # ifdef HAS_GETTIMEOFDAY
1785 gettimeofday(&when,(struct timezone *) 0);
1786 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1789 u = (U32)SEED_C1 * when;
1792 u += SEED_C3 * (U32)getpid();
1793 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
1794 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
1795 u += SEED_C5 * (U32)PTR2UV(&when);
1802 djSP; dTARGET; tryAMAGICun(exp);
1806 value = Perl_exp(value);
1814 djSP; dTARGET; tryAMAGICun(log);
1819 RESTORE_NUMERIC_STANDARD();
1820 DIE(aTHX_ "Can't take log of %g", value);
1822 value = Perl_log(value);
1830 djSP; dTARGET; tryAMAGICun(sqrt);
1835 RESTORE_NUMERIC_STANDARD();
1836 DIE(aTHX_ "Can't take sqrt of %g", value);
1838 value = Perl_sqrt(value);
1851 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1857 (void)Perl_modf(value, &value);
1859 (void)Perl_modf(-value, &value);
1874 djSP; dTARGET; tryAMAGICun(abs);
1879 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1880 (iv = SvIVX(TOPs)) != IV_MIN) {
1902 XPUSHn(scan_hex(tmps, 99, &argtype));
1915 while (*tmps && isSPACE(*tmps))
1920 value = scan_hex(++tmps, 99, &argtype);
1921 else if (*tmps == 'b')
1922 value = scan_bin(++tmps, 99, &argtype);
1924 value = scan_oct(tmps, 99, &argtype);
1936 SETi( sv_len_utf8(TOPs) );
1940 SETi( sv_len(TOPs) );
1954 I32 lvalue = PL_op->op_flags & OPf_MOD;
1956 I32 arybase = PL_curcop->cop_arybase;
1960 SvTAINTED_off(TARG); /* decontaminate */
1964 repl = SvPV(sv, repl_len);
1971 tmps = SvPV(sv, curlen);
1973 utfcurlen = sv_len_utf8(sv);
1974 if (utfcurlen == curlen)
1982 if (pos >= arybase) {
2000 else if (len >= 0) {
2002 if (rem > (I32)curlen)
2016 if (ckWARN(WARN_SUBSTR) || lvalue || repl)
2017 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2022 sv_pos_u2b(sv, &pos, &rem);
2024 sv_setpvn(TARG, tmps, rem);
2025 if (lvalue) { /* it's an lvalue! */
2026 if (!SvGMAGICAL(sv)) {
2030 if (ckWARN(WARN_SUBSTR))
2031 Perl_warner(aTHX_ WARN_SUBSTR,
2032 "Attempt to use reference as lvalue in substr");
2034 if (SvOK(sv)) /* is it defined ? */
2035 (void)SvPOK_only(sv);
2037 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2040 if (SvTYPE(TARG) < SVt_PVLV) {
2041 sv_upgrade(TARG, SVt_PVLV);
2042 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
2046 if (LvTARG(TARG) != sv) {
2048 SvREFCNT_dec(LvTARG(TARG));
2049 LvTARG(TARG) = SvREFCNT_inc(sv);
2051 LvTARGOFF(TARG) = pos;
2052 LvTARGLEN(TARG) = rem;
2055 sv_insert(sv, pos, rem, repl, repl_len);
2058 PUSHs(TARG); /* avoid SvSETMAGIC here */
2065 register I32 size = POPi;
2066 register I32 offset = POPi;
2067 register SV *src = POPs;
2068 I32 lvalue = PL_op->op_flags & OPf_MOD;
2070 SvTAINTED_off(TARG); /* decontaminate */
2071 if (lvalue) { /* it's an lvalue! */
2072 if (SvTYPE(TARG) < SVt_PVLV) {
2073 sv_upgrade(TARG, SVt_PVLV);
2074 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
2077 if (LvTARG(TARG) != src) {
2079 SvREFCNT_dec(LvTARG(TARG));
2080 LvTARG(TARG) = SvREFCNT_inc(src);
2082 LvTARGOFF(TARG) = offset;
2083 LvTARGLEN(TARG) = size;
2086 sv_setuv(TARG, do_vecget(src, offset, size));
2101 I32 arybase = PL_curcop->cop_arybase;
2106 offset = POPi - arybase;
2109 tmps = SvPV(big, biglen);
2110 if (IN_UTF8 && offset > 0)
2111 sv_pos_u2b(big, &offset, 0);
2114 else if (offset > biglen)
2116 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
2117 (unsigned char*)tmps + biglen, little, 0)))
2120 retval = tmps2 - tmps;
2121 if (IN_UTF8 && retval > 0)
2122 sv_pos_b2u(big, &retval);
2123 PUSHi(retval + arybase);
2138 I32 arybase = PL_curcop->cop_arybase;
2144 tmps2 = SvPV(little, llen);
2145 tmps = SvPV(big, blen);
2149 if (IN_UTF8 && offset > 0)
2150 sv_pos_u2b(big, &offset, 0);
2151 offset = offset - arybase + llen;
2155 else if (offset > blen)
2157 if (!(tmps2 = rninstr(tmps, tmps + offset,
2158 tmps2, tmps2 + llen)))
2161 retval = tmps2 - tmps;
2162 if (IN_UTF8 && retval > 0)
2163 sv_pos_b2u(big, &retval);
2164 PUSHi(retval + arybase);
2170 djSP; dMARK; dORIGMARK; dTARGET;
2171 do_sprintf(TARG, SP-MARK, MARK+1);
2172 TAINT_IF(SvTAINTED(TARG));
2183 U8 *tmps = (U8*)POPpx;
2186 if (IN_UTF8 && (*tmps & 0x80))
2187 value = utf8_to_uv(tmps, &retlen);
2189 value = (UV)(*tmps & 255);
2200 (void)SvUPGRADE(TARG,SVt_PV);
2202 if (IN_UTF8 && value >= 128) {
2205 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
2206 SvCUR_set(TARG, tmps - SvPVX(TARG));
2208 (void)SvPOK_only(TARG);
2218 (void)SvPOK_only(TARG);
2225 djSP; dTARGET; dPOPTOPssrl;
2228 char *tmps = SvPV(left, n_a);
2230 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
2232 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
2236 "The crypt() function is unimplemented due to excessive paranoia.");
2249 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2253 UV uv = utf8_to_uv(s, &ulen);
2255 if (PL_op->op_private & OPpLOCALE) {
2258 uv = toTITLE_LC_uni(uv);
2261 uv = toTITLE_utf8(s);
2263 tend = uv_to_utf8(tmpbuf, uv);
2265 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2267 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2268 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2272 s = (U8*)SvPV_force(sv, slen);
2273 Copy(tmpbuf, s, ulen, U8);
2277 if (!SvPADTMP(sv)) {
2283 s = (U8*)SvPV_force(sv, slen);
2285 if (PL_op->op_private & OPpLOCALE) {
2288 *s = toUPPER_LC(*s);
2306 if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
2310 UV uv = utf8_to_uv(s, &ulen);
2312 if (PL_op->op_private & OPpLOCALE) {
2315 uv = toLOWER_LC_uni(uv);
2318 uv = toLOWER_utf8(s);
2320 tend = uv_to_utf8(tmpbuf, uv);
2322 if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
2324 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2325 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
2329 s = (U8*)SvPV_force(sv, slen);
2330 Copy(tmpbuf, s, ulen, U8);
2334 if (!SvPADTMP(sv)) {
2340 s = (U8*)SvPV_force(sv, slen);
2342 if (PL_op->op_private & OPpLOCALE) {
2345 *s = toLOWER_LC(*s);
2370 s = (U8*)SvPV(sv,len);
2372 sv_setpvn(TARG, "", 0);
2376 (void)SvUPGRADE(TARG, SVt_PV);
2377 SvGROW(TARG, (len * 2) + 1);
2378 (void)SvPOK_only(TARG);
2379 d = (U8*)SvPVX(TARG);
2381 if (PL_op->op_private & OPpLOCALE) {
2385 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2391 d = uv_to_utf8(d, toUPPER_utf8( s ));
2396 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2401 if (!SvPADTMP(sv)) {
2407 s = (U8*)SvPV_force(sv, len);
2409 register U8 *send = s + len;
2411 if (PL_op->op_private & OPpLOCALE) {
2414 for (; s < send; s++)
2415 *s = toUPPER_LC(*s);
2418 for (; s < send; s++)
2441 s = (U8*)SvPV(sv,len);
2443 sv_setpvn(TARG, "", 0);
2447 (void)SvUPGRADE(TARG, SVt_PV);
2448 SvGROW(TARG, (len * 2) + 1);
2449 (void)SvPOK_only(TARG);
2450 d = (U8*)SvPVX(TARG);
2452 if (PL_op->op_private & OPpLOCALE) {
2456 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2462 d = uv_to_utf8(d, toLOWER_utf8(s));
2467 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2472 if (!SvPADTMP(sv)) {
2479 s = (U8*)SvPV_force(sv, len);
2481 register U8 *send = s + len;
2483 if (PL_op->op_private & OPpLOCALE) {
2486 for (; s < send; s++)
2487 *s = toLOWER_LC(*s);
2490 for (; s < send; s++)
2505 register char *s = SvPV(sv,len);
2509 (void)SvUPGRADE(TARG, SVt_PV);
2510 SvGROW(TARG, (len * 2) + 1);
2515 STRLEN ulen = UTF8SKIP(s);
2538 SvCUR_set(TARG, d - SvPVX(TARG));
2539 (void)SvPOK_only(TARG);
2542 sv_setpvn(TARG, s, len);
2544 if (SvSMAGICAL(TARG))
2553 djSP; dMARK; dORIGMARK;
2555 register AV* av = (AV*)POPs;
2556 register I32 lval = PL_op->op_flags & OPf_MOD;
2557 I32 arybase = PL_curcop->cop_arybase;
2560 if (SvTYPE(av) == SVt_PVAV) {
2561 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
2563 for (svp = MARK + 1; svp <= SP; svp++) {
2568 if (max > AvMAX(av))
2571 while (++MARK <= SP) {
2572 elem = SvIVx(*MARK);
2576 svp = av_fetch(av, elem, lval);
2578 if (!svp || *svp == &PL_sv_undef)
2579 DIE(aTHX_ PL_no_aelem, elem);
2580 if (PL_op->op_private & OPpLVAL_INTRO)
2581 save_aelem(av, elem, svp);
2583 *MARK = svp ? *svp : &PL_sv_undef;
2586 if (GIMME != G_ARRAY) {
2594 /* Associative arrays. */
2599 HV *hash = (HV*)POPs;
2601 I32 gimme = GIMME_V;
2602 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2605 /* might clobber stack_sp */
2606 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2611 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2612 if (gimme == G_ARRAY) {
2615 /* might clobber stack_sp */
2617 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
2622 else if (gimme == G_SCALAR)
2641 I32 gimme = GIMME_V;
2642 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2646 if (PL_op->op_private & OPpSLICE) {
2650 hvtype = SvTYPE(hv);
2651 while (++MARK <= SP) {
2652 if (hvtype == SVt_PVHV)
2653 sv = hv_delete_ent(hv, *MARK, discard, 0);
2655 DIE(aTHX_ "Not a HASH reference");
2656 *MARK = sv ? sv : &PL_sv_undef;
2660 else if (gimme == G_SCALAR) {
2669 if (SvTYPE(hv) == SVt_PVHV)
2670 sv = hv_delete_ent(hv, keysv, discard, 0);
2672 DIE(aTHX_ "Not a HASH reference");
2686 if (SvTYPE(hv) == SVt_PVHV) {
2687 if (hv_exists_ent(hv, tmpsv, 0))
2690 else if (SvTYPE(hv) == SVt_PVAV) {
2691 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2695 DIE(aTHX_ "Not a HASH reference");
2702 djSP; dMARK; dORIGMARK;
2703 register HV *hv = (HV*)POPs;
2704 register I32 lval = PL_op->op_flags & OPf_MOD;
2705 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2707 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
2708 DIE(aTHX_ "Can't localize pseudo-hash element");
2710 if (realhv || SvTYPE(hv) == SVt_PVAV) {
2711 while (++MARK <= SP) {
2715 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
2716 svp = he ? &HeVAL(he) : 0;
2719 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2722 if (!svp || *svp == &PL_sv_undef) {
2724 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2726 if (PL_op->op_private & OPpLVAL_INTRO)
2727 save_helem(hv, keysv, svp);
2729 *MARK = svp ? *svp : &PL_sv_undef;
2732 if (GIMME != G_ARRAY) {
2740 /* List operators. */
2745 if (GIMME != G_ARRAY) {
2747 *MARK = *SP; /* unwanted list, return last item */
2749 *MARK = &PL_sv_undef;
2758 SV **lastrelem = PL_stack_sp;
2759 SV **lastlelem = PL_stack_base + POPMARK;
2760 SV **firstlelem = PL_stack_base + POPMARK + 1;
2761 register SV **firstrelem = lastlelem + 1;
2762 I32 arybase = PL_curcop->cop_arybase;
2763 I32 lval = PL_op->op_flags & OPf_MOD;
2764 I32 is_something_there = lval;
2766 register I32 max = lastrelem - lastlelem;
2767 register SV **lelem;
2770 if (GIMME != G_ARRAY) {
2771 ix = SvIVx(*lastlelem);
2776 if (ix < 0 || ix >= max)
2777 *firstlelem = &PL_sv_undef;
2779 *firstlelem = firstrelem[ix];
2785 SP = firstlelem - 1;
2789 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2795 if (ix < 0 || ix >= max)
2796 *lelem = &PL_sv_undef;
2798 is_something_there = TRUE;
2799 if (!(*lelem = firstrelem[ix]))
2800 *lelem = &PL_sv_undef;
2803 if (is_something_there)
2806 SP = firstlelem - 1;
2812 djSP; dMARK; dORIGMARK;
2813 I32 items = SP - MARK;
2814 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2815 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2822 djSP; dMARK; dORIGMARK;
2823 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2827 SV *val = NEWSV(46, 0);
2829 sv_setsv(val, *++MARK);
2830 else if (ckWARN(WARN_UNSAFE))
2831 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
2832 (void)hv_store_ent(hv,key,val,0);
2841 djSP; dMARK; dORIGMARK;
2842 register AV *ary = (AV*)*++MARK;
2846 register I32 offset;
2847 register I32 length;
2854 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2855 *MARK-- = SvTIED_obj((SV*)ary, mg);
2859 call_method("SPLICE",GIMME_V);
2868 offset = i = SvIVx(*MARK);
2870 offset += AvFILLp(ary) + 1;
2872 offset -= PL_curcop->cop_arybase;
2874 DIE(aTHX_ PL_no_aelem, i);
2876 length = SvIVx(*MARK++);
2878 length += AvFILLp(ary) - offset + 1;
2884 length = AvMAX(ary) + 1; /* close enough to infinity */
2888 length = AvMAX(ary) + 1;
2890 if (offset > AvFILLp(ary) + 1)
2891 offset = AvFILLp(ary) + 1;
2892 after = AvFILLp(ary) + 1 - (offset + length);
2893 if (after < 0) { /* not that much array */
2894 length += after; /* offset+length now in array */
2900 /* At this point, MARK .. SP-1 is our new LIST */
2903 diff = newlen - length;
2904 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2907 if (diff < 0) { /* shrinking the area */
2909 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2910 Copy(MARK, tmparyval, newlen, SV*);
2913 MARK = ORIGMARK + 1;
2914 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2915 MEXTEND(MARK, length);
2916 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2918 EXTEND_MORTAL(length);
2919 for (i = length, dst = MARK; i; i--) {
2920 sv_2mortal(*dst); /* free them eventualy */
2927 *MARK = AvARRAY(ary)[offset+length-1];
2930 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2931 SvREFCNT_dec(*dst++); /* free them now */
2934 AvFILLp(ary) += diff;
2936 /* pull up or down? */
2938 if (offset < after) { /* easier to pull up */
2939 if (offset) { /* esp. if nothing to pull */
2940 src = &AvARRAY(ary)[offset-1];
2941 dst = src - diff; /* diff is negative */
2942 for (i = offset; i > 0; i--) /* can't trust Copy */
2946 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2950 if (after) { /* anything to pull down? */
2951 src = AvARRAY(ary) + offset + length;
2952 dst = src + diff; /* diff is negative */
2953 Move(src, dst, after, SV*);
2955 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2956 /* avoid later double free */
2960 dst[--i] = &PL_sv_undef;
2963 for (src = tmparyval, dst = AvARRAY(ary) + offset;
2965 *dst = NEWSV(46, 0);
2966 sv_setsv(*dst++, *src++);
2968 Safefree(tmparyval);
2971 else { /* no, expanding (or same) */
2973 New(452, tmparyval, length, SV*); /* so remember deletion */
2974 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2977 if (diff > 0) { /* expanding */
2979 /* push up or down? */
2981 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2985 Move(src, dst, offset, SV*);
2987 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2989 AvFILLp(ary) += diff;
2992 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
2993 av_extend(ary, AvFILLp(ary) + diff);
2994 AvFILLp(ary) += diff;
2997 dst = AvARRAY(ary) + AvFILLp(ary);
2999 for (i = after; i; i--) {
3006 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3007 *dst = NEWSV(46, 0);
3008 sv_setsv(*dst++, *src++);
3010 MARK = ORIGMARK + 1;
3011 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3013 Copy(tmparyval, MARK, length, SV*);
3015 EXTEND_MORTAL(length);
3016 for (i = length, dst = MARK; i; i--) {
3017 sv_2mortal(*dst); /* free them eventualy */
3021 Safefree(tmparyval);
3025 else if (length--) {
3026 *MARK = tmparyval[length];
3029 while (length-- > 0)
3030 SvREFCNT_dec(tmparyval[length]);
3032 Safefree(tmparyval);
3035 *MARK = &PL_sv_undef;
3043 djSP; dMARK; dORIGMARK; dTARGET;
3044 register AV *ary = (AV*)*++MARK;
3045 register SV *sv = &PL_sv_undef;
3048 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3049 *MARK-- = SvTIED_obj((SV*)ary, mg);
3053 call_method("PUSH",G_SCALAR|G_DISCARD);
3058 /* Why no pre-extend of ary here ? */
3059 for (++MARK; MARK <= SP; MARK++) {
3062 sv_setsv(sv, *MARK);
3067 PUSHi( AvFILL(ary) + 1 );
3075 SV *sv = av_pop(av);
3077 (void)sv_2mortal(sv);
3086 SV *sv = av_shift(av);
3091 (void)sv_2mortal(sv);
3098 djSP; dMARK; dORIGMARK; dTARGET;
3099 register AV *ary = (AV*)*++MARK;
3104 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3105 *MARK-- = SvTIED_obj((SV*)ary, mg);
3109 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
3114 av_unshift(ary, SP - MARK);
3117 sv_setsv(sv, *++MARK);
3118 (void)av_store(ary, i++, sv);
3122 PUSHi( AvFILL(ary) + 1 );
3132 if (GIMME == G_ARRAY) {
3143 register char *down;
3149 do_join(TARG, &PL_sv_no, MARK, SP);
3151 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3152 up = SvPV_force(TARG, len);
3154 if (IN_UTF8) { /* first reverse each character */
3155 U8* s = (U8*)SvPVX(TARG);
3156 U8* send = (U8*)(s + len);
3165 down = (char*)(s - 1);
3166 if (s > send || !((*down & 0xc0) == 0x80)) {
3167 if (ckWARN_d(WARN_UTF8))
3168 Perl_warner(aTHX_ WARN_UTF8,
3169 "Malformed UTF-8 character");
3181 down = SvPVX(TARG) + len - 1;
3187 (void)SvPOK_only(TARG);
3196 S_mul128(pTHX_ SV *sv, U8 m)
3199 char *s = SvPV(sv, len);
3203 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3204 SV *tmpNew = newSVpvn("0000000000", 10);
3206 sv_catsv(tmpNew, sv);
3207 SvREFCNT_dec(sv); /* free old sv */
3212 while (!*t) /* trailing '\0'? */
3215 i = ((*t - '0') << 7) + m;
3216 *(t--) = '0' + (i % 10);
3222 /* Explosives and implosives. */
3224 #if 'I' == 73 && 'J' == 74
3225 /* On an ASCII/ISO kind of system */
3226 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3229 Some other sort of character set - use memchr() so we don't match
3232 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3240 I32 gimme = GIMME_V;
3244 register char *pat = SvPV(left, llen);
3245 register char *s = SvPV(right, rlen);
3246 char *strend = s + rlen;
3248 register char *patend = pat + llen;
3253 /* These must not be in registers: */
3270 register U32 culong;
3274 #ifdef PERL_NATINT_PACK
3275 int natint; /* native integer */
3276 int unatint; /* unsigned native integer */
3279 if (gimme != G_ARRAY) { /* arrange to do first one only */
3281 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3282 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3284 while (isDIGIT(*patend) || *patend == '*')
3290 while (pat < patend) {
3292 datumtype = *pat++ & 0xFF;
3293 #ifdef PERL_NATINT_PACK
3296 if (isSPACE(datumtype))
3298 if (datumtype == '#') {
3299 while (pat < patend && *pat != '\n')
3304 char *natstr = "sSiIlL";
3306 if (strchr(natstr, datumtype)) {
3307 #ifdef PERL_NATINT_PACK
3313 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3318 else if (*pat == '*') {
3319 len = strend - strbeg; /* long enough */
3323 else if (isDIGIT(*pat)) {
3325 while (isDIGIT(*pat)) {
3326 len = (len * 10) + (*pat++ - '0');
3328 DIE(aTHX_ "Repeat count in unpack overflows");
3332 len = (datumtype != '@');
3336 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3337 case ',': /* grandfather in commas but with a warning */
3338 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3339 Perl_warner(aTHX_ WARN_UNSAFE,
3340 "Invalid type in unpack: '%c'", (int)datumtype);
3343 if (len == 1 && pat[-1] != '1')
3352 if (len > strend - strbeg)
3353 DIE(aTHX_ "@ outside of string");
3357 if (len > s - strbeg)
3358 DIE(aTHX_ "X outside of string");
3362 if (len > strend - s)
3363 DIE(aTHX_ "x outside of string");
3368 DIE(aTHX_ "/ must follow a numeric type");
3371 pat++; /* ignore '*' for compatibility with pack */
3373 DIE(aTHX_ "/ cannot take a count" );
3380 if (len > strend - s)
3383 goto uchar_checksum;
3384 sv = NEWSV(35, len);
3385 sv_setpvn(sv, s, len);
3387 if (datumtype == 'A' || datumtype == 'Z') {
3388 aptr = s; /* borrow register */
3389 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3394 else { /* 'A' strips both nulls and spaces */
3395 s = SvPVX(sv) + len - 1;
3396 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3400 SvCUR_set(sv, s - SvPVX(sv));
3401 s = aptr; /* unborrow register */
3403 XPUSHs(sv_2mortal(sv));
3407 if (star || len > (strend - s) * 8)
3408 len = (strend - s) * 8;
3411 Newz(601, PL_bitcount, 256, char);
3412 for (bits = 1; bits < 256; bits++) {
3413 if (bits & 1) PL_bitcount[bits]++;
3414 if (bits & 2) PL_bitcount[bits]++;
3415 if (bits & 4) PL_bitcount[bits]++;
3416 if (bits & 8) PL_bitcount[bits]++;
3417 if (bits & 16) PL_bitcount[bits]++;
3418 if (bits & 32) PL_bitcount[bits]++;
3419 if (bits & 64) PL_bitcount[bits]++;
3420 if (bits & 128) PL_bitcount[bits]++;
3424 culong += PL_bitcount[*(unsigned char*)s++];
3429 if (datumtype == 'b') {
3431 if (bits & 1) culong++;
3437 if (bits & 128) culong++;
3444 sv = NEWSV(35, len + 1);
3447 aptr = pat; /* borrow register */
3449 if (datumtype == 'b') {
3451 for (len = 0; len < aint; len++) {
3452 if (len & 7) /*SUPPRESS 595*/
3456 *pat++ = '0' + (bits & 1);
3461 for (len = 0; len < aint; len++) {
3466 *pat++ = '0' + ((bits & 128) != 0);
3470 pat = aptr; /* unborrow register */
3471 XPUSHs(sv_2mortal(sv));
3475 if (star || len > (strend - s) * 2)
3476 len = (strend - s) * 2;
3477 sv = NEWSV(35, len + 1);
3480 aptr = pat; /* borrow register */
3482 if (datumtype == 'h') {
3484 for (len = 0; len < aint; len++) {
3489 *pat++ = PL_hexdigit[bits & 15];
3494 for (len = 0; len < aint; len++) {
3499 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3503 pat = aptr; /* unborrow register */
3504 XPUSHs(sv_2mortal(sv));
3507 if (len > strend - s)
3512 if (aint >= 128) /* fake up signed chars */
3522 if (aint >= 128) /* fake up signed chars */
3525 sv_setiv(sv, (IV)aint);
3526 PUSHs(sv_2mortal(sv));
3531 if (len > strend - s)
3546 sv_setiv(sv, (IV)auint);
3547 PUSHs(sv_2mortal(sv));
3552 if (len > strend - s)
3555 while (len-- > 0 && s < strend) {
3556 auint = utf8_to_uv((U8*)s, &along);
3559 cdouble += (NV)auint;
3567 while (len-- > 0 && s < strend) {
3568 auint = utf8_to_uv((U8*)s, &along);
3571 sv_setuv(sv, (UV)auint);
3572 PUSHs(sv_2mortal(sv));
3577 #if SHORTSIZE == SIZE16
3578 along = (strend - s) / SIZE16;
3580 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3585 #if SHORTSIZE != SIZE16
3589 COPYNN(s, &ashort, sizeof(short));
3600 #if SHORTSIZE > SIZE16
3612 #if SHORTSIZE != SIZE16
3616 COPYNN(s, &ashort, sizeof(short));
3619 sv_setiv(sv, (IV)ashort);
3620 PUSHs(sv_2mortal(sv));
3628 #if SHORTSIZE > SIZE16
3634 sv_setiv(sv, (IV)ashort);
3635 PUSHs(sv_2mortal(sv));
3643 #if SHORTSIZE == SIZE16
3644 along = (strend - s) / SIZE16;
3646 unatint = natint && datumtype == 'S';
3647 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3652 #if SHORTSIZE != SIZE16
3654 unsigned short aushort;
3656 COPYNN(s, &aushort, sizeof(unsigned short));
3657 s += sizeof(unsigned short);
3665 COPY16(s, &aushort);
3668 if (datumtype == 'n')
3669 aushort = PerlSock_ntohs(aushort);
3672 if (datumtype == 'v')
3673 aushort = vtohs(aushort);
3682 #if SHORTSIZE != SIZE16
3684 unsigned short aushort;
3686 COPYNN(s, &aushort, sizeof(unsigned short));
3687 s += sizeof(unsigned short);
3689 sv_setiv(sv, (UV)aushort);
3690 PUSHs(sv_2mortal(sv));
3697 COPY16(s, &aushort);
3701 if (datumtype == 'n')
3702 aushort = PerlSock_ntohs(aushort);
3705 if (datumtype == 'v')
3706 aushort = vtohs(aushort);
3708 sv_setiv(sv, (UV)aushort);
3709 PUSHs(sv_2mortal(sv));
3715 along = (strend - s) / sizeof(int);
3720 Copy(s, &aint, 1, int);
3723 cdouble += (NV)aint;
3732 Copy(s, &aint, 1, int);
3736 /* Without the dummy below unpack("i", pack("i",-1))
3737 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3738 * cc with optimization turned on.
3740 * The bug was detected in
3741 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3742 * with optimization (-O4) turned on.
3743 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3744 * does not have this problem even with -O4.
3746 * This bug was reported as DECC_BUGS 1431
3747 * and tracked internally as GEM_BUGS 7775.
3749 * The bug is fixed in
3750 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3751 * UNIX V4.0F support: DEC C V5.9-006 or later
3752 * UNIX V4.0E support: DEC C V5.8-011 or later
3755 * See also few lines later for the same bug.
3758 sv_setiv(sv, (IV)aint) :
3760 sv_setiv(sv, (IV)aint);
3761 PUSHs(sv_2mortal(sv));
3766 along = (strend - s) / sizeof(unsigned int);
3771 Copy(s, &auint, 1, unsigned int);
3772 s += sizeof(unsigned int);
3774 cdouble += (NV)auint;
3783 Copy(s, &auint, 1, unsigned int);
3784 s += sizeof(unsigned int);
3787 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3788 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3789 * See details few lines earlier. */
3791 sv_setuv(sv, (UV)auint) :
3793 sv_setuv(sv, (UV)auint);
3794 PUSHs(sv_2mortal(sv));
3799 #if LONGSIZE == SIZE32
3800 along = (strend - s) / SIZE32;
3802 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3807 #if LONGSIZE != SIZE32
3811 COPYNN(s, &along, sizeof(long));
3814 cdouble += (NV)along;
3824 #if LONGSIZE > SIZE32
3825 if (along > 2147483647)
3826 along -= 4294967296;
3830 cdouble += (NV)along;
3839 #if LONGSIZE != SIZE32
3843 COPYNN(s, &along, sizeof(long));
3846 sv_setiv(sv, (IV)along);
3847 PUSHs(sv_2mortal(sv));
3855 #if LONGSIZE > SIZE32
3856 if (along > 2147483647)
3857 along -= 4294967296;
3861 sv_setiv(sv, (IV)along);
3862 PUSHs(sv_2mortal(sv));
3870 #if LONGSIZE == SIZE32
3871 along = (strend - s) / SIZE32;
3873 unatint = natint && datumtype == 'L';
3874 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3879 #if LONGSIZE != SIZE32
3881 unsigned long aulong;
3883 COPYNN(s, &aulong, sizeof(unsigned long));
3884 s += sizeof(unsigned long);
3886 cdouble += (NV)aulong;
3898 if (datumtype == 'N')
3899 aulong = PerlSock_ntohl(aulong);
3902 if (datumtype == 'V')
3903 aulong = vtohl(aulong);
3906 cdouble += (NV)aulong;
3915 #if LONGSIZE != SIZE32
3917 unsigned long aulong;
3919 COPYNN(s, &aulong, sizeof(unsigned long));
3920 s += sizeof(unsigned long);
3922 sv_setuv(sv, (UV)aulong);
3923 PUSHs(sv_2mortal(sv));
3933 if (datumtype == 'N')
3934 aulong = PerlSock_ntohl(aulong);
3937 if (datumtype == 'V')
3938 aulong = vtohl(aulong);
3941 sv_setuv(sv, (UV)aulong);
3942 PUSHs(sv_2mortal(sv));
3948 along = (strend - s) / sizeof(char*);
3954 if (sizeof(char*) > strend - s)
3957 Copy(s, &aptr, 1, char*);
3963 PUSHs(sv_2mortal(sv));
3973 while ((len > 0) && (s < strend)) {
3974 auv = (auv << 7) | (*s & 0x7f);
3975 if (!(*s++ & 0x80)) {
3979 PUSHs(sv_2mortal(sv));
3983 else if (++bytes >= sizeof(UV)) { /* promote to string */
3987 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3988 while (s < strend) {
3989 sv = mul128(sv, *s & 0x7f);
3990 if (!(*s++ & 0x80)) {
3999 PUSHs(sv_2mortal(sv));
4004 if ((s >= strend) && bytes)
4005 DIE(aTHX_ "Unterminated compressed integer");
4010 if (sizeof(char*) > strend - s)
4013 Copy(s, &aptr, 1, char*);
4018 sv_setpvn(sv, aptr, len);
4019 PUSHs(sv_2mortal(sv));
4023 along = (strend - s) / sizeof(Quad_t);
4029 if (s + sizeof(Quad_t) > strend)
4032 Copy(s, &aquad, 1, Quad_t);
4033 s += sizeof(Quad_t);
4036 if (aquad >= IV_MIN && aquad <= IV_MAX)
4037 sv_setiv(sv, (IV)aquad);
4039 sv_setnv(sv, (NV)aquad);
4040 PUSHs(sv_2mortal(sv));
4044 along = (strend - s) / sizeof(Quad_t);
4050 if (s + sizeof(Uquad_t) > strend)
4053 Copy(s, &auquad, 1, Uquad_t);
4054 s += sizeof(Uquad_t);
4057 if (auquad <= UV_MAX)
4058 sv_setuv(sv, (UV)auquad);
4060 sv_setnv(sv, (NV)auquad);
4061 PUSHs(sv_2mortal(sv));
4065 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4068 along = (strend - s) / sizeof(float);
4073 Copy(s, &afloat, 1, float);
4082 Copy(s, &afloat, 1, float);
4085 sv_setnv(sv, (NV)afloat);
4086 PUSHs(sv_2mortal(sv));
4092 along = (strend - s) / sizeof(double);
4097 Copy(s, &adouble, 1, double);
4098 s += sizeof(double);
4106 Copy(s, &adouble, 1, double);
4107 s += sizeof(double);
4109 sv_setnv(sv, (NV)adouble);
4110 PUSHs(sv_2mortal(sv));
4116 * Initialise the decode mapping. By using a table driven
4117 * algorithm, the code will be character-set independent
4118 * (and just as fast as doing character arithmetic)
4120 if (PL_uudmap['M'] == 0) {
4123 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4124 PL_uudmap[PL_uuemap[i]] = i;
4126 * Because ' ' and '`' map to the same value,
4127 * we need to decode them both the same.
4132 along = (strend - s) * 3 / 4;
4133 sv = NEWSV(42, along);
4136 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4141 len = PL_uudmap[*s++] & 077;
4143 if (s < strend && ISUUCHAR(*s))
4144 a = PL_uudmap[*s++] & 077;
4147 if (s < strend && ISUUCHAR(*s))
4148 b = PL_uudmap[*s++] & 077;
4151 if (s < strend && ISUUCHAR(*s))
4152 c = PL_uudmap[*s++] & 077;
4155 if (s < strend && ISUUCHAR(*s))
4156 d = PL_uudmap[*s++] & 077;
4159 hunk[0] = (a << 2) | (b >> 4);
4160 hunk[1] = (b << 4) | (c >> 2);
4161 hunk[2] = (c << 6) | d;
4162 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4167 else if (s[1] == '\n') /* possible checksum byte */
4170 XPUSHs(sv_2mortal(sv));
4175 if (strchr("fFdD", datumtype) ||
4176 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4180 while (checksum >= 16) {
4184 while (checksum >= 4) {
4190 along = (1 << checksum) - 1;
4191 while (cdouble < 0.0)
4193 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4194 sv_setnv(sv, cdouble);
4197 if (checksum < 32) {
4198 aulong = (1 << checksum) - 1;
4201 sv_setuv(sv, (UV)culong);
4203 XPUSHs(sv_2mortal(sv));
4207 if (SP == oldsp && gimme == G_SCALAR)
4208 PUSHs(&PL_sv_undef);
4213 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4217 *hunk = PL_uuemap[len];
4218 sv_catpvn(sv, hunk, 1);
4221 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4222 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4223 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4224 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4225 sv_catpvn(sv, hunk, 4);
4230 char r = (len > 1 ? s[1] : '\0');
4231 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4232 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4233 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4234 hunk[3] = PL_uuemap[0];
4235 sv_catpvn(sv, hunk, 4);
4237 sv_catpvn(sv, "\n", 1);
4241 S_is_an_int(pTHX_ char *s, STRLEN l)
4244 SV *result = newSVpvn(s, l);
4245 char *result_c = SvPV(result, n_a); /* convenience */
4246 char *out = result_c;
4256 SvREFCNT_dec(result);
4279 SvREFCNT_dec(result);
4285 SvCUR_set(result, out - result_c);
4289 /* pnum must be '\0' terminated */
4291 S_div128(pTHX_ SV *pnum, bool *done)
4294 char *s = SvPV(pnum, len);
4303 i = m * 10 + (*t - '0');
4305 r = (i >> 7); /* r < 10 */
4312 SvCUR_set(pnum, (STRLEN) (t - s));
4319 djSP; dMARK; dORIGMARK; dTARGET;
4320 register SV *cat = TARG;
4323 register char *pat = SvPVx(*++MARK, fromlen);
4324 register char *patend = pat + fromlen;
4329 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4330 static char *space10 = " ";
4332 /* These must not be in registers: */
4347 #ifdef PERL_NATINT_PACK
4348 int natint; /* native integer */
4353 sv_setpvn(cat, "", 0);
4354 while (pat < patend) {
4355 SV *lengthcode = Nullsv;
4356 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4357 datumtype = *pat++ & 0xFF;
4358 #ifdef PERL_NATINT_PACK
4361 if (isSPACE(datumtype))
4363 if (datumtype == '#') {
4364 while (pat < patend && *pat != '\n')
4369 char *natstr = "sSiIlL";
4371 if (strchr(natstr, datumtype)) {
4372 #ifdef PERL_NATINT_PACK
4378 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4381 len = strchr("@Xxu", datumtype) ? 0 : items;
4384 else if (isDIGIT(*pat)) {
4386 while (isDIGIT(*pat)) {
4387 len = (len * 10) + (*pat++ - '0');
4389 DIE(aTHX_ "Repeat count in pack overflows");
4396 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4397 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4398 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4399 ? *MARK : &PL_sv_no)));
4403 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4404 case ',': /* grandfather in commas but with a warning */
4405 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4406 Perl_warner(aTHX_ WARN_UNSAFE,
4407 "Invalid type in pack: '%c'", (int)datumtype);
4410 DIE(aTHX_ "%% may only be used in unpack");
4421 if (SvCUR(cat) < len)
4422 DIE(aTHX_ "X outside of string");
4429 sv_catpvn(cat, null10, 10);
4432 sv_catpvn(cat, null10, len);
4438 aptr = SvPV(fromstr, fromlen);
4439 if (pat[-1] == '*') {
4441 if (datumtype == 'Z')
4444 if (fromlen >= len) {
4445 sv_catpvn(cat, aptr, len);
4446 if (datumtype == 'Z')
4447 *(SvEND(cat)-1) = '\0';
4450 sv_catpvn(cat, aptr, fromlen);
4452 if (datumtype == 'A') {
4454 sv_catpvn(cat, space10, 10);
4457 sv_catpvn(cat, space10, len);
4461 sv_catpvn(cat, null10, 10);
4464 sv_catpvn(cat, null10, len);
4471 char *savepat = pat;
4476 aptr = SvPV(fromstr, fromlen);
4481 SvCUR(cat) += (len+7)/8;
4482 SvGROW(cat, SvCUR(cat) + 1);
4483 aptr = SvPVX(cat) + aint;
4488 if (datumtype == 'B') {
4489 for (len = 0; len++ < aint;) {
4490 items |= *pat++ & 1;
4494 *aptr++ = items & 0xff;
4500 for (len = 0; len++ < aint;) {
4506 *aptr++ = items & 0xff;
4512 if (datumtype == 'B')
4513 items <<= 7 - (aint & 7);
4515 items >>= 7 - (aint & 7);
4516 *aptr++ = items & 0xff;
4518 pat = SvPVX(cat) + SvCUR(cat);
4529 char *savepat = pat;
4534 aptr = SvPV(fromstr, fromlen);
4539 SvCUR(cat) += (len+1)/2;
4540 SvGROW(cat, SvCUR(cat) + 1);
4541 aptr = SvPVX(cat) + aint;
4546 if (datumtype == 'H') {
4547 for (len = 0; len++ < aint;) {
4549 items |= ((*pat++ & 15) + 9) & 15;
4551 items |= *pat++ & 15;
4555 *aptr++ = items & 0xff;
4561 for (len = 0; len++ < aint;) {
4563 items |= (((*pat++ & 15) + 9) & 15) << 4;
4565 items |= (*pat++ & 15) << 4;
4569 *aptr++ = items & 0xff;
4575 *aptr++ = items & 0xff;
4576 pat = SvPVX(cat) + SvCUR(cat);
4588 aint = SvIV(fromstr);
4590 sv_catpvn(cat, &achar, sizeof(char));
4596 auint = SvUV(fromstr);
4597 SvGROW(cat, SvCUR(cat) + 10);
4598 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4603 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4608 afloat = (float)SvNV(fromstr);
4609 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4616 adouble = (double)SvNV(fromstr);
4617 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4623 ashort = (I16)SvIV(fromstr);
4625 ashort = PerlSock_htons(ashort);
4627 CAT16(cat, &ashort);
4633 ashort = (I16)SvIV(fromstr);
4635 ashort = htovs(ashort);
4637 CAT16(cat, &ashort);
4641 #if SHORTSIZE != SIZE16
4643 unsigned short aushort;
4647 aushort = SvUV(fromstr);
4648 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4658 aushort = (U16)SvUV(fromstr);
4659 CAT16(cat, &aushort);
4665 #if SHORTSIZE != SIZE16
4671 ashort = SvIV(fromstr);
4672 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4680 ashort = (I16)SvIV(fromstr);
4681 CAT16(cat, &ashort);
4688 auint = SvUV(fromstr);
4689 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4695 adouble = Perl_floor(SvNV(fromstr));
4698 DIE(aTHX_ "Cannot compress negative numbers");
4704 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4705 adouble <= UV_MAX_cxux
4712 char buf[1 + sizeof(UV)];
4713 char *in = buf + sizeof(buf);
4714 UV auv = U_V(adouble);
4717 *--in = (auv & 0x7f) | 0x80;
4720 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4721 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4723 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4724 char *from, *result, *in;
4729 /* Copy string and check for compliance */
4730 from = SvPV(fromstr, len);
4731 if ((norm = is_an_int(from, len)) == NULL)
4732 DIE(aTHX_ "can compress only unsigned integer");
4734 New('w', result, len, char);
4738 *--in = div128(norm, &done) | 0x80;
4739 result[len - 1] &= 0x7F; /* clear continue bit */
4740 sv_catpvn(cat, in, (result + len) - in);
4742 SvREFCNT_dec(norm); /* free norm */
4744 else if (SvNOKp(fromstr)) {
4745 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4746 char *in = buf + sizeof(buf);
4749 double next = floor(adouble / 128);
4750 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4751 if (--in < buf) /* this cannot happen ;-) */
4752 DIE(aTHX_ "Cannot compress integer");
4754 } while (adouble > 0);
4755 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4756 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4759 DIE(aTHX_ "Cannot compress non integer");
4765 aint = SvIV(fromstr);
4766 sv_catpvn(cat, (char*)&aint, sizeof(int));
4772 aulong = SvUV(fromstr);
4774 aulong = PerlSock_htonl(aulong);
4776 CAT32(cat, &aulong);
4782 aulong = SvUV(fromstr);
4784 aulong = htovl(aulong);
4786 CAT32(cat, &aulong);
4790 #if LONGSIZE != SIZE32
4792 unsigned long aulong;
4796 aulong = SvUV(fromstr);
4797 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4805 aulong = SvUV(fromstr);
4806 CAT32(cat, &aulong);
4811 #if LONGSIZE != SIZE32
4817 along = SvIV(fromstr);
4818 sv_catpvn(cat, (char *)&along, sizeof(long));
4826 along = SvIV(fromstr);
4835 auquad = (Uquad_t)SvUV(fromstr);
4836 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4842 aquad = (Quad_t)SvIV(fromstr);
4843 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4848 len = 1; /* assume SV is correct length */
4853 if (fromstr == &PL_sv_undef)
4857 /* XXX better yet, could spirit away the string to
4858 * a safe spot and hang on to it until the result
4859 * of pack() (and all copies of the result) are
4862 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4863 Perl_warner(aTHX_ WARN_UNSAFE,
4864 "Attempt to pack pointer to temporary value");
4865 if (SvPOK(fromstr) || SvNIOK(fromstr))
4866 aptr = SvPV(fromstr,n_a);
4868 aptr = SvPV_force(fromstr,n_a);
4870 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4875 aptr = SvPV(fromstr, fromlen);
4876 SvGROW(cat, fromlen * 4 / 3);
4881 while (fromlen > 0) {
4888 doencodes(cat, aptr, todo);
4907 register I32 limit = POPi; /* note, negative is forever */
4910 register char *s = SvPV(sv, len);
4911 char *strend = s + len;
4913 register REGEXP *rx;
4917 I32 maxiters = (strend - s) + 10;
4920 I32 origlimit = limit;
4923 AV *oldstack = PL_curstack;
4924 I32 gimme = GIMME_V;
4925 I32 oldsave = PL_savestack_ix;
4926 I32 make_mortal = 1;
4927 MAGIC *mg = (MAGIC *) NULL;
4930 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4935 DIE(aTHX_ "panic: do_split");
4936 rx = pm->op_pmregexp;
4938 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4939 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4941 if (pm->op_pmreplroot) {
4943 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4945 ary = GvAVn((GV*)pm->op_pmreplroot);
4948 else if (gimme != G_ARRAY)
4950 ary = (AV*)PL_curpad[0];
4952 ary = GvAVn(PL_defgv);
4953 #endif /* USE_THREADS */
4956 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4962 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4964 XPUSHs(SvTIED_obj((SV*)ary, mg));
4970 for (i = AvFILLp(ary); i >= 0; i--)
4971 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4973 /* temporarily switch stacks */
4974 SWITCHSTACK(PL_curstack, ary);
4978 base = SP - PL_stack_base;
4980 if (pm->op_pmflags & PMf_SKIPWHITE) {
4981 if (pm->op_pmflags & PMf_LOCALE) {
4982 while (isSPACE_LC(*s))
4990 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4991 SAVEINT(PL_multiline);
4992 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4996 limit = maxiters + 2;
4997 if (pm->op_pmflags & PMf_WHITE) {
5000 while (m < strend &&
5001 !((pm->op_pmflags & PMf_LOCALE)
5002 ? isSPACE_LC(*m) : isSPACE(*m)))
5007 dstr = NEWSV(30, m-s);
5008 sv_setpvn(dstr, s, m-s);
5014 while (s < strend &&
5015 ((pm->op_pmflags & PMf_LOCALE)
5016 ? isSPACE_LC(*s) : isSPACE(*s)))
5020 else if (strEQ("^", rx->precomp)) {
5023 for (m = s; m < strend && *m != '\n'; m++) ;
5027 dstr = NEWSV(30, m-s);
5028 sv_setpvn(dstr, s, m-s);
5035 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5036 && (rx->reganch & ROPT_CHECK_ALL)
5037 && !(rx->reganch & ROPT_ANCH)) {
5038 int tail = (rx->reganch & RE_INTUIT_TAIL);
5039 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5043 if (len == 1 && !tail) {
5047 for (m = s; m < strend && *m != c; m++) ;
5050 dstr = NEWSV(30, m-s);
5051 sv_setpvn(dstr, s, m-s);
5060 while (s < strend && --limit &&
5061 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5062 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5065 dstr = NEWSV(31, m-s);
5066 sv_setpvn(dstr, s, m-s);
5070 s = m + len; /* Fake \n at the end */
5075 maxiters += (strend - s) * rx->nparens;
5076 while (s < strend && --limit
5077 /* && (!rx->check_substr
5078 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5080 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5081 1 /* minend */, sv, NULL, 0))
5083 TAINT_IF(RX_MATCH_TAINTED(rx));
5084 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5089 strend = s + (strend - m);
5091 m = rx->startp[0] + orig;
5092 dstr = NEWSV(32, m-s);
5093 sv_setpvn(dstr, s, m-s);
5098 for (i = 1; i <= rx->nparens; i++) {
5099 s = rx->startp[i] + orig;
5100 m = rx->endp[i] + orig;
5102 dstr = NEWSV(33, m-s);
5103 sv_setpvn(dstr, s, m-s);
5106 dstr = NEWSV(33, 0);
5112 s = rx->endp[0] + orig;
5116 LEAVE_SCOPE(oldsave);
5117 iters = (SP - PL_stack_base) - base;
5118 if (iters > maxiters)
5119 DIE(aTHX_ "Split loop");
5121 /* keep field after final delim? */
5122 if (s < strend || (iters && origlimit)) {
5123 dstr = NEWSV(34, strend-s);
5124 sv_setpvn(dstr, s, strend-s);
5130 else if (!origlimit) {
5131 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5137 SWITCHSTACK(ary, oldstack);
5138 if (SvSMAGICAL(ary)) {
5143 if (gimme == G_ARRAY) {
5145 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5153 call_method("PUSH",G_SCALAR|G_DISCARD);
5156 if (gimme == G_ARRAY) {
5157 /* EXTEND should not be needed - we just popped them */
5159 for (i=0; i < iters; i++) {
5160 SV **svp = av_fetch(ary, i, FALSE);
5161 PUSHs((svp) ? *svp : &PL_sv_undef);
5168 if (gimme == G_ARRAY)
5171 if (iters || !pm->op_pmreplroot) {
5181 Perl_unlock_condpair(pTHX_ void *svv)
5184 MAGIC *mg = mg_find((SV*)svv, 'm');
5187 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5188 MUTEX_LOCK(MgMUTEXP(mg));
5189 if (MgOWNER(mg) != thr)
5190 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5192 COND_SIGNAL(MgOWNERCONDP(mg));
5193 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5194 PTR2UV(thr), PTR2UV(svv));)
5195 MUTEX_UNLOCK(MgMUTEXP(mg));
5197 #endif /* USE_THREADS */
5210 mg = condpair_magic(sv);
5211 MUTEX_LOCK(MgMUTEXP(mg));
5212 if (MgOWNER(mg) == thr)
5213 MUTEX_UNLOCK(MgMUTEXP(mg));
5216 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5218 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5219 PTR2UV(thr), PTR2UV(sv));)
5220 MUTEX_UNLOCK(MgMUTEXP(mg));
5221 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5223 #endif /* USE_THREADS */
5224 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5225 || SvTYPE(retsv) == SVt_PVCV) {
5226 retsv = refto(retsv);
5237 if (PL_op->op_private & OPpLVAL_INTRO)
5238 PUSHs(*save_threadsv(PL_op->op_targ));
5240 PUSHs(THREADSV(PL_op->op_targ));
5243 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5244 #endif /* USE_THREADS */