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)PerlProc_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) {
3139 /* safe as long as stack cannot get extended in the above */
3144 register char *down;
3150 do_join(TARG, &PL_sv_no, MARK, SP);
3152 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
3153 up = SvPV_force(TARG, len);
3155 if (IN_UTF8) { /* first reverse each character */
3156 U8* s = (U8*)SvPVX(TARG);
3157 U8* send = (U8*)(s + len);
3166 down = (char*)(s - 1);
3167 if (s > send || !((*down & 0xc0) == 0x80)) {
3168 if (ckWARN_d(WARN_UTF8))
3169 Perl_warner(aTHX_ WARN_UTF8,
3170 "Malformed UTF-8 character");
3182 down = SvPVX(TARG) + len - 1;
3188 (void)SvPOK_only(TARG);
3197 S_mul128(pTHX_ SV *sv, U8 m)
3200 char *s = SvPV(sv, len);
3204 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
3205 SV *tmpNew = newSVpvn("0000000000", 10);
3207 sv_catsv(tmpNew, sv);
3208 SvREFCNT_dec(sv); /* free old sv */
3213 while (!*t) /* trailing '\0'? */
3216 i = ((*t - '0') << 7) + m;
3217 *(t--) = '0' + (i % 10);
3223 /* Explosives and implosives. */
3225 #if 'I' == 73 && 'J' == 74
3226 /* On an ASCII/ISO kind of system */
3227 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
3230 Some other sort of character set - use memchr() so we don't match
3233 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
3240 I32 start_sp_offset = SP - PL_stack_base;
3241 I32 gimme = GIMME_V;
3245 register char *pat = SvPV(left, llen);
3246 register char *s = SvPV(right, rlen);
3247 char *strend = s + rlen;
3249 register char *patend = pat + llen;
3254 /* These must not be in registers: */
3271 register U32 culong;
3275 #ifdef PERL_NATINT_PACK
3276 int natint; /* native integer */
3277 int unatint; /* unsigned native integer */
3280 if (gimme != G_ARRAY) { /* arrange to do first one only */
3282 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
3283 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
3285 while (isDIGIT(*patend) || *patend == '*')
3291 while (pat < patend) {
3293 datumtype = *pat++ & 0xFF;
3294 #ifdef PERL_NATINT_PACK
3297 if (isSPACE(datumtype))
3299 if (datumtype == '#') {
3300 while (pat < patend && *pat != '\n')
3305 char *natstr = "sSiIlL";
3307 if (strchr(natstr, datumtype)) {
3308 #ifdef PERL_NATINT_PACK
3314 DIE(aTHX_ "'!' allowed only after types %s", natstr);
3319 else if (*pat == '*') {
3320 len = strend - strbeg; /* long enough */
3324 else if (isDIGIT(*pat)) {
3326 while (isDIGIT(*pat)) {
3327 len = (len * 10) + (*pat++ - '0');
3329 DIE(aTHX_ "Repeat count in unpack overflows");
3333 len = (datumtype != '@');
3337 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
3338 case ',': /* grandfather in commas but with a warning */
3339 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
3340 Perl_warner(aTHX_ WARN_UNSAFE,
3341 "Invalid type in unpack: '%c'", (int)datumtype);
3344 if (len == 1 && pat[-1] != '1')
3353 if (len > strend - strbeg)
3354 DIE(aTHX_ "@ outside of string");
3358 if (len > s - strbeg)
3359 DIE(aTHX_ "X outside of string");
3363 if (len > strend - s)
3364 DIE(aTHX_ "x outside of string");
3368 if (start_sp_offset >= SP - PL_stack_base)
3369 DIE(aTHX_ "/ must follow a numeric type");
3372 pat++; /* ignore '*' for compatibility with pack */
3374 DIE(aTHX_ "/ cannot take a count" );
3381 if (len > strend - s)
3384 goto uchar_checksum;
3385 sv = NEWSV(35, len);
3386 sv_setpvn(sv, s, len);
3388 if (datumtype == 'A' || datumtype == 'Z') {
3389 aptr = s; /* borrow register */
3390 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3395 else { /* 'A' strips both nulls and spaces */
3396 s = SvPVX(sv) + len - 1;
3397 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3401 SvCUR_set(sv, s - SvPVX(sv));
3402 s = aptr; /* unborrow register */
3404 XPUSHs(sv_2mortal(sv));
3408 if (star || len > (strend - s) * 8)
3409 len = (strend - s) * 8;
3412 Newz(601, PL_bitcount, 256, char);
3413 for (bits = 1; bits < 256; bits++) {
3414 if (bits & 1) PL_bitcount[bits]++;
3415 if (bits & 2) PL_bitcount[bits]++;
3416 if (bits & 4) PL_bitcount[bits]++;
3417 if (bits & 8) PL_bitcount[bits]++;
3418 if (bits & 16) PL_bitcount[bits]++;
3419 if (bits & 32) PL_bitcount[bits]++;
3420 if (bits & 64) PL_bitcount[bits]++;
3421 if (bits & 128) PL_bitcount[bits]++;
3425 culong += PL_bitcount[*(unsigned char*)s++];
3430 if (datumtype == 'b') {
3432 if (bits & 1) culong++;
3438 if (bits & 128) culong++;
3445 sv = NEWSV(35, len + 1);
3448 aptr = pat; /* borrow register */
3450 if (datumtype == 'b') {
3452 for (len = 0; len < aint; len++) {
3453 if (len & 7) /*SUPPRESS 595*/
3457 *pat++ = '0' + (bits & 1);
3462 for (len = 0; len < aint; len++) {
3467 *pat++ = '0' + ((bits & 128) != 0);
3471 pat = aptr; /* unborrow register */
3472 XPUSHs(sv_2mortal(sv));
3476 if (star || len > (strend - s) * 2)
3477 len = (strend - s) * 2;
3478 sv = NEWSV(35, len + 1);
3481 aptr = pat; /* borrow register */
3483 if (datumtype == 'h') {
3485 for (len = 0; len < aint; len++) {
3490 *pat++ = PL_hexdigit[bits & 15];
3495 for (len = 0; len < aint; len++) {
3500 *pat++ = PL_hexdigit[(bits >> 4) & 15];
3504 pat = aptr; /* unborrow register */
3505 XPUSHs(sv_2mortal(sv));
3508 if (len > strend - s)
3513 if (aint >= 128) /* fake up signed chars */
3523 if (aint >= 128) /* fake up signed chars */
3526 sv_setiv(sv, (IV)aint);
3527 PUSHs(sv_2mortal(sv));
3532 if (len > strend - s)
3547 sv_setiv(sv, (IV)auint);
3548 PUSHs(sv_2mortal(sv));
3553 if (len > strend - s)
3556 while (len-- > 0 && s < strend) {
3557 auint = utf8_to_uv((U8*)s, &along);
3560 cdouble += (NV)auint;
3568 while (len-- > 0 && s < strend) {
3569 auint = utf8_to_uv((U8*)s, &along);
3572 sv_setuv(sv, (UV)auint);
3573 PUSHs(sv_2mortal(sv));
3578 #if SHORTSIZE == SIZE16
3579 along = (strend - s) / SIZE16;
3581 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
3586 #if SHORTSIZE != SIZE16
3590 COPYNN(s, &ashort, sizeof(short));
3601 #if SHORTSIZE > SIZE16
3613 #if SHORTSIZE != SIZE16
3617 COPYNN(s, &ashort, sizeof(short));
3620 sv_setiv(sv, (IV)ashort);
3621 PUSHs(sv_2mortal(sv));
3629 #if SHORTSIZE > SIZE16
3635 sv_setiv(sv, (IV)ashort);
3636 PUSHs(sv_2mortal(sv));
3644 #if SHORTSIZE == SIZE16
3645 along = (strend - s) / SIZE16;
3647 unatint = natint && datumtype == 'S';
3648 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
3653 #if SHORTSIZE != SIZE16
3655 unsigned short aushort;
3657 COPYNN(s, &aushort, sizeof(unsigned short));
3658 s += sizeof(unsigned short);
3666 COPY16(s, &aushort);
3669 if (datumtype == 'n')
3670 aushort = PerlSock_ntohs(aushort);
3673 if (datumtype == 'v')
3674 aushort = vtohs(aushort);
3683 #if SHORTSIZE != SIZE16
3685 unsigned short aushort;
3687 COPYNN(s, &aushort, sizeof(unsigned short));
3688 s += sizeof(unsigned short);
3690 sv_setiv(sv, (UV)aushort);
3691 PUSHs(sv_2mortal(sv));
3698 COPY16(s, &aushort);
3702 if (datumtype == 'n')
3703 aushort = PerlSock_ntohs(aushort);
3706 if (datumtype == 'v')
3707 aushort = vtohs(aushort);
3709 sv_setiv(sv, (UV)aushort);
3710 PUSHs(sv_2mortal(sv));
3716 along = (strend - s) / sizeof(int);
3721 Copy(s, &aint, 1, int);
3724 cdouble += (NV)aint;
3733 Copy(s, &aint, 1, int);
3737 /* Without the dummy below unpack("i", pack("i",-1))
3738 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3739 * cc with optimization turned on.
3741 * The bug was detected in
3742 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3743 * with optimization (-O4) turned on.
3744 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3745 * does not have this problem even with -O4.
3747 * This bug was reported as DECC_BUGS 1431
3748 * and tracked internally as GEM_BUGS 7775.
3750 * The bug is fixed in
3751 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3752 * UNIX V4.0F support: DEC C V5.9-006 or later
3753 * UNIX V4.0E support: DEC C V5.8-011 or later
3756 * See also few lines later for the same bug.
3759 sv_setiv(sv, (IV)aint) :
3761 sv_setiv(sv, (IV)aint);
3762 PUSHs(sv_2mortal(sv));
3767 along = (strend - s) / sizeof(unsigned int);
3772 Copy(s, &auint, 1, unsigned int);
3773 s += sizeof(unsigned int);
3775 cdouble += (NV)auint;
3784 Copy(s, &auint, 1, unsigned int);
3785 s += sizeof(unsigned int);
3788 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
3789 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3790 * See details few lines earlier. */
3792 sv_setuv(sv, (UV)auint) :
3794 sv_setuv(sv, (UV)auint);
3795 PUSHs(sv_2mortal(sv));
3800 #if LONGSIZE == SIZE32
3801 along = (strend - s) / SIZE32;
3803 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
3808 #if LONGSIZE != SIZE32
3812 COPYNN(s, &along, sizeof(long));
3815 cdouble += (NV)along;
3825 #if LONGSIZE > SIZE32
3826 if (along > 2147483647)
3827 along -= 4294967296;
3831 cdouble += (NV)along;
3840 #if LONGSIZE != SIZE32
3844 COPYNN(s, &along, sizeof(long));
3847 sv_setiv(sv, (IV)along);
3848 PUSHs(sv_2mortal(sv));
3856 #if LONGSIZE > SIZE32
3857 if (along > 2147483647)
3858 along -= 4294967296;
3862 sv_setiv(sv, (IV)along);
3863 PUSHs(sv_2mortal(sv));
3871 #if LONGSIZE == SIZE32
3872 along = (strend - s) / SIZE32;
3874 unatint = natint && datumtype == 'L';
3875 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
3880 #if LONGSIZE != SIZE32
3882 unsigned long aulong;
3884 COPYNN(s, &aulong, sizeof(unsigned long));
3885 s += sizeof(unsigned long);
3887 cdouble += (NV)aulong;
3899 if (datumtype == 'N')
3900 aulong = PerlSock_ntohl(aulong);
3903 if (datumtype == 'V')
3904 aulong = vtohl(aulong);
3907 cdouble += (NV)aulong;
3916 #if LONGSIZE != SIZE32
3918 unsigned long aulong;
3920 COPYNN(s, &aulong, sizeof(unsigned long));
3921 s += sizeof(unsigned long);
3923 sv_setuv(sv, (UV)aulong);
3924 PUSHs(sv_2mortal(sv));
3934 if (datumtype == 'N')
3935 aulong = PerlSock_ntohl(aulong);
3938 if (datumtype == 'V')
3939 aulong = vtohl(aulong);
3942 sv_setuv(sv, (UV)aulong);
3943 PUSHs(sv_2mortal(sv));
3949 along = (strend - s) / sizeof(char*);
3955 if (sizeof(char*) > strend - s)
3958 Copy(s, &aptr, 1, char*);
3964 PUSHs(sv_2mortal(sv));
3974 while ((len > 0) && (s < strend)) {
3975 auv = (auv << 7) | (*s & 0x7f);
3976 if (!(*s++ & 0x80)) {
3980 PUSHs(sv_2mortal(sv));
3984 else if (++bytes >= sizeof(UV)) { /* promote to string */
3988 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
3989 while (s < strend) {
3990 sv = mul128(sv, *s & 0x7f);
3991 if (!(*s++ & 0x80)) {
4000 PUSHs(sv_2mortal(sv));
4005 if ((s >= strend) && bytes)
4006 DIE(aTHX_ "Unterminated compressed integer");
4011 if (sizeof(char*) > strend - s)
4014 Copy(s, &aptr, 1, char*);
4019 sv_setpvn(sv, aptr, len);
4020 PUSHs(sv_2mortal(sv));
4024 along = (strend - s) / sizeof(Quad_t);
4030 if (s + sizeof(Quad_t) > strend)
4033 Copy(s, &aquad, 1, Quad_t);
4034 s += sizeof(Quad_t);
4037 if (aquad >= IV_MIN && aquad <= IV_MAX)
4038 sv_setiv(sv, (IV)aquad);
4040 sv_setnv(sv, (NV)aquad);
4041 PUSHs(sv_2mortal(sv));
4045 along = (strend - s) / sizeof(Quad_t);
4051 if (s + sizeof(Uquad_t) > strend)
4054 Copy(s, &auquad, 1, Uquad_t);
4055 s += sizeof(Uquad_t);
4058 if (auquad <= UV_MAX)
4059 sv_setuv(sv, (UV)auquad);
4061 sv_setnv(sv, (NV)auquad);
4062 PUSHs(sv_2mortal(sv));
4066 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4069 along = (strend - s) / sizeof(float);
4074 Copy(s, &afloat, 1, float);
4083 Copy(s, &afloat, 1, float);
4086 sv_setnv(sv, (NV)afloat);
4087 PUSHs(sv_2mortal(sv));
4093 along = (strend - s) / sizeof(double);
4098 Copy(s, &adouble, 1, double);
4099 s += sizeof(double);
4107 Copy(s, &adouble, 1, double);
4108 s += sizeof(double);
4110 sv_setnv(sv, (NV)adouble);
4111 PUSHs(sv_2mortal(sv));
4117 * Initialise the decode mapping. By using a table driven
4118 * algorithm, the code will be character-set independent
4119 * (and just as fast as doing character arithmetic)
4121 if (PL_uudmap['M'] == 0) {
4124 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4125 PL_uudmap[PL_uuemap[i]] = i;
4127 * Because ' ' and '`' map to the same value,
4128 * we need to decode them both the same.
4133 along = (strend - s) * 3 / 4;
4134 sv = NEWSV(42, along);
4137 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
4142 len = PL_uudmap[*s++] & 077;
4144 if (s < strend && ISUUCHAR(*s))
4145 a = PL_uudmap[*s++] & 077;
4148 if (s < strend && ISUUCHAR(*s))
4149 b = PL_uudmap[*s++] & 077;
4152 if (s < strend && ISUUCHAR(*s))
4153 c = PL_uudmap[*s++] & 077;
4156 if (s < strend && ISUUCHAR(*s))
4157 d = PL_uudmap[*s++] & 077;
4160 hunk[0] = (a << 2) | (b >> 4);
4161 hunk[1] = (b << 4) | (c >> 2);
4162 hunk[2] = (c << 6) | d;
4163 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
4168 else if (s[1] == '\n') /* possible checksum byte */
4171 XPUSHs(sv_2mortal(sv));
4176 if (strchr("fFdD", datumtype) ||
4177 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
4181 while (checksum >= 16) {
4185 while (checksum >= 4) {
4191 along = (1 << checksum) - 1;
4192 while (cdouble < 0.0)
4194 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
4195 sv_setnv(sv, cdouble);
4198 if (checksum < 32) {
4199 aulong = (1 << checksum) - 1;
4202 sv_setuv(sv, (UV)culong);
4204 XPUSHs(sv_2mortal(sv));
4208 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
4209 PUSHs(&PL_sv_undef);
4214 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
4218 *hunk = PL_uuemap[len];
4219 sv_catpvn(sv, hunk, 1);
4222 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4223 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4224 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4225 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
4226 sv_catpvn(sv, hunk, 4);
4231 char r = (len > 1 ? s[1] : '\0');
4232 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4233 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4234 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4235 hunk[3] = PL_uuemap[0];
4236 sv_catpvn(sv, hunk, 4);
4238 sv_catpvn(sv, "\n", 1);
4242 S_is_an_int(pTHX_ char *s, STRLEN l)
4245 SV *result = newSVpvn(s, l);
4246 char *result_c = SvPV(result, n_a); /* convenience */
4247 char *out = result_c;
4257 SvREFCNT_dec(result);
4280 SvREFCNT_dec(result);
4286 SvCUR_set(result, out - result_c);
4290 /* pnum must be '\0' terminated */
4292 S_div128(pTHX_ SV *pnum, bool *done)
4295 char *s = SvPV(pnum, len);
4304 i = m * 10 + (*t - '0');
4306 r = (i >> 7); /* r < 10 */
4313 SvCUR_set(pnum, (STRLEN) (t - s));
4320 djSP; dMARK; dORIGMARK; dTARGET;
4321 register SV *cat = TARG;
4324 register char *pat = SvPVx(*++MARK, fromlen);
4325 register char *patend = pat + fromlen;
4330 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4331 static char *space10 = " ";
4333 /* These must not be in registers: */
4348 #ifdef PERL_NATINT_PACK
4349 int natint; /* native integer */
4354 sv_setpvn(cat, "", 0);
4355 while (pat < patend) {
4356 SV *lengthcode = Nullsv;
4357 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
4358 datumtype = *pat++ & 0xFF;
4359 #ifdef PERL_NATINT_PACK
4362 if (isSPACE(datumtype))
4364 if (datumtype == '#') {
4365 while (pat < patend && *pat != '\n')
4370 char *natstr = "sSiIlL";
4372 if (strchr(natstr, datumtype)) {
4373 #ifdef PERL_NATINT_PACK
4379 DIE(aTHX_ "'!' allowed only after types %s", natstr);
4382 len = strchr("@Xxu", datumtype) ? 0 : items;
4385 else if (isDIGIT(*pat)) {
4387 while (isDIGIT(*pat)) {
4388 len = (len * 10) + (*pat++ - '0');
4390 DIE(aTHX_ "Repeat count in pack overflows");
4397 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4398 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
4399 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4400 ? *MARK : &PL_sv_no)));
4404 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
4405 case ',': /* grandfather in commas but with a warning */
4406 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
4407 Perl_warner(aTHX_ WARN_UNSAFE,
4408 "Invalid type in pack: '%c'", (int)datumtype);
4411 DIE(aTHX_ "%% may only be used in unpack");
4422 if (SvCUR(cat) < len)
4423 DIE(aTHX_ "X outside of string");
4430 sv_catpvn(cat, null10, 10);
4433 sv_catpvn(cat, null10, len);
4439 aptr = SvPV(fromstr, fromlen);
4440 if (pat[-1] == '*') {
4442 if (datumtype == 'Z')
4445 if (fromlen >= len) {
4446 sv_catpvn(cat, aptr, len);
4447 if (datumtype == 'Z')
4448 *(SvEND(cat)-1) = '\0';
4451 sv_catpvn(cat, aptr, fromlen);
4453 if (datumtype == 'A') {
4455 sv_catpvn(cat, space10, 10);
4458 sv_catpvn(cat, space10, len);
4462 sv_catpvn(cat, null10, 10);
4465 sv_catpvn(cat, null10, len);
4472 char *savepat = pat;
4477 aptr = SvPV(fromstr, fromlen);
4482 SvCUR(cat) += (len+7)/8;
4483 SvGROW(cat, SvCUR(cat) + 1);
4484 aptr = SvPVX(cat) + aint;
4489 if (datumtype == 'B') {
4490 for (len = 0; len++ < aint;) {
4491 items |= *pat++ & 1;
4495 *aptr++ = items & 0xff;
4501 for (len = 0; len++ < aint;) {
4507 *aptr++ = items & 0xff;
4513 if (datumtype == 'B')
4514 items <<= 7 - (aint & 7);
4516 items >>= 7 - (aint & 7);
4517 *aptr++ = items & 0xff;
4519 pat = SvPVX(cat) + SvCUR(cat);
4530 char *savepat = pat;
4535 aptr = SvPV(fromstr, fromlen);
4540 SvCUR(cat) += (len+1)/2;
4541 SvGROW(cat, SvCUR(cat) + 1);
4542 aptr = SvPVX(cat) + aint;
4547 if (datumtype == 'H') {
4548 for (len = 0; len++ < aint;) {
4550 items |= ((*pat++ & 15) + 9) & 15;
4552 items |= *pat++ & 15;
4556 *aptr++ = items & 0xff;
4562 for (len = 0; len++ < aint;) {
4564 items |= (((*pat++ & 15) + 9) & 15) << 4;
4566 items |= (*pat++ & 15) << 4;
4570 *aptr++ = items & 0xff;
4576 *aptr++ = items & 0xff;
4577 pat = SvPVX(cat) + SvCUR(cat);
4589 aint = SvIV(fromstr);
4591 sv_catpvn(cat, &achar, sizeof(char));
4597 auint = SvUV(fromstr);
4598 SvGROW(cat, SvCUR(cat) + 10);
4599 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4604 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4609 afloat = (float)SvNV(fromstr);
4610 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4617 adouble = (double)SvNV(fromstr);
4618 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4624 ashort = (I16)SvIV(fromstr);
4626 ashort = PerlSock_htons(ashort);
4628 CAT16(cat, &ashort);
4634 ashort = (I16)SvIV(fromstr);
4636 ashort = htovs(ashort);
4638 CAT16(cat, &ashort);
4642 #if SHORTSIZE != SIZE16
4644 unsigned short aushort;
4648 aushort = SvUV(fromstr);
4649 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4659 aushort = (U16)SvUV(fromstr);
4660 CAT16(cat, &aushort);
4666 #if SHORTSIZE != SIZE16
4672 ashort = SvIV(fromstr);
4673 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4681 ashort = (I16)SvIV(fromstr);
4682 CAT16(cat, &ashort);
4689 auint = SvUV(fromstr);
4690 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4696 adouble = Perl_floor(SvNV(fromstr));
4699 DIE(aTHX_ "Cannot compress negative numbers");
4705 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
4706 adouble <= UV_MAX_cxux
4713 char buf[1 + sizeof(UV)];
4714 char *in = buf + sizeof(buf);
4715 UV auv = U_V(adouble);
4718 *--in = (auv & 0x7f) | 0x80;
4721 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4722 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4724 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4725 char *from, *result, *in;
4730 /* Copy string and check for compliance */
4731 from = SvPV(fromstr, len);
4732 if ((norm = is_an_int(from, len)) == NULL)
4733 DIE(aTHX_ "can compress only unsigned integer");
4735 New('w', result, len, char);
4739 *--in = div128(norm, &done) | 0x80;
4740 result[len - 1] &= 0x7F; /* clear continue bit */
4741 sv_catpvn(cat, in, (result + len) - in);
4743 SvREFCNT_dec(norm); /* free norm */
4745 else if (SvNOKp(fromstr)) {
4746 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4747 char *in = buf + sizeof(buf);
4750 double next = floor(adouble / 128);
4751 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4752 if (--in < buf) /* this cannot happen ;-) */
4753 DIE(aTHX_ "Cannot compress integer");
4755 } while (adouble > 0);
4756 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4757 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4760 DIE(aTHX_ "Cannot compress non integer");
4766 aint = SvIV(fromstr);
4767 sv_catpvn(cat, (char*)&aint, sizeof(int));
4773 aulong = SvUV(fromstr);
4775 aulong = PerlSock_htonl(aulong);
4777 CAT32(cat, &aulong);
4783 aulong = SvUV(fromstr);
4785 aulong = htovl(aulong);
4787 CAT32(cat, &aulong);
4791 #if LONGSIZE != SIZE32
4793 unsigned long aulong;
4797 aulong = SvUV(fromstr);
4798 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4806 aulong = SvUV(fromstr);
4807 CAT32(cat, &aulong);
4812 #if LONGSIZE != SIZE32
4818 along = SvIV(fromstr);
4819 sv_catpvn(cat, (char *)&along, sizeof(long));
4827 along = SvIV(fromstr);
4836 auquad = (Uquad_t)SvUV(fromstr);
4837 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
4843 aquad = (Quad_t)SvIV(fromstr);
4844 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4849 len = 1; /* assume SV is correct length */
4854 if (fromstr == &PL_sv_undef)
4858 /* XXX better yet, could spirit away the string to
4859 * a safe spot and hang on to it until the result
4860 * of pack() (and all copies of the result) are
4863 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4864 Perl_warner(aTHX_ WARN_UNSAFE,
4865 "Attempt to pack pointer to temporary value");
4866 if (SvPOK(fromstr) || SvNIOK(fromstr))
4867 aptr = SvPV(fromstr,n_a);
4869 aptr = SvPV_force(fromstr,n_a);
4871 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4876 aptr = SvPV(fromstr, fromlen);
4877 SvGROW(cat, fromlen * 4 / 3);
4882 while (fromlen > 0) {
4889 doencodes(cat, aptr, todo);
4908 register I32 limit = POPi; /* note, negative is forever */
4911 register char *s = SvPV(sv, len);
4912 char *strend = s + len;
4914 register REGEXP *rx;
4918 I32 maxiters = (strend - s) + 10;
4921 I32 origlimit = limit;
4924 AV *oldstack = PL_curstack;
4925 I32 gimme = GIMME_V;
4926 I32 oldsave = PL_savestack_ix;
4927 I32 make_mortal = 1;
4928 MAGIC *mg = (MAGIC *) NULL;
4931 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4936 DIE(aTHX_ "panic: do_split");
4937 rx = pm->op_pmregexp;
4939 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4940 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4942 if (pm->op_pmreplroot) {
4944 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4946 ary = GvAVn((GV*)pm->op_pmreplroot);
4949 else if (gimme != G_ARRAY)
4951 ary = (AV*)PL_curpad[0];
4953 ary = GvAVn(PL_defgv);
4954 #endif /* USE_THREADS */
4957 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4963 if (mg = SvTIED_mg((SV*)ary, 'P')) {
4965 XPUSHs(SvTIED_obj((SV*)ary, mg));
4971 for (i = AvFILLp(ary); i >= 0; i--)
4972 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4974 /* temporarily switch stacks */
4975 SWITCHSTACK(PL_curstack, ary);
4979 base = SP - PL_stack_base;
4981 if (pm->op_pmflags & PMf_SKIPWHITE) {
4982 if (pm->op_pmflags & PMf_LOCALE) {
4983 while (isSPACE_LC(*s))
4991 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4992 SAVEINT(PL_multiline);
4993 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4997 limit = maxiters + 2;
4998 if (pm->op_pmflags & PMf_WHITE) {
5001 while (m < strend &&
5002 !((pm->op_pmflags & PMf_LOCALE)
5003 ? isSPACE_LC(*m) : isSPACE(*m)))
5008 dstr = NEWSV(30, m-s);
5009 sv_setpvn(dstr, s, m-s);
5015 while (s < strend &&
5016 ((pm->op_pmflags & PMf_LOCALE)
5017 ? isSPACE_LC(*s) : isSPACE(*s)))
5021 else if (strEQ("^", rx->precomp)) {
5024 for (m = s; m < strend && *m != '\n'; m++) ;
5028 dstr = NEWSV(30, m-s);
5029 sv_setpvn(dstr, s, m-s);
5036 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
5037 && (rx->reganch & ROPT_CHECK_ALL)
5038 && !(rx->reganch & ROPT_ANCH)) {
5039 int tail = (rx->reganch & RE_INTUIT_TAIL);
5040 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5044 if (len == 1 && !tail) {
5048 for (m = s; m < strend && *m != c; m++) ;
5051 dstr = NEWSV(30, m-s);
5052 sv_setpvn(dstr, s, m-s);
5061 while (s < strend && --limit &&
5062 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5063 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
5066 dstr = NEWSV(31, m-s);
5067 sv_setpvn(dstr, s, m-s);
5071 s = m + len; /* Fake \n at the end */
5076 maxiters += (strend - s) * rx->nparens;
5077 while (s < strend && --limit
5078 /* && (!rx->check_substr
5079 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5081 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5082 1 /* minend */, sv, NULL, 0))
5084 TAINT_IF(RX_MATCH_TAINTED(rx));
5085 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
5090 strend = s + (strend - m);
5092 m = rx->startp[0] + orig;
5093 dstr = NEWSV(32, m-s);
5094 sv_setpvn(dstr, s, m-s);
5099 for (i = 1; i <= rx->nparens; i++) {
5100 s = rx->startp[i] + orig;
5101 m = rx->endp[i] + orig;
5103 dstr = NEWSV(33, m-s);
5104 sv_setpvn(dstr, s, m-s);
5107 dstr = NEWSV(33, 0);
5113 s = rx->endp[0] + orig;
5117 LEAVE_SCOPE(oldsave);
5118 iters = (SP - PL_stack_base) - base;
5119 if (iters > maxiters)
5120 DIE(aTHX_ "Split loop");
5122 /* keep field after final delim? */
5123 if (s < strend || (iters && origlimit)) {
5124 dstr = NEWSV(34, strend-s);
5125 sv_setpvn(dstr, s, strend-s);
5131 else if (!origlimit) {
5132 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
5138 SWITCHSTACK(ary, oldstack);
5139 if (SvSMAGICAL(ary)) {
5144 if (gimme == G_ARRAY) {
5146 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5154 call_method("PUSH",G_SCALAR|G_DISCARD);
5157 if (gimme == G_ARRAY) {
5158 /* EXTEND should not be needed - we just popped them */
5160 for (i=0; i < iters; i++) {
5161 SV **svp = av_fetch(ary, i, FALSE);
5162 PUSHs((svp) ? *svp : &PL_sv_undef);
5169 if (gimme == G_ARRAY)
5172 if (iters || !pm->op_pmreplroot) {
5182 Perl_unlock_condpair(pTHX_ void *svv)
5185 MAGIC *mg = mg_find((SV*)svv, 'm');
5188 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
5189 MUTEX_LOCK(MgMUTEXP(mg));
5190 if (MgOWNER(mg) != thr)
5191 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
5193 COND_SIGNAL(MgOWNERCONDP(mg));
5194 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5195 PTR2UV(thr), PTR2UV(svv));)
5196 MUTEX_UNLOCK(MgMUTEXP(mg));
5198 #endif /* USE_THREADS */
5211 mg = condpair_magic(sv);
5212 MUTEX_LOCK(MgMUTEXP(mg));
5213 if (MgOWNER(mg) == thr)
5214 MUTEX_UNLOCK(MgMUTEXP(mg));
5217 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5219 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5220 PTR2UV(thr), PTR2UV(sv));)
5221 MUTEX_UNLOCK(MgMUTEXP(mg));
5222 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
5224 #endif /* USE_THREADS */
5225 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5226 || SvTYPE(retsv) == SVt_PVCV) {
5227 retsv = refto(retsv);
5238 if (PL_op->op_private & OPpLVAL_INTRO)
5239 PUSHs(*save_threadsv(PL_op->op_targ));
5241 PUSHs(THREADSV(PL_op->op_targ));
5244 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
5245 #endif /* USE_THREADS */