Allow dup'ing of PerlIO::Scalar etc.

p4raw-id: //depot/perlio@13072

diff --git a/doio.c b/doio.c
index 58df123..d005a4e 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -172,6 +172,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        STRLEN olen = len;
        char *tend;
        int dodup = 0;
+       PerlIO *that_fp = NULL;
 
        type = savepvn(name, len);
        tend = type+len;
@@ -266,7 +267,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 
            if (*type == '&') {
              duplicity:
-               dodup = 1;
+               dodup = PERLIO_DUP_FD;
                type++;
                if (*type == '=') {
                    dodup = 0;
@@ -307,7 +308,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                            goto say_false;
                        }
                        if (IoIFP(thatio)) {
-                           PerlIO *fp = IoIFP(thatio);
+                           that_fp = IoIFP(thatio);
                            /* Flush stdio buffer before dup. --mjd
                             * Unfortunately SEEK_CURing 0 seems to
                             * be optimized away on most platforms;
@@ -317,15 +318,15 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                            /* sfio fails to clear error on next
                               sfwrite, contrary to documentation.
                               -- Nick Clark */
-                           if (PerlIO_seek(fp, 0, SEEK_CUR) == -1)
-                               PerlIO_clearerr(fp);
+                           if (PerlIO_seek(that_fp, 0, SEEK_CUR) == -1)
+                               PerlIO_clearerr(that_fp);
 #endif
                            /* On the other hand, do all platforms
                             * take gracefully to flushing a read-only
                             * filehandle?  Perhaps we should do
                             * fsetpos(src)+fgetpos(dst)?  --nik */
-                           PerlIO_flush(fp);
-                           fd = PerlIO_fileno(fp);
+                           PerlIO_flush(that_fp);
+                           fd = PerlIO_fileno(that_fp);
                            /* When dup()ing STDIN, STDOUT or STDERR
                             * explicitly set appropriate access mode */
                            if (IoIFP(thatio) == PerlIO_stdout()
@@ -341,15 +342,20 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                        else
                            fd = -1;
                    }
-                   if (dodup)
-                       fd = PerlLIO_dup(fd);
-                   else
-                       was_fdopen = TRUE;
                    if (!num_svs)
                        type = Nullch;
-                   if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
+                   if (that_fp) {
+                       fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
+                   }
+                   else {
                        if (dodup)
-                           PerlLIO_close(fd);
+                           fd = PerlLIO_dup(fd);
+                       else
+                           was_fdopen = TRUE;
+                       if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
+                           if (dodup)
+                               PerlLIO_close(fd);
+                       }
                    }
                }
            } /* & */
@@ -535,6 +541,10 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        if (savefd != fd) {
            Pid_t pid;
            SV *sv;
+           /* Still a small can-of-worms here if (say) PerlIO::Scalar
+              is assigned to (say) STDOUT - for now let dup2() fail
+              and provide the error
+            */
            if (PerlLIO_dup2(fd, savefd) < 0) {
                (void)PerlIO_close(fp);
                goto say_false;
@@ -557,8 +567,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            UNLOCK_FDPID_MUTEX;
            (void)SvUPGRADE(sv, SVt_IV);
            SvIVX(sv) = pid;
-           if (!was_fdopen)
+           if (!was_fdopen) {
                PerlIO_close(fp);
+           }
        }
        fp = saveifp;
        PerlIO_clearerr(fp);

diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs
index e7d8c6f..31be63b 100644 (file)
--- a/ext/Encode/Encode.xs
+++ b/ext/Encode/Encode.xs
@@ -52,9 +52,8 @@ typedef struct
 } PerlIOEncode;
 
 SV *
-PerlIOEncode_getarg(PerlIO *f)
+PerlIOEncode_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
 {
- dTHX;
  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
  SV *sv = &PL_sv_undef;
  if (e->enc)
@@ -329,9 +328,9 @@ PerlIOEncode_tell(PerlIO *f)
 }
 
 PerlIO *
