summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doio.c37
-rw-r--r--ext/Encode/Encode.xs7
-rw-r--r--ext/PerlIO/Scalar/Scalar.xs31
-rw-r--r--ext/PerlIO/Via/Via.xs21
-rw-r--r--ext/PerlIO/t/scalar.t18
-rw-r--r--perlio.c52
-rw-r--r--perlio.h5
-rw-r--r--perliol.h8
-rw-r--r--sv.c8
9 files changed, 124 insertions, 63 deletions
diff --git a/doio.c b/doio.c
index 58df123f23..d005a4e72e 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 e7d8c6f5c7..31be63b90c 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 3bd37de010..8784a48804 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 adf0abfd78..783eb9d279 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 8368e666b9..fd1b852657 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 88b3758345..5584d64abe 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 3c0234ebca..b7b25560fe 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 a84d1c6ff1..226de6a695 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 997a3a8b26..8453d286b6 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;
}
View Lorry Controller Status