From: Nick Ing-Simmons Date: Sun, 18 Nov 2001 16:15:31 +0000 (+0000) Subject: Allow dup'ing of PerlIO::Scalar etc. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ecdeb87c58ecf41e283516bbe30cb8616ec66e13;p=p5sagit%2Fp5-mst-13.2.git Allow dup'ing of PerlIO::Scalar etc. p4raw-id: //depot/perlio@13072 --- diff --git a/doio.c b/doio.c index 58df123..d005a4e 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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; }