From: Nick Ing-Simmons Date: Thu, 22 Mar 2001 22:26:51 +0000 (+0000) Subject: Snapshot of new PerlIO open scheme. Still buggy - mainly in open($fh,">&STDOUT!") X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ee518936bd3eee0065c20591f5182f733dadd4bd;p=p5sagit%2Fp5-mst-13.2.git Snapshot of new PerlIO open scheme. Still buggy - mainly in open($fh,">&STDOUT!") type code. - Invent PerlIO_openn() - which has "lots" of args a bit like do_openn() which is its main caller. In particular now has access to "extra" args, and can tell when an open handle is "reopened" (or duped?). - In -Duseperlio PerlIO_open() et. al. are now wrappers on PerlIO_openn(). - In -Uuseperlio (untested as yet) PerlIO_openn() is a wrapper on PerlIO_open() et. al. (i.e. other way round). - Collapse "vtable" entries for layers - was fdopen/open/reopen now just open with args close to PerlIO_openn(). p4raw-id: //depot/perlio@9302 --- diff --git a/doio.c b/doio.c index a32604e..3a4bbe7 100644 --- a/doio.c +++ b/doio.c @@ -68,6 +68,28 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, supplied_fp, &svs, 1); } +static char *S_layers(pTHX_ char *mode); + +static char * +S_layers(pTHX_ char *mode) +{ + char *type = NULL; + /* Need to supply default layer info from open.pm */ + SV *layers = PL_curcop->cop_io; + if (layers) { + STRLEN len; + type = SvPV(layers,len); + if (type && mode[0] != 'r') { + /* Skip to write part */ + char *s = strchr(type,0); + if (s && (s-type) < len) { + type = s+1; + } + } + } + return type; +} + bool Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, @@ -76,6 +98,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, register IO *io = GvIOn(gv); PerlIO *saveifp = Nullfp; PerlIO *saveofp = Nullfp; + int savefd = -1; char savetype = IoTYPE_CLOSED; int writing = 0; PerlIO *fp; @@ -84,8 +107,8 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, bool was_fdopen = FALSE; bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; char *type = NULL; - char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ - SV *svs = (num_svs) ? *svp : Nullsv; + char mode[8]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ + SV *namesv; Zero(mode,sizeof(mode),char); PL_forkprocess = 1; /* assume true if no fork */ @@ -103,13 +126,17 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /* If currently open - close before we re-open */ if (IoIFP(io)) { fd = PerlIO_fileno(IoIFP(io)); - if (IoTYPE(io) == IoTYPE_STD) + if (IoTYPE(io) == IoTYPE_STD) { + /* This is a clone of one of STD* handles */ result = 0; - else if (fd <= PL_maxsysfd) { - saveifp = IoIFP(io); - saveofp = IoOFP(io); + } + else if (fd >= 0 && fd <= PL_maxsysfd) { + /* This is one of the original STD* handles */ + saveifp = IoIFP(io); + saveofp = IoOFP(io); savetype = IoTYPE(io); - result = 0; + savefd = fd; + result = 0; } else if (IoTYPE(io) == IoTYPE_PIPE) result = PerlProc_pclose(IoIFP(io)); @@ -123,18 +150,22 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } else result = PerlIO_close(IoIFP(io)); - if (result == EOF && fd > PL_maxsysfd) + if (result == EOF && fd > PL_maxsysfd) { + /* Why is this not Perl_warn*() call ? */ PerlIO_printf(Perl_error_log, "Warning: unable to close filehandle %s properly.\n", GvENAME(gv)); + } IoOFP(io) = IoIFP(io) = Nullfp; } if (as_raw) { /* sysopen style args, i.e. integer mode and permissions */ + STRLEN ix = 0; if (num_svs != 0) { Perl_croak(aTHX_ "panic:sysopen with multiple args"); } + mode[ix++] = '#'; /* Marker to openn to use numeric "sysopen" */ #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) rawmode |= O_LARGEFILE; @@ -156,39 +187,34 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoTYPE(io) = IoTYPE_RDWR; break; } - writing = (result > 0); - fd = PerlLIO_open3(name, rawmode, rawperm); - if (fd == -1) - fp = NULL; - else { - STRLEN ix = 0; - if (result == O_RDONLY) { - mode[ix++] = 'r'; - } + if (result == O_RDONLY) { + mode[ix++] = 'r'; + } #ifdef O_APPEND - else if (rawmode & O_APPEND) { - mode[ix++] = 'a'; - if (result != O_WRONLY) - mode[ix++] = '+'; - } + else if (rawmode & O_APPEND) { + mode[ix++] = 'a'; + if (result != O_WRONLY) + mode[ix++] = '+'; + } #endif + else { + if (result == O_WRONLY) + mode[ix++] = 'w'; else { - if (result == O_WRONLY) - mode[ix++] = 'w'; - else { - mode[ix++] = 'r'; - mode[ix++] = '+'; - } + mode[ix++] = 'r'; + mode[ix++] = '+'; } - if (rawmode & O_BINARY) - mode[ix++] = 'b'; - mode[ix] = '\0'; - fp = PerlIO_fdopen(fd, mode); - if (!fp) - PerlLIO_close(fd); } + if (rawmode & O_BINARY) + mode[ix++] = 'b'; + mode[ix] = '\0'; + + namesv = sv_2mortal(newSVpvn(name,strlen(name))); + num_svs = 1; + svp = &namesv; + fp = PerlIO_openn(aTHX_ S_layers(aTHX_ mode),mode, -1, rawmode, rawperm, saveifp, num_svs, svp); } else { /* Regular (non-sys) open */ @@ -206,7 +232,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (num_svs) { /* New style explict name, type is just mode and discipline/layer info */ STRLEN l; - name = SvPV(svs, l) ; + name = SvPV(*svp, l) ; len = (I32)l; name = savepvn(name, len); SAVEFREEPV(name); @@ -273,8 +299,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, mode[0] = IoTYPE(io) = IoTYPE_APPEND; type++; } - else + else { mode[0] = 'w'; + } writing = 1; if (out_raw) @@ -290,15 +317,17 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, dodup = 0; type++; } - if (!num_svs && !*type && supplied_fp) + if (!num_svs && !*type && supplied_fp) { /* "<+&" etc. is used by typemaps */ fp = supplied_fp; + } else { if (num_svs > 1) { Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); } - if (num_svs && SvIOK(*svp)) + if (num_svs && SvIOK(*svp)) { fd = SvUV(*svp); + } else if (isDIGIT(*type)) { /*SUPPRESS 530*/ for (; isSPACE(*type); type++) ; @@ -361,12 +390,14 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, fd = PerlLIO_dup(fd); else was_fdopen = TRUE; - if (!(fp = PerlIO_fdopen(fd,mode))) { + if (!num_svs) + type = S_layers(aTHX_ mode); + if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) { if (dodup) PerlLIO_close(fd); } } - } + } /* & */ else { if (num_svs > 1) { Perl_croak(aTHX_ "More than one argument to '>' open"); @@ -380,9 +411,15 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoTYPE(io) = IoTYPE_STD; } else { - fp = PerlIO_open((num_svs ? name : type), mode); + if (!num_svs) { + namesv = sv_2mortal(newSVpvn(type,strlen(type))); + num_svs = 1; + svp = &namesv; + type = S_layers(aTHX_ mode); + } + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,saveifp,num_svs,svp); } - } + } /* !& */ } else if (*type == IoTYPE_RDONLY) { if (num_svs > 1) { @@ -405,8 +442,15 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; } - else - fp = PerlIO_open((num_svs ? name : type), mode); + else { + if (!num_svs) { + namesv = sv_2mortal(newSVpvn(type,strlen(type))); + num_svs = 1; + svp = &namesv; + type = S_layers(aTHX_ mode); + } + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,saveifp,num_svs,svp); + } } else if ((num_svs && type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { @@ -462,7 +506,13 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoTYPE(io) = IoTYPE_STD; } else { - fp = PerlIO_open(name,mode); + if (!num_svs) { + namesv = sv_2mortal(newSVpvn(type,strlen(type))); + num_svs = 1; + svp = &namesv; + type = S_layers(aTHX_ mode); + } + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,saveifp,num_svs,svp); } } } @@ -478,7 +528,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, Perl_warner(aTHX_ WARN_IO, "'std%s' opened only for input", (fp == PerlIO_stdout()) ? "out" : "err"); } - else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdout()) { + else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { Perl_warner(aTHX_ WARN_IO, "'stdin' opened only for output"); } } @@ -514,17 +564,13 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR then dup the new fileno down */ - fd = PerlIO_fileno(saveifp); if (saveofp) { PerlIO_flush(saveofp); /* emulate PerlIO_close() */ if (saveofp != saveifp) { /* was a socket? */ PerlIO_close(saveofp); - /* This looks very suspect - NI-S 24 Nov 2000 */ - if (fd > 2) - Safefree(saveofp); /* ??? */ } } - if (fd != PerlIO_fileno(fp)) { + if (savefd != PerlIO_fileno(fp)) { Pid_t pid; SV *sv; @@ -549,7 +595,6 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, SvIVX(sv) = pid; if (!was_fdopen) PerlIO_close(fp); - } fp = saveifp; PerlIO_clearerr(fp); @@ -563,52 +608,17 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } #endif IoIFP(io) = fp; - if (!num_svs) { - /* Need to supply default type info from open.pm */ - SV *layers = PL_curcop->cop_io; - type = NULL; - if (layers) { - STRLEN len; - type = SvPV(layers,len); - if (type && mode[0] != 'r') { - /* Skip to write part */ - char *s = strchr(type,0); - if (s && (s-type) < len) { - type = s+1; - } - } - } - } - if (type) { - while (isSPACE(*type)) type++; - if (*type) { - errno = 0; - if (PerlIO_apply_layers(aTHX_ IoIFP(io),mode,type) != 0) { - goto say_false; - } - } - } IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { if (IoTYPE(io) == IoTYPE_SOCKET - || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) ) - { + || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) ) { mode[0] = 'w'; - if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) { + if (!(IoOFP(io) = PerlIO_openn(aTHX_ S_layers(aTHX_ mode),mode,PerlIO_fileno(fp),0,0,saveofp,num_svs,svp))) { PerlIO_close(fp); IoIFP(io) = Nullfp; goto say_false; } - if (type && *type) { - if (PerlIO_apply_layers(aTHX_ IoOFP(io),mode,type) != 0) { - PerlIO_close(IoOFP(io)); - PerlIO_close(fp); - IoIFP(io) = Nullfp; - IoOFP(io) = Nullfp; - goto say_false; - } - } } else IoOFP(io) = fp; diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index 4d62501..5d33303 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -301,9 +301,7 @@ PerlIO_funcs PerlIO_encode = { sizeof(PerlIOEncode), PERLIO_K_BUFFERED, PerlIOBase_fileno, - PerlIOBuf_fdopen, PerlIOBuf_open, - PerlIOBuf_reopen, PerlIOEncode_pushed, PerlIOEncode_popped, PerlIOBuf_read, diff --git a/perlio.c b/perlio.c index 132fe47..d192892 100644 --- a/perlio.c +++ b/perlio.c @@ -99,6 +99,36 @@ PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) return perlsio_binmode(fp,iotype,mode); } +/* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */ + +PerlIO * +PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args) +{ + if (narg == 1) + { + char *name = SvPV_nolen(*args); + if (*mode == '#') + { + fd = PerlLIO_open3(name,imode,perm); + if (fd >= 0) + return PerlIO_fdopen(fd,mode+1); + } + else if (old) + { + return PerlIO_reopen(name,mode,old); + } + else + { + return PerlIO_open(name,mode); + } + } + else + { + return PerlIO_fdopen(fd,mode); + } + return NULL; +} + #endif @@ -765,44 +795,47 @@ PerlIO_fileno(PerlIO *f) return (*PerlIOBase(f)->tab->Fileno)(f); } +PerlIO_funcs * +PerlIO_top_layer(pTHX_ const char *layers) +{ + /* FIXME !!! */ + return PerlIO_default_top(); +} + +PerlIO * +PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) +{ + PerlIO_funcs *tab = (f && *f) ? PerlIOBase(f)->tab : PerlIO_top_layer(aTHX_ layers); + if (!_perlio) + PerlIO_stdstreams(); + return (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,f,narg,args); +} #undef PerlIO_fdopen PerlIO * PerlIO_fdopen(int fd, const char *mode) { - PerlIO_funcs *tab = PerlIO_default_top(); - if (!_perlio) - PerlIO_stdstreams(); - return (*tab->Fdopen)(tab,fd,mode); + dTHX; + return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL); } #undef PerlIO_open PerlIO * PerlIO_open(const char *path, const char *mode) { - PerlIO_funcs *tab = PerlIO_default_top(); - if (!_perlio) - PerlIO_stdstreams(); - return (*tab->Open)(tab,path,mode); + dTHX; + SV *name = sv_2mortal(newSVpvn(path,strlen(path))); + return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name); } #undef PerlIO_reopen PerlIO * PerlIO_reopen(const char *path, const char *mode, PerlIO *f) { - if (f) - { - PerlIO_flush(f); - if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0) - { - if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0) - return f; - } - return NULL; - } - else - return PerlIO_open(path,mode); + dTHX; + SV *name = sv_2mortal(newSVpvn(path,strlen(path))); + return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name); } #undef PerlIO_read @@ -1041,10 +1074,10 @@ PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) } PerlIO * -PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode) +PerlIOUtf8_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args) { PerlIO_funcs *tab = PerlIO_default_layer(-2); - PerlIO *f = (*tab->Fdopen)(tab,fd,mode); + PerlIO *f = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,old,narg,args); if (f) { PerlIOl *l = PerlIOBase(f); @@ -1056,30 +1089,12 @@ PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode) return f; } -PerlIO * -PerlIOUtf8_open(PerlIO_funcs *self, const char *path,const char *mode) -{ - PerlIO_funcs *tab = PerlIO_default_layer(-2); - PerlIO *f = (*tab->Open)(tab,path,mode); - if (f) - { - PerlIOl *l = PerlIOBase(f); - if (tab->kind & PERLIO_K_UTF8) - l->flags |= PERLIO_F_UTF8; - else - l->flags &= ~PERLIO_F_UTF8; - } - return f; -} - PerlIO_funcs PerlIO_utf8 = { "utf8", sizeof(PerlIOl), PERLIO_K_DUMMY|PERLIO_F_UTF8, NULL, - PerlIOUtf8_fdopen, PerlIOUtf8_open, - NULL, PerlIOUtf8_pushed, NULL, NULL, @@ -1106,9 +1121,7 @@ PerlIO_funcs PerlIO_byte = { sizeof(PerlIOl), PERLIO_K_DUMMY, NULL, - PerlIOUtf8_fdopen, PerlIOUtf8_open, - NULL, PerlIOUtf8_pushed, NULL, NULL, @@ -1131,17 +1144,10 @@ PerlIO_funcs PerlIO_byte = { }; PerlIO * -PerlIORaw_fdopen(PerlIO_funcs *self, int fd,const char *mode) -{ - PerlIO_funcs *tab = PerlIO_default_btm(); - return (*tab->Fdopen)(tab,fd,mode); -} - -PerlIO * -PerlIORaw_open(PerlIO_funcs *self, const char *path,const char *mode) +PerlIORaw_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args) { PerlIO_funcs *tab = PerlIO_default_btm(); - return (*tab->Open)(tab,path,mode); + return (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,old,narg,args); } PerlIO_funcs PerlIO_raw = { @@ -1149,9 +1155,7 @@ PerlIO_funcs PerlIO_raw = { sizeof(PerlIOl), PERLIO_K_DUMMY, NULL, - PerlIORaw_fdopen, PerlIORaw_open, - NULL, PerlIORaw_pushed, PerlIOBase_popped, NULL, @@ -1470,45 +1474,53 @@ PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode) } PerlIO * -PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode) +PerlIOUnix_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { - dTHX; - PerlIO *f = NULL; - int oflags = PerlIOUnix_oflags(mode); - if (oflags != -1) + if (f) { - int fd = PerlLIO_open3(path,oflags,0666); - if (fd >= 0) + if (PerlIOBase(f)->flags & PERLIO_F_OPEN) + (*PerlIOBase(f)->tab->Close)(f); + } + if (narg > 0) + { + char *path = SvPV_nolen(*args); + if (*mode == '#') + mode++; + else { - PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix); - s->fd = fd; - s->oflags = oflags; - PerlIOBase(f)->flags |= PERLIO_F_OPEN; + imode = PerlIOUnix_oflags(mode); + perm = 0666; + } + if (imode != -1) + { + fd = PerlLIO_open3(path,imode,perm); } } - return f; -} - -int -PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f) -{ - PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix); - int oflags = PerlIOUnix_oflags(mode); - if (PerlIOBase(f)->flags & PERLIO_F_OPEN) - (*PerlIOBase(f)->tab->Close)(f); - if (oflags != -1) + if (fd >= 0) { - dTHX; - int fd = PerlLIO_open3(path,oflags,0666); - if (fd >= 0) + PerlIOUnix *s; + if (*mode == 'I') + mode++; + if (!f) { - s->fd = fd; - s->oflags = oflags; - PerlIOBase(f)->flags |= PERLIO_F_OPEN; - return 0; + f = PerlIO_allocate(aTHX); + s = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOUnix); } + else + s = PerlIOSelf(f,PerlIOUnix); + s->fd = fd; + s->oflags = imode; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + return f; + } + else + { + if (f) + { + /* FIXME: pop layers ??? */ + } + return NULL; } - return -1; } SSize_t @@ -1595,9 +1607,7 @@ PerlIO_funcs PerlIO_unix = { sizeof(PerlIOUnix), PERLIO_K_RAW, PerlIOUnix_fileno, - PerlIOUnix_fdopen, PerlIOUnix_open, - PerlIOUnix_reopen, PerlIOUnix_pushed, PerlIOBase_noop_ok, PerlIOUnix_read, @@ -1658,40 +1668,6 @@ PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode) PerlIO *f = NULL; int init = 0; char tmode[8]; - if (*mode == 'I') - { - init = 1; - mode++; - } - if (fd >= 0) - { - FILE *stdio = NULL; - if (init) - { - switch(fd) - { - case 0: - stdio = PerlSIO_stdin; - break; - case 1: - stdio = PerlSIO_stdout; - break; - case 2: - stdio = PerlSIO_stderr; - break; - } - } - else - { - stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode)); - } - if (stdio) - { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio); - s->stdio = stdio; - } - } - return f; } /* This isn't used yet ... */ @@ -1727,33 +1703,79 @@ PerlIO_importFILE(FILE *stdio, int fl) } PerlIO * -PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode) +PerlIOStdio_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { - dTHX; - PerlIO *f = NULL; - FILE *stdio = PerlSIO_fopen(path,mode); - if (stdio) + char tmode[8]; + if (f) { - char tmode[8]; - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self, - (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0), - PerlIOStdio); - s->stdio = stdio; + char *path = SvPV_nolen(*args); + PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio); + FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio); + if (!s->stdio) + return NULL; + s->stdio = stdio; + return f; } - return f; -} - -int -PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f) -{ - dTHX; - PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio); - char tmode[8]; - FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio); - if (!s->stdio) - return -1; - s->stdio = stdio; - return 0; + else + { + if (narg > 0) + { + char *path = SvPV_nolen(*args); + if (*mode == '#') + { + mode++; + fd = PerlLIO_open3(path,imode,perm); + } + else + { + FILE *stdio = PerlSIO_fopen(path,mode); + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self, + (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0), + PerlIOStdio); + s->stdio = stdio; + } + return f; + } + } + if (fd >= 0) + { + FILE *stdio = NULL; + int init = 0; + if (*mode == 'I') + { + init = 1; + mode++; + } + if (init) + { + switch(fd) + { + case 0: + stdio = PerlSIO_stdin; + break; + case 1: + stdio = PerlSIO_stdout; + break; + case 2: + stdio = PerlSIO_stderr; + break; + } + } + else + { + stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode)); + } + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio); + s->stdio = stdio; + return f; + } + } + } + return NULL; } SSize_t @@ -1995,9 +2017,7 @@ PerlIO_funcs PerlIO_stdio = { sizeof(PerlIOStdio), PERLIO_K_BUFFERED, PerlIOStdio_fileno, - PerlIOStdio_fdopen, PerlIOStdio_open, - PerlIOStdio_reopen, PerlIOBase_pushed, PerlIOBase_noop_ok, PerlIOStdio_read, @@ -2094,60 +2114,46 @@ PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) } PerlIO * -PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode) +PerlIOBuf_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { - dTHX; - PerlIO_funcs *tab = PerlIO_default_btm(); - int init = 0; - PerlIO *f; - if (*mode == 'I') - { - init = 1; - mode++; - } -#if O_BINARY != O_TEXT - /* do something about failing setmode()? --jhi */ - PerlLIO_setmode(fd, O_BINARY); -#endif - f = (*tab->Fdopen)(tab,fd,mode); if (f) { - PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf); - if (init && fd == 2) + PerlIO *next = PerlIONext(f); + PerlIO_funcs *tab = PerlIOBase(next)->tab; + next = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,next,narg,args); + if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) != 0) { - /* Initial stderr is unbuffered */ - PerlIOBase(f)->flags |= PERLIO_F_UNBUF; + return NULL; } -#if 0 - PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n", - self->name,f,fd,mode,PerlIOBase(f)->flags); -#endif } - return f; -} - -PerlIO * -PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode) -{ - PerlIO_funcs *tab = PerlIO_default_btm(); - PerlIO *f = (*tab->Open)(tab,path,mode); - if (f) + else { - PerlIO_push(f,self,mode,Nullch,0); + PerlIO_funcs *tab = PerlIO_default_btm(); + int init = 0; + if (*mode == 'I') + { + init = 1; + mode++; + } + f = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,NULL,narg,args); + if (f) + { + PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf); + fd = PerlIO_fileno(f); +#if O_BINARY != O_TEXT + /* do something about failing setmode()? --jhi */ + PerlLIO_setmode(fd , O_BINARY); +#endif + if (init && fd == 2) + { + /* Initial stderr is unbuffered */ + PerlIOBase(f)->flags |= PERLIO_F_UNBUF; + } + } } return f; } -int -PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f) -{ - PerlIO *next = PerlIONext(f); - int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next); - if (code = 0) - code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0); - return code; -} - /* This "flush" is akin to sfio's sync in that it handles files in either read or write state */ @@ -2518,9 +2524,7 @@ PerlIO_funcs PerlIO_perlio = { sizeof(PerlIOBuf), PERLIO_K_BUFFERED, PerlIOBase_fileno, - PerlIOBuf_fdopen, PerlIOBuf_open, - PerlIOBuf_reopen, PerlIOBuf_pushed, PerlIOBase_noop_ok, PerlIOBuf_read, @@ -2636,8 +2640,6 @@ PerlIO_funcs PerlIO_pending = { PERLIO_K_BUFFERED, PerlIOBase_fileno, NULL, - NULL, - NULL, PerlIOPending_pushed, PerlIOBase_noop_ok, PerlIOPending_read, @@ -2942,9 +2944,7 @@ PerlIO_funcs PerlIO_crlf = { sizeof(PerlIOCrlf), PERLIO_K_BUFFERED|PERLIO_K_CANCRLF, PerlIOBase_fileno, - PerlIOBuf_fdopen, PerlIOBuf_open, - PerlIOBuf_reopen, PerlIOCrlf_pushed, PerlIOBase_noop_ok, /* popped */ PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */ @@ -3248,9 +3248,7 @@ PerlIO_funcs PerlIO_mmap = { sizeof(PerlIOMmap), PERLIO_K_BUFFERED, PerlIOBase_fileno, - PerlIOBuf_fdopen, PerlIOBuf_open, - PerlIOBuf_reopen, PerlIOBuf_pushed, PerlIOBase_noop_ok, PerlIOBuf_read, diff --git a/perlio.h b/perlio.h index b144b24..4efdae3 100644 --- a/perlio.h +++ b/perlio.h @@ -189,6 +189,9 @@ extern int PerlIO_puts (PerlIO *,const char *); #ifndef PerlIO_open extern PerlIO * PerlIO_open (const char *,const char *); #endif +#ifndef PerlIO_open +extern PerlIO * PerlIO_openn (pTHX_ const char *layers, const char *mode,int fd,int imode,int perm,PerlIO *old,int narg,SV **arg); +#endif #ifndef PerlIO_close extern int PerlIO_close (PerlIO *); #endif diff --git a/perliol.h b/perliol.h index 6d4485a..d97df31 100644 --- a/perliol.h +++ b/perliol.h @@ -7,9 +7,7 @@ struct _PerlIO_funcs Size_t size; IV kind; IV (*Fileno)(PerlIO *f); - PerlIO * (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode); - PerlIO * (*Open)(PerlIO_funcs *tab, const char *path, const char *mode); - int (*Reopen)(const char *path, const char *mode, PerlIO *f); + PerlIO * (*Open)(pTHX_ PerlIO_funcs *tab, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args); IV (*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len); IV (*Popped)(PerlIO *f); /* Unix-like functions - cf sfio line disciplines */ @@ -131,9 +129,7 @@ typedef struct IV oneword; /* Emergency buffer */ } PerlIOBuf; -extern PerlIO * PerlIOBuf_fdopen (PerlIO_funcs *self, int fd, const char *mode); -extern PerlIO * PerlIOBuf_open (PerlIO_funcs *self, const char *path, const char *mode); -extern int PerlIOBuf_reopen (const char *path, const char *mode, PerlIO *f); +extern PerlIO * PerlIOBuf_open (pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args); 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);