Michael Schroeder's fix for re-try if stdio ops after

[p5sagit/p5-mst-13.2.git] / sv.c

diff --git a/sv.c b/sv.c
index a1a7753..5a99375 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5524,7 +5524,7 @@ Perl_sv_len_utf8(pTHX_ register SV *sv)
  *
  */
 STATIC bool
-S_utf8_mg_pos_init(SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
+S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
 {
     bool found = FALSE; 
 
@@ -5559,7 +5559,7 @@ S_utf8_mg_pos_init(SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8
  *
  */
 STATIC bool
-S_utf8_mg_pos(SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
+S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
 {
     bool found = FALSE;
 
@@ -5568,7 +5568,7 @@ S_utf8_mg_pos(SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uof
            *mgp = mg_find(sv, PERL_MAGIC_utf8);
        if (*mgp && (*mgp)->mg_ptr) {
            *cachep = (STRLEN *) (*mgp)->mg_ptr;
-           if ((*cachep)[i] == uoff)   /* An exact match. */
+           if ((*cachep)[i] == (STRLEN)uoff)   /* An exact match. */
                 found = TRUE;
            else {                      /* We will skip to the right spot. */
                 STRLEN forw  = 0;
@@ -5580,9 +5580,9 @@ S_utf8_mg_pos(SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uof
                  * 2 * backw in the below comes from).  (The real
                  * figure of course depends on the UTF-8 data.) */
 
-                if ((*cachep)[i] > uoff) {
+                if ((*cachep)[i] > (STRLEN)uoff) {
                      forw  = uoff;
-                     backw = (*cachep)[i] - uoff;
+                     backw = (*cachep)[i] - (STRLEN)uoff;
 
                      if (forw < 2 * backw)
                           p = start;
@@ -5594,9 +5594,9 @@ S_utf8_mg_pos(SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uof
                 else if (i == 0) { /* (*cachep)[i] < uoff */
                      STRLEN ulen = sv_len_utf8(sv);
 
-                     if (uoff < ulen) {
-                          forw  = uoff - (*cachep)[i];
-                          backw = ulen - uoff;
+                     if ((STRLEN)uoff < ulen) {
+                          forw  = (STRLEN)uoff - (*cachep)[i];
+                          backw = ulen - (STRLEN)uoff;
 
                           if (forw < 2 * backw)
                                p = start + (*cachep)[i+1];
@@ -5622,7 +5622,7 @@ S_utf8_mg_pos(SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uof
                      }
 
                      /* Update the cache. */
-                     (*cachep)[i]   = uoff;
+                     (*cachep)[i]   = (STRLEN)uoff;
                      (*cachep)[i+1] = p - start;
  
                      found = TRUE;
@@ -5683,21 +5683,21 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
         MAGIC *mg = 0;
         bool found = FALSE;
 
-         if (S_utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
+         if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
              found = TRUE;
         if (!found && uoffset > 0) {
              while (s < send && uoffset--)
                   s += UTF8SKIP(s);
              if (s >= send)
                   s = send;
-              if (S_utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
+              if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
                   boffset = cache[1];
              *offsetp = s - start;
         }
         if (lenp) {
              found = FALSE;
              start = s;
-              if (S_utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
+              if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
                   *lenp -= boffset;
                   found = TRUE;
               }
@@ -5708,7 +5708,7 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
                             s += UTF8SKIP(s);
                   if (s >= send)
                        s = send;
-                   if (S_utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
+                   if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
                        cache[2] += *offsetp;
              }
              *lenp = s - start;
@@ -5787,6 +5787,8 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
                        U8 *p = s + cache[1];
                        STRLEN ubackw = 0;
                             
+                       cache[1] -= backw;
+
                        while (backw--) {
                            p--;
                            while (UTF8_IS_CONTINUATION(*p))
@@ -5795,7 +5797,6 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
                        }
 
                        cache[0] -= ubackw;
-                       cache[1] -= backw;
 
                        return;
                    }
@@ -6153,6 +6154,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
     register I32 cnt;
     I32 i = 0;
     I32 rspara = 0;
+    I32 recsize;
 
     SV_CHECK_THINKFIRST_COW_DROP(sv);
     /* XXX. If you make this PVIV, then copy on write can copy scalars read
@@ -6163,6 +6165,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
     (void)SvUPGRADE(sv, SVt_PV);
 
     SvSCREAM_off(sv);
+    SvPOK_only(sv);    /* Validate pointer */
 
     if (PL_curcop == &PL_compiling) {
        /* we always read code in line mode */
@@ -6170,17 +6173,22 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
        rslen = 1;
     }
     else if (RsSNARF(PL_rs)) {
+       Stat_t st;
+       if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && st.st_size
+               && (recsize = st.st_size - PerlIO_tell(fp)))
+           goto read_record;
        rsptr = NULL;
        rslen = 0;
     }
     else if (RsRECORD(PL_rs)) {
-      I32 recsize, bytesread;
+      I32 bytesread;
       char *buffer;
 
       /* Grab the size of the record we're getting */
       recsize = SvIV(SvRV(PL_rs));
-      (void)SvPOK_only(sv);    /* Validate pointer */
-      buffer = SvGROW(sv, (STRLEN)(recsize + 1));
+
+    read_record:
+      buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
       /* Go yank in */
 #ifdef VMS
       /* VMS wants read instead of fread, because fread doesn't respect */
@@ -6190,13 +6198,9 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
 #else
       bytesread = PerlIO_read(fp, buffer, recsize);
 #endif
-      SvCUR_set(sv, bytesread);
+      SvCUR_set(sv, bytesread += append);
       buffer[bytesread] = '\0';
-      if (PerlIO_isutf8(fp))
-       SvUTF8_on(sv);
-      else
-       SvUTF8_off(sv);
-      return(SvCUR(sv) ? SvPVX(sv) : Nullch);
+      goto check_utf8_and_return;
     }
     else if (RsPARA(PL_rs)) {
        rsptr = "\n\n";
@@ -6265,7 +6269,6 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
     /* Here is some breathtakingly efficient cheating */
 
     cnt = PerlIO_get_cnt(fp);                  /* get count into register */
-    (void)SvPOK_only(sv);              /* validate pointer */
     if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */
        if (cnt > 80 && (I32)SvLEN(sv) > append) {
            shortbuffered = cnt - SvLEN(sv) + append + 1;
@@ -6445,6 +6448,7 @@ screamer2:
        }
     }
 
+check_utf8_and_return:
     if (PerlIO_isutf8(fp))
        SvUTF8_on(sv);
     else
@@ -7883,7 +7887,9 @@ Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
     }
     SvRV(sv) = 0;
     SvROK_off(sv);
-    if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || (flags & SV_IMMEDIATE_UNREF))
+    /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
+       assigned to as BEGIN {$a = \"Foo"} will fail.  */
+    if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
        SvREFCNT_dec(rv);
     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
        sv_2mortal(rv);         /* Schedule for freeing later */