Long double patches from Dan Sugalski.

[perl5.git] / doop.c

diff --git a/doop.c b/doop.c
index a3663f9..ad626ca 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -1,6 +1,6 @@
 /*    doop.c
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-1999, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -12,14 +12,15 @@
  */
 
 #include "EXTERN.h"
+#define PERL_IN_DOOP_C
 #include "perl.h"
 
 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
 #include <signal.h>
 #endif
 
-static I32
-do_trans_CC_simple(SV *sv)
+STATIC I32
+S_do_trans_CC_simple(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -31,7 +32,7 @@ do_trans_CC_simple(SV *sv)
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-       croak("panic: do_trans");
+       Perl_croak(aTHX_ "panic: do_trans");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
@@ -48,8 +49,8 @@ do_trans_CC_simple(SV *sv)
     return matches;
 }
 
-static I32
-do_trans_CC_count(SV *sv)
+STATIC I32
+S_do_trans_CC_count(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -60,7 +61,7 @@ do_trans_CC_count(SV *sv)
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-       croak("panic: do_trans");
+       Perl_croak(aTHX_ "panic: do_trans");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
@@ -74,8 +75,8 @@ do_trans_CC_count(SV *sv)
     return matches;
 }
 
-static I32
-do_trans_CC_complex(SV *sv)
+STATIC I32
+S_do_trans_CC_complex(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -88,7 +89,7 @@ do_trans_CC_complex(SV *sv)
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-       croak("panic: do_trans");
+       Perl_croak(aTHX_ "panic: do_trans");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
@@ -131,8 +132,8 @@ do_trans_CC_complex(SV *sv)
     return matches;
 }
 
-static I32
-do_trans_UU_simple(SV *sv)
+STATIC I32
+S_do_trans_UU_simple(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -183,8 +184,8 @@ do_trans_UU_simple(SV *sv)
     return matches;
 }
 
-static I32
-do_trans_UU_count(SV *sv)
+STATIC I32
+S_do_trans_UU_count(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -202,17 +203,16 @@ do_trans_UU_count(SV *sv)
     send = s + len;
 
     while (s < send) {
-       if ((uv = swash_fetch(rv, s)) < none) {
-           s += UTF8SKIP(s);
+       if ((uv = swash_fetch(rv, s)) < none)
            matches++;
-       }
+       s += UTF8SKIP(s);
     }
 
     return matches;
 }
 
-static I32
-do_trans_UC_simple(SV *sv)
+STATIC I32
+S_do_trans_UC_simple(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -264,8 +264,8 @@ do_trans_UC_simple(SV *sv)
     return matches;
 }
 
-static I32
-do_trans_CU_simple(SV *sv)
+STATIC I32
+S_do_trans_CU_simple(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -327,8 +327,8 @@ do_trans_CU_simple(SV *sv)
 
 /* utf-8 to latin-1 */
 
-static I32
-do_trans_UC_trivial(SV *sv)
+STATIC I32
+S_do_trans_UC_trivial(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -359,8 +359,8 @@ do_trans_UC_trivial(SV *sv)
 
 /* latin-1 to utf-8 */
 
-static I32
-do_trans_CU_trivial(SV *sv)
+STATIC I32
+S_do_trans_CU_trivial(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -393,8 +393,8 @@ do_trans_CU_trivial(SV *sv)
     return matches;
 }
 
-static I32
-do_trans_UU_complex(SV *sv)
+STATIC I32
+S_do_trans_UU_complex(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -579,12 +579,13 @@ do_trans_UU_complex(SV *sv)
 }
 
 I32
-do_trans(SV *sv)
+Perl_do_trans(pTHX_ SV *sv)
 {
+    dTHR;
     STRLEN len;
 
     if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
-       croak(no_modify);
+       Perl_croak(aTHX_ PL_no_modify);
 
     (void)SvPV(sv, len);
     if (!len)
@@ -593,7 +594,7 @@ do_trans(SV *sv)
        (void)SvPV_force(sv, len);
     (void)SvPOK_only(sv);
 
-    DEBUG_t( deb("2.TBL\n"));
+    DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 
     switch (PL_op->op_private & 63) {
     case 0:
@@ -629,7 +630,7 @@ do_trans(SV *sv)
 }
 
 void
-do_join(register SV *sv, SV *del, register SV **mark, register SV **sp)
+Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp)
 {
     SV **oldmark = mark;
     register I32 items = sp - mark;
@@ -640,8 +641,7 @@ do_join(register SV *sv, SV *del, register SV **mark, register SV **sp)
 
     mark++;
     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
-    if (SvTYPE(sv) < SVt_PV)
-       sv_upgrade(sv, SVt_PV);
+    (void)SvUPGRADE(sv, SVt_PV);
     if (SvLEN(sv) < len + items) {     /* current length is way too short */
        while (items-- > 0) {
            if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) {
@@ -653,7 +653,7 @@ do_join(register SV *sv, SV *del, register SV **mark, register SV **sp)
        SvGROW(sv, len + 1);            /* so try to pre-extend */
 
        mark = oldmark;
-       items = sp - mark;;
+       items = sp - mark;
        ++mark;
     }
 
@@ -685,7 +685,7 @@ do_join(register SV *sv, SV *del, register SV **mark, register SV **sp)
 }
 
 void
-do_sprintf(SV *sv, I32 len, SV **sarg)
+Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
 {
     STRLEN patlen;
     char *pat = SvPV(*sarg, patlen);
@@ -698,7 +698,7 @@ do_sprintf(SV *sv, I32 len, SV **sarg)
 }
 
 void
-do_vecset(SV *sv)
+Perl_do_vecset(pTHX_ SV *sv)
 {
     SV *targ = LvTARG(sv);
     register I32 offset;
@@ -746,10 +746,11 @@ do_vecset(SV *sv)
            s[offset+3] = lval & 255;
        }
     }
+    SvSETMAGIC(targ);
 }
 
 void
-do_chop(register SV *astr, register SV *sv)
+Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
 {
     STRLEN len;
     char *s;
@@ -767,7 +768,7 @@ do_chop(register SV *astr, register SV *sv)
        }
         return;
     }
-    if (SvTYPE(sv) == SVt_PVHV) {
+    else if (SvTYPE(sv) == SVt_PVHV) {
         HV* hv = (HV*)sv;
        HE* entry;
         (void)hv_iterinit(hv);
@@ -776,6 +777,8 @@ do_chop(register SV *astr, register SV *sv)
             do_chop(astr,hv_iterval(hv,entry));
         return;
     }
+    else if (SvREADONLY(sv))
+       Perl_croak(aTHX_ PL_no_modify);
     s = SvPV(sv, len);
     if (len && !SvPOK(sv))
        s = SvPV_force(sv, len);
@@ -786,8 +789,8 @@ do_chop(register SV *astr, register SV *sv)
            s = send - 1;
            while ((*s & 0xc0) == 0x80)
                --s;
-           if (UTF8SKIP(s) != send - s)
-               warn("Malformed UTF-8 character");
+           if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8))
+               Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
            sv_setpvn(astr, s, send - s);
            *s = '\0';
            SvCUR_set(sv, s - start);
@@ -810,7 +813,7 @@ do_chop(register SV *astr, register SV *sv)
 } 
 
 I32
-do_chomp(register SV *sv)
+Perl_do_chomp(pTHX_ register SV *sv)
 {
     dTHR;
     register I32 count;
@@ -819,6 +822,8 @@ do_chomp(register SV *sv)
 
     if (RsSNARF(PL_rs))
        return 0;
+    if (RsRECORD(PL_rs))
+      return 0;
     count = 0;
     if (SvTYPE(sv) == SVt_PVAV) {
        register I32 i;
@@ -832,7 +837,7 @@ do_chomp(register SV *sv)
        }
         return count;
     }
-    if (SvTYPE(sv) == SVt_PVHV) {
+    else if (SvTYPE(sv) == SVt_PVHV) {
         HV* hv = (HV*)sv;
        HE* entry;
         (void)hv_iterinit(hv);
@@ -841,6 +846,8 @@ do_chomp(register SV *sv)
             count += do_chomp(hv_iterval(hv,entry));
         return count;
     }
+    else if (SvREADONLY(sv))
+       Perl_croak(aTHX_ PL_no_modify);
     s = SvPV(sv, len);
     if (len && !SvPOKp(sv))
        s = SvPV_force(sv, len);
@@ -884,7 +891,7 @@ do_chomp(register SV *sv)
 } 
 
 void
-do_vop(I32 optype, SV *sv, SV *left, SV *right)
+Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 {
     dTHR;      /* just for taint */
 #ifdef LIBERAL
@@ -909,7 +916,8 @@ do_vop(I32 optype, SV *sv, SV *left, SV *right)
     len = leftlen < rightlen ? leftlen : rightlen;
     lensave = len;
     if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
-       dc = SvPV_force(sv, PL_na);
+       STRLEN n_a;
+       dc = SvPV_force(sv, n_a);
        if (SvCUR(sv) < len) {
            dc = SvGROW(sv, len + 1);
            (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
@@ -998,7 +1006,7 @@ do_vop(I32 optype, SV *sv, SV *left, SV *right)
 }
 
 OP *
-do_kv(ARGSproto)
+Perl_do_kv(pTHX)
 {
     djSP;
     HV *hv = (HV*)POPs;
@@ -1048,7 +1056,7 @@ do_kv(ARGSproto)
            RETURN;
        }
 
-       if (!SvRMAGICAL(keys) || !mg_find((SV*)keys,'P'))
+       if (! SvTIED_mg((SV*)keys, 'P'))
            i = HvKEYS(keys);
        else {
            i = 0;
@@ -1070,7 +1078,7 @@ do_kv(ARGSproto)
            PUTBACK;
            tmpstr = realhv ?
                     hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
-           DEBUG_H(sv_setpvf(tmpstr, "%lu%%%d=%lu",
+           DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
                            (unsigned long)HeHASH(entry),
                            HvMAX(keys)+1,
                            (unsigned long)(HeHASH(entry) & HvMAX(keys))));