Silence one more format warning

[perl5.git] / ext / PerlIO / scalar / scalar.xs

diff --git a/ext/PerlIO/scalar/scalar.xs b/ext/PerlIO/scalar/scalar.xs
index b26a238..6876b2b 100644 (file)
--- a/ext/PerlIO/scalar/scalar.xs
+++ b/ext/PerlIO/scalar/scalar.xs
@@ -24,9 +24,16 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
      */
     if (arg) {
        if (SvROK(arg)) {
+           if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
+               if (ckWARN(WARN_LAYER))
+                   Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
+               SETERRNO(EINVAL, SS_IVCHAN);
+               return -1;
+           }
            s->var = SvREFCNT_inc(SvRV(arg));
-           if (!SvPOK(s->var))
-               (void)SvPV_nolen(s->var);
+           SvGETMAGIC(s->var);
+           if (!SvPOK(s->var) && SvOK(s->var))
+               (void)SvPV_nomg_const_nolen(s->var);
        }
        else {
            s->var =
@@ -37,10 +44,10 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
     else {
        s->var = newSVpvn("", 0);
     }
-    sv_upgrade(s->var, SVt_PV);
+    SvUPGRADE(s->var, SVt_PV);
     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
-    if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
-       SvCUR(s->var) = 0;
+    if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
+       SvCUR_set(s->var, 0);
     if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
        s->posn = SvCUR(s->var);
     else
@@ -77,20 +84,36 @@ IV
 PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
 {
     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+    STRLEN oldcur = SvCUR(s->var);
+    STRLEN newlen;
     switch (whence) {
-    case 0:
+    case SEEK_SET:
        s->posn = offset;
        break;
-    case 1:
+    case SEEK_CUR:
        s->posn = offset + s->posn;
        break;
-    case 2:
+    case SEEK_END:
        s->posn = offset + SvCUR(s->var);
        break;
     }
-    if ((STRLEN) s->posn > SvCUR(s->var)) {
-       (void) SvGROW(s->var, (STRLEN) s->posn);
+    if (s->posn < 0) {
+        if (ckWARN(WARN_LAYER))
+           Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
+       SETERRNO(EINVAL, SS_IVCHAN);
+       return -1;
     }
+    newlen = (STRLEN) s->posn;
+    if (newlen > oldcur) {
+       (void) SvGROW(s->var, newlen);
+       Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
+       /* No SvCUR_set(), though.  This is just a seek, not a write. */
+    }
+    else if (!SvPVX(s->var)) {
+       /* ensure there's always a character buffer */
+       (void)SvGROW(s->var,1);
+    }
+    SvPOK_on(s->var);
     return 0;
 }
 
@@ -106,9 +129,8 @@ PerlIOScalar_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
 {
     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
     char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
+    s->posn -= count;
     Move(vbuf, dst + s->posn, count, char);
-    s->posn += count;
-    SvCUR_set(s->var, (STRLEN)s->posn);
     SvPOK_on(s->var);
     return count;
 }
@@ -163,7 +185,7 @@ PerlIOScalar_get_base(pTHX_ PerlIO * f)
     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
        return (STDCHAR *) SvPV_nolen(s->var);
     }
-    return (STDCHAR *) Nullch;
+    return (STDCHAR *) NULL;
 }
 
 STDCHAR *
@@ -173,7 +195,7 @@ PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
        PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
        return PerlIOScalar_get_base(aTHX_ f) + s->posn;
     }
-    return (STDCHAR *) Nullch;
+    return (STDCHAR *) NULL;
 }
 
 SSize_t
@@ -254,7 +276,7 @@ PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
     return f;
 }
 
-PerlIO_funcs PerlIO_scalar = {
+PERLIO_FUNCS_DECL(PerlIO_scalar) = {
     sizeof(PerlIO_funcs),
     "scalar",
     sizeof(PerlIOScalar),
@@ -295,7 +317,7 @@ PROTOTYPES: ENABLE
 BOOT:
 {
 #ifdef PERLIO_LAYERS
- PerlIO_define_layer(aTHX_ &PerlIO_scalar);
+ PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
 #endif
 }