-PerlIOEncode_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params)
+PerlIOEncode_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
 {
- if ((f = PerlIOBase_dup(aTHX_ f, o, params)))
+ if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags)))
   {
    PerlIOEncode *fe = PerlIOSelf(f,PerlIOEncode);
    PerlIOEncode *oe = PerlIOSelf(o,PerlIOEncode);

diff --git a/ext/PerlIO/Scalar/Scalar.xs b/ext/PerlIO/Scalar/Scalar.xs
index 3bd37de..8784a48 100644 (file)
--- a/ext/PerlIO/Scalar/Scalar.xs
+++ b/ext/PerlIO/Scalar/Scalar.xs
@@ -40,12 +40,12 @@ PerlIOScalar_pushed(PerlIO *f, const char *mode, SV *arg)
   }
  sv_upgrade(s->var,SVt_PV);
  code = PerlIOBase_pushed(f,mode,Nullsv);
+ if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
+   SvCUR(s->var) = 0;
  if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
-   s->posn = SvCUR(SvRV(arg));
+   s->posn = SvCUR(s->var);
  else
    s->posn = 0;
- if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
-   SvCUR(SvRV(arg)) = 0;
  return code;
 }
 
@@ -236,10 +236,29 @@ PerlIOScalar_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const c
  return NULL;
 }
 
+SV *
+PerlIOScalar_arg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
+{
+ PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+ SV *var = s->var;
+ if (flags & PERLIO_DUP_CLONE)
+  var = PerlIO_sv_dup(aTHX_ var, param);
+ else if (flags & PERLIO_DUP_FD)
+  {
+   /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
+   var = newSVsv(var);
+  }
+ else
+  {
+   var = SvREFCNT_inc(var);
+  }
+ return newRV_noinc(var);
+}
+
 PerlIO *
-PerlIOScalar_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOScalar_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
- if ((f = PerlIOBase_dup(aTHX_ f, o, param)))
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
   {
    PerlIOScalar *fs = PerlIOSelf(f,PerlIOScalar);
    PerlIOScalar *os = PerlIOSelf(o,PerlIOScalar);
@@ -256,7 +275,7 @@ PerlIO_funcs PerlIO_scalar = {
  PerlIOScalar_pushed,
  PerlIOScalar_popped,
  PerlIOScalar_open,
- NULL,
+ PerlIOScalar_arg,
  PerlIOScalar_fileno,
  PerlIOScalar_dup,
  PerlIOBase_read,

diff --git a/ext/PerlIO/Via/Via.xs b/ext/PerlIO/Via/Via.xs
index adf0abf..783eb9d 100644 (file)
--- a/ext/PerlIO/Via/Via.xs
+++ b/ext/PerlIO/Via/Via.xs
@@ -464,14 +464,6 @@ PerlIOVia_clearerr(PerlIO *f)
  PerlIOBase_clearerr(f);
 }
 
-SV *
-PerlIOVia_getarg(PerlIO *f)
-{
- dTHX;
- PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
- return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
-}
-
 IV
 PerlIOVia_error(PerlIO *f)
 {
@@ -490,12 +482,19 @@ PerlIOVia_eof(PerlIO *f)
  return (result) ? SvIV(result) : PerlIOBase_eof(f);
 }
 
+SV *
+PerlIOVia_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
+{
+ PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
+ return PerlIOVia_method(aTHX_ f,MYMethod(GETARG),G_SCALAR,Nullsv);
+}
+
 PerlIO *
-PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
- if ((f = PerlIOBase_dup(aTHX_ f, o, param)))
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
   {
-   /* Most of the fields will lazily set them selves up as needed
+   /* Most of the fields will lazily set themselves up as needed
       stash and obj have been set up by the implied push
     */
   }

diff --git a/ext/PerlIO/t/scalar.t b/ext/PerlIO/t/scalar.t
index 8368e66..fd1b852 100644 (file)
--- a/ext/PerlIO/t/scalar.t
+++ b/ext/PerlIO/t/scalar.t
@@ -10,7 +10,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..20\n";
+print "1..22\n";
 
 my $fh;
 my $var = "ok 2\n";
@@ -99,3 +99,19 @@ close $fh;
 print "# Got [$var], expect [foo]\n";
 print "not " unless $var eq "foo";
 print "ok 20\n";
+
+# Check that dup'ing the handle works
+
+$var = '';
+
+open $fh, "+>", \$var;
+print $fh "ok 21\n";
+open $dup,'+<&',$fh;
+print $dup "ok 22\n";
+seek($dup,0,0);
+while (<$dup>) {
+    print;
+}
+close($fh);
+close($dup);
+

diff --git a/perlio.c b/perlio.c
index 88b3758..5584d64 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -178,7 +178,7 @@ PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 }
 
 PerlIO *
-PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
+PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
 {
 #ifndef PERL_MICRO
     if (f) {
@@ -442,13 +442,13 @@ PerlIO_allocate(pTHX)
 
 #undef PerlIO_fdupopen
 PerlIO *
-PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
+PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
 {
     if (f && *f) {
        PerlIO_funcs *tab = PerlIOBase(f)->tab;
        PerlIO *new;
        PerlIO_debug("fdupopen f=%p param=%p\n",f,param);
-        new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param);
+        new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
        return new;
     }
     else {
@@ -1259,7 +1259,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
            while (l) {
                SV *arg =
                    (l->tab->Getarg) ? (*l->tab->
-                                       Getarg) (&l) : &PL_sv_undef;
+                                       Getarg) (aTHX_ &l, NULL, 0) : &PL_sv_undef;
                PerlIO_list_push(aTHX_ layera, l->tab, arg);
                l = *PerlIONext(&l);
            }
@@ -1976,12 +1976,12 @@ PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
 }
 
 PerlIO *
-PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
     PerlIO *nexto = PerlIONext(o);
     if (*nexto) {
        PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
-       f = (*tab->Dup)(aTHX_ f, nexto, param);
+       f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
     }
     if (f) {
        PerlIO_funcs *self = PerlIOBase(o)->tab;
@@ -1989,13 +1989,10 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
        char buf[8];
        PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",self->name,f,o,param);
        if (self->Getarg) {
-           arg = (*self->Getarg)(o);
-           if (arg) {
-               arg = PerlIO_sv_dup(aTHX_ arg, param);
-           }
+           arg = (*self->Getarg)(aTHX_ o,param,flags);
        }
        f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
-       if (!f && arg) {
+       if (arg) {
            SvREFCNT_dec(arg);
        }
     }
@@ -2207,12 +2204,15 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 }
 
 PerlIO *
-PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
     PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
     int fd = os->fd;
+    if (flags & PERLIO_DUP_FD) {
+       fd = PerlLIO_dup(fd);
+    }
     if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
-       f = PerlIOBase_dup(aTHX_ f, o, param);
+       f = PerlIOBase_dup(aTHX_ f, o, param, flags);
        if (f) {
            /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
            PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
@@ -2485,13 +2485,27 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 }
 
 PerlIO *
-PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
     /* This assumes no layers underneath - which is what
        happens, but is not how I remember it. NI-S 2001/10/16
      */
-    if ((f = PerlIOBase_dup(aTHX_ f, o, param))) {
+    if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
        FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
+       if (flags & PERLIO_DUP_FD) {
+           int fd = PerlLIO_dup(fileno(stdio));
+           if (fd >= 0) {
+               char mode[8];
+               int omode = fcntl(fd, F_GETFL);
+               PerlIO_intmode2str(omode,mode,NULL);
+               stdio = fdopen(fd, mode);
+           }
+           else {
+               /* FIXME: To avoid messy error recovery if dup fails
+                  re-use the existing stdio as though flag was not set
+                */
+           }
+       }
        PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
        PerlIOUnix_refcnt_inc(fileno(stdio));
     }
@@ -3246,9 +3260,9 @@ PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 }
 
 PerlIO *
-PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
- return PerlIOBase_dup(aTHX_ f, o, param);
+ return PerlIOBase_dup(aTHX_ f, o, param, flags);
 }
 
 
@@ -3974,9 +3988,9 @@ PerlIOMmap_close(PerlIO *f)
 }
 
 PerlIO *
-PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
- return PerlIOBase_dup(aTHX_ f, o, param);
+ return PerlIOBase_dup(aTHX_ f, o, param, flags);
 }
 
 

diff --git a/perlio.h b/perlio.h
index 3c0234e..b7b2556 100644 (file)
--- a/perlio.h
+++ b/perlio.h
@@ -178,6 +178,9 @@ extern void PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param);
 #define SEEK_END 2
 #endif
 
+#define PERLIO_DUP_CLONE       1
+#define PERLIO_DUP_FD          2
+
 /* --------------------- Now prototypes for functions --------------- */
 
 START_EXTERN_C
@@ -330,7 +333,7 @@ extern int PerlIO_getpos(PerlIO *, SV *);
 extern int PerlIO_setpos(PerlIO *, SV *);
 #endif
 #ifndef PerlIO_fdupopen
-extern PerlIO *PerlIO_fdupopen(pTHX_ PerlIO *, CLONE_PARAMS *);
+extern PerlIO *PerlIO_fdupopen(pTHX_ PerlIO *, CLONE_PARAMS *, int);
 #endif
 #if !defined(PerlIO_modestr) && !defined(PERLIO_IS_STDIO)
 extern char *PerlIO_modestr(PerlIO *, char *buf);

diff --git a/perliol.h b/perliol.h
index a84d1c6..226de6a 100644 (file)
--- a/perliol.h
+++ b/perliol.h
@@ -24,9 +24,9 @@ struct _PerlIO_funcs {
                     const char *mode,
                     int fd, int imode, int perm,
                     PerlIO *old, int narg, SV **args);
-    SV *(*Getarg) (PerlIO *f);
+    SV *(*Getarg) (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags);
     IV (*Fileno) (PerlIO *f);
-    PerlIO *(*Dup) (pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param);
+    PerlIO *(*Dup) (pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
     /* Unix-like functions - cf sfio line disciplines */
      SSize_t(*Read) (PerlIO *f, void *vbuf, Size_t count);
      SSize_t(*Unread) (PerlIO *f, const void *vbuf, Size_t count);
@@ -120,7 +120,7 @@ extern SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n);
 /* Generic, or stub layer functions */
 
 extern IV PerlIOBase_fileno(PerlIO *f);
-extern PerlIO *PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param);
+extern PerlIO *PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
 extern IV PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg);
 extern IV PerlIOBase_popped(PerlIO *f);
 extern SSize_t PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count);
@@ -158,7 +158,7 @@ extern PerlIO *PerlIOBuf_open(pTHX_ PerlIO_funcs *self,
                              const char *mode, int fd, int imode,
                              int perm, PerlIO *old, int narg, SV **args);
 extern IV PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg);
-extern PerlIO *PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param);
+extern PerlIO *PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
 extern SSize_t PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count);
 extern SSize_t PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count);
 extern SSize_t PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count);

diff --git a/sv.c b/sv.c
index 997a3a8..8453d28 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1768,7 +1768,7 @@ S_not_a_number(pTHX_ SV *sv)
          char *limit = tmpbuf + sizeof(tmpbuf) - 8;
          /* each *s can expand to 4 chars + "...\0",
             i.e. need room for 8 chars */
-         
+       
          char *s, *end;
          for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
               int ch = *s & 0xFF;
@@ -3326,7 +3326,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
         }
         if (hibit) {
              STRLEN len;
-             
+       
              len = SvCUR(sv) + 1; /* Plus the \0 */
              SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
              SvCUR(sv) = len - 1;
@@ -7234,7 +7234,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash)
             mg_set(tmpRef);
 
 
- 
+
     return sv;
 }
 
@@ -8522,7 +8522,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
        return ret;
 
     /* create anew and remember what it is */
-    ret = PerlIO_fdupopen(aTHX_ fp, param);
+    ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
     ptr_table_store(PL_ptr_table, fp, ret);
     return ret;
 }