diff options
author | Jarkko Hietaniemi <jhi@iki.fi> | 2001-03-23 23:40:46 +0000 |
---|---|---|
committer | Jarkko Hietaniemi <jhi@iki.fi> | 2001-03-23 23:40:46 +0000 |
commit | 7bcb86fce1726fff66ae6da62ba3693682090cc3 (patch) | |
tree | 9ba05eadcb380d123a474addd89da8aa7292c992 | |
parent | 8c42d64c72b04c0d79b458c20e8c631336338ac5 (diff) | |
parent | e3f3bf95bcb81efe35cb0f0d3e3528d5c002dcec (diff) | |
download | perl-7bcb86fce1726fff66ae6da62ba3693682090cc3.tar.gz |
Integrate perlio:
[ 9314]
Perlio internals re-organized.
- open process creates AV of layer/arg pairs
(appends layers from open() or open.pm to default list).
- push arg is now an SV.
- layer ->Open get passed the AV
- open is no longer mandatory method.
- topmost layer that has ->Open method does the open
- any layers above are pushed once that returns.
- vtable re-ordered so dummy layers need only provide push/pop methods.
[ 9313]
Check in a stable (working) version before next round of tweaks.
Changes include:
- Move default layers code out of doio.c and into perlio.c
- Single routine for parsing layer specification strings.
- Skeleton support for demand loading of layers
- Core-dump avoidance if PERLIO environment specifies loadable layer
(does not _work_ as need IO to load and need load to do IO ...)
[ 9305]
Add pTHX_ to -Duseperlio API where it does not conflict with legacy stuff.
[ 9304]
Render -Duseperlio functional again.
- this is "quick fix" which calls PerlIO_apply_layers after opening,
which is what old scheme did. New scheme needs to change that
to make open(...,\$scalar) etc. work but this will do for now.
[ 9303]
Avoid "reopen" semantics for time being. Fix bug in dup logic.
-Uuseperlio now works again.
-Duseperlio is still poorly. Don't merge yet...
[ 9302]
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-link: @9314 on //depot/perlio: e3f3bf95bcb81efe35cb0f0d3e3528d5c002dcec
p4raw-link: @9313 on //depot/perlio: 1141d9f89ca1cb89e46951e8afc784c7b4862cd2
p4raw-link: @9305 on //depot/perlio: a999f61be32148694ba1c2837b1a303e42fd96b1
p4raw-link: @9304 on //depot/perlio: 5e334b7bcf49bf053aa25da896a1ff98c12dd228
p4raw-link: @9303 on //depot/perlio: 6e60e805618a52942747f76233ecc85135a964e3
p4raw-link: @9302 on //depot/perlio: ee518936bd3eee0065c20591f5182f733dadd4bd
p4raw-id: //depot/perl@9316
-rw-r--r-- | MANIFEST | 1 | ||||
-rw-r--r-- | doio.c | 181 | ||||
-rw-r--r-- | ext/Encode/Encode.xs | 42 | ||||
-rw-r--r-- | lib/PerlIO.pm | 26 | ||||
-rw-r--r-- | perlio.c | 999 | ||||
-rw-r--r-- | perlio.h | 11 | ||||
-rw-r--r-- | perliol.h | 21 |
7 files changed, 720 insertions, 561 deletions
@@ -741,6 +741,7 @@ lib/Net/hostent.pm By-name interface to Perl's builtin gethost* lib/Net/netent.pm By-name interface to Perl's builtin getnet* lib/Net/protoent.pm By-name interface to Perl's builtin getproto* lib/Net/servent.pm By-name interface to Perl's builtin getserv* +lib/PerlIO.pm PerlIO support module lib/Pod/Checker.pm Pod-Parser - check POD documents for syntax errors lib/Pod/Find.pm used by pod/splitpod lib/Pod/Functions.pm used by pod/splitpod @@ -76,6 +76,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 +85,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 +104,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 +128,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 +165,35 @@ 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; + type = Nullch; + fp = PerlIO_openn(aTHX_ type,mode, -1, rawmode, rawperm, NULL, num_svs, svp); } else { /* Regular (non-sys) open */ @@ -206,7 +211,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 +278,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 +296,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 +369,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 = Nullch; + 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 +390,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 = Nullch; + } + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } - } + } /* !& */ } else if (*type == IoTYPE_RDONLY) { if (num_svs > 1) { @@ -405,8 +421,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 = Nullch; + } + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,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 +485,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 = Nullch; + } + fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } } } @@ -478,7 +507,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,42 +543,37 @@ 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); + fd = PerlIO_fileno(fp); 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 != fd) { Pid_t pid; SV *sv; - - PerlLIO_dup2(PerlIO_fileno(fp), fd); + PerlLIO_dup2(fd, savefd); #ifdef VMS - if (fd != PerlIO_fileno(PerlIO_stdin())) { + if (savefd != PerlIO_fileno(PerlIO_stdin())) { char newname[FILENAME_MAX+1]; if (fgetname(fp, newname)) { - if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname); - if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR", newname); + if (savefd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname); + if (savefd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR", newname); } } #endif LOCK_FDPID_MUTEX; - sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); + sv = *av_fetch(PL_fdpid,fd,TRUE); (void)SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); SvIVX(sv) = 0; - sv = *av_fetch(PL_fdpid,fd,TRUE); + sv = *av_fetch(PL_fdpid,savefd,TRUE); UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; if (!was_fdopen) PerlIO_close(fp); - } fp = saveifp; PerlIO_clearerr(fp); @@ -563,52 +587,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_ type,mode,PerlIO_fileno(fp),0,0,NULL,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 4d62501775..fea83aec4a 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -48,19 +48,41 @@ typedef struct SV * enc; } PerlIOEncode; +SV * +PerlIOEncode_getarg(PerlIO *f) +{ + PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); + SV *sv = &PL_sv_undef; + if (e->enc) + { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + XPUSHs(e->enc); + PUTBACK; + if (perl_call_method("name",G_SCALAR) == 1) + { + SPAGAIN; + sv = newSVsv(POPs); + PUTBACK; + } + } + return sv; +} IV -PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) +PerlIOEncode_pushed(PerlIO *f, const char *mode, SV *arg) { PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode); dTHX; dSP; IV code; - code = PerlIOBuf_pushed(f,mode,Nullch,0); + code = PerlIOBuf_pushed(f,mode,Nullsv); ENTER; SAVETMPS; PUSHMARK(sp); - XPUSHs(sv_2mortal(newSVpvn(arg,len))); + XPUSHs(arg); PUTBACK; if (perl_call_pv("Encode::find_encoding",G_SCALAR) != 1) { @@ -75,7 +97,7 @@ PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) { e->enc = Nullsv; errno = EINVAL; - Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%.*s\"", (int) len, arg); + Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%_\"", arg); return -1; } SvREFCNT_inc(e->enc); @@ -267,6 +289,7 @@ PerlIOEncode_close(PerlIO *f) Off_t PerlIOEncode_tell(PerlIO *f) { + dTHX; PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); /* Unfortunately the only way to get a postion is to back-translate, the UTF8-bytes we have buf..ptr and adjust accordingly. @@ -276,7 +299,7 @@ PerlIOEncode_tell(PerlIO *f) if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF) && b->ptr < b->end) { Size_t count = b->end - b->ptr; - PerlIO_push(f,&PerlIO_pending,"r",Nullch,0); + PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv); /* Save what we have left to read */ PerlIOSelf(f,PerlIOBuf)->bufsiz = count; PerlIO_unread(f,b->ptr,count); @@ -300,12 +323,11 @@ PerlIO_funcs PerlIO_encode = { "encoding", sizeof(PerlIOEncode), PERLIO_K_BUFFERED, - PerlIOBase_fileno, - PerlIOBuf_fdopen, - PerlIOBuf_open, - PerlIOBuf_reopen, PerlIOEncode_pushed, PerlIOEncode_popped, + PerlIOBuf_open, + PerlIOEncode_getarg, + PerlIOBase_fileno, PerlIOBuf_read, PerlIOBuf_unread, PerlIOBuf_write, @@ -609,7 +631,7 @@ _utf8_off(sv) BOOT: { #if defined(USE_PERLIO) && !defined(USE_SFIO) - PerlIO_define_layer(&PerlIO_encode); + PerlIO_define_layer(aTHX_ &PerlIO_encode); #endif #include "iso8859.def" #include "EBCDIC.def" diff --git a/lib/PerlIO.pm b/lib/PerlIO.pm new file mode 100644 index 0000000000..c5ce016db4 --- /dev/null +++ b/lib/PerlIO.pm @@ -0,0 +1,26 @@ +package PerlIO; + +# Map layer name to package that defines it +my %alias = (encoding => 'Encode'); + +sub import +{ + my $class = shift; + while (@_) + { + my $layer = shift; + if (exists $alias{$layer}) + { + $layer = $alias{$layer} + } + else + { + $layer = "${class}::$layer"; + } + eval "require $layer"; + warn $@ if $@; + } +} + +1; +__END__ @@ -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 @@ -216,6 +246,8 @@ PerlIO_debug(const char *fmt,...) PerlIO *_perlio = NULL; #define PERLIO_TABLE_SIZE 64 + + PerlIO * PerlIO_allocate(pTHX) { @@ -276,9 +308,8 @@ PerlIO_cleanup() } void -PerlIO_pop(PerlIO *f) +PerlIO_pop(pTHX_ PerlIO *f) { - dTHX; PerlIOl *l = *f; if (l) { @@ -314,16 +345,29 @@ XS(XS_perlio_unimport) } SV * -PerlIO_find_layer(const char *name, STRLEN len) +PerlIO_find_layer(pTHX_ const char *name, STRLEN len) { - dTHX; SV **svp; SV *sv; if ((SSize_t) len <= 0) len = strlen(name); svp = hv_fetch(PerlIO_layer_hv,name,len,0); - if (svp && (sv = *svp) && SvROK(sv)) - return *svp; + if (!svp && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2) + { + SV *pkgsv = newSVpvn("PerlIO",6); + SV *layer = newSVpvn(name,len); + ENTER; + /* The two SVs are magically freed by load_module */ + Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv); + LEAVE; + /* Say this is lvalue so we get an 'undef' if still not there */ + svp = hv_fetch(PerlIO_layer_hv,name,len,1); + } + if (svp && (sv = *svp)) + { + if (SvROK(sv)) + return *svp; + } return NULL; } @@ -396,7 +440,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) { STRLEN len; const char *name = SvPV(ST(i),len); - SV *layer = PerlIO_find_layer(name,len); + SV *layer = PerlIO_find_layer(aTHX_ name,len); if (layer) { av_push(av,SvREFCNT_inc(layer)); @@ -411,22 +455,110 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) XSRETURN(count); } -void -PerlIO_define_layer(PerlIO_funcs *tab) +SV * +PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) { - dTHX; HV *stash = gv_stashpv("perlio::Layer", TRUE); SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash); + return sv; +} + +void +PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) +{ if (!PerlIO_layer_hv) { PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI); } - hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0); + hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0); PerlIO_debug("define %s %p\n",tab->name,tab); } +int +PerlIO_parse_layers(pTHX_ AV *av, const char *names) +{ + if (names) + { + const char *s = names; + while (*s) + { + while (isSPACE(*s) || *s == ':') + s++; + if (*s) + { + STRLEN llen = 0; + const char *e = s; + const char *as = Nullch; + STRLEN alen = 0; + if (!isIDFIRST(*s)) + { + /* Message is consistent with how attribute lists are passed. + Even though this means "foo : : bar" is seen as an invalid separator + character. */ + char q = ((*s == '\'') ? '"' : '\''); + Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q); + return -1; + } + do + { + e++; + } while (isALNUM(*e)); + llen = e-s; + if (*e == '(') + { + int nesting = 1; + as = ++e; + while (nesting) + { + switch (*e++) + { + case ')': + if (--nesting == 0) + alen = (e-1)-as; + break; + case '(': + ++nesting; + break; + case '\\': + /* It's a nul terminated string, not allowed to \ the terminating null. + Anything other character is passed over. */ + if (*e++) + { + break; + } + /* Drop through */ + case '\0': + e--; + Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s); + return -1; + default: + /* boring. */ + break; + } + } + } + if (e > s) + { + SV *layer = PerlIO_find_layer(aTHX_ s,llen); + if (layer) + { + av_push(av,SvREFCNT_inc(layer)); + av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef); + } + else { + Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s); + return -1; + } + } + s = e; + } + } + } + return 0; +} + void -PerlIO_default_buffer(pTHX) +PerlIO_default_buffer(pTHX_ AV *av) { PerlIO_funcs *tab = &PerlIO_perlio; if (O_BINARY != O_TEXT) @@ -441,99 +573,97 @@ PerlIO_default_buffer(pTHX) } } PerlIO_debug("Pushing %s\n",tab->name); - av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(tab->name,0))); + av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0))); + av_push(av,&PL_sv_undef); +} + +SV * +PerlIO_arg_fetch(pTHX_ AV *av,IV n) +{ + SV **svp = av_fetch(av,n,FALSE); + return (svp) ? *svp : Nullsv; } +#define MYARG PerlIO_arg_fetch(aTHX_ layers,n+1) + PerlIO_funcs * -PerlIO_default_layer(I32 n) +PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def) { - dTHX; - SV **svp; + SV **svp = av_fetch(av,n,FALSE); SV *layer; - PerlIO_funcs *tab = &PerlIO_stdio; - int len; + if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer)))) + { + /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */ + return INT2PTR(PerlIO_funcs *, SvIV(layer)); + } + if (!def) + Perl_croak(aTHX_ "panic:layer array corrupt"); + return def; +} + +AV * +PerlIO_default_layers(pTHX) +{ + IV len; if (!PerlIO_layer_av) { - const char *s = PerlEnv_getenv("PERLIO"); + const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO"); PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI); newXS("perlio::import",XS_perlio_import,__FILE__); newXS("perlio::unimport",XS_perlio_unimport,__FILE__); #if 0 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__); #endif - PerlIO_define_layer(&PerlIO_raw); - PerlIO_define_layer(&PerlIO_unix); - PerlIO_define_layer(&PerlIO_perlio); - PerlIO_define_layer(&PerlIO_stdio); - PerlIO_define_layer(&PerlIO_crlf); + PerlIO_define_layer(aTHX_ &PerlIO_raw); + PerlIO_define_layer(aTHX_ &PerlIO_unix); + PerlIO_define_layer(aTHX_ &PerlIO_perlio); + PerlIO_define_layer(aTHX_ &PerlIO_stdio); + PerlIO_define_layer(aTHX_ &PerlIO_crlf); #ifdef HAS_MMAP - PerlIO_define_layer(&PerlIO_mmap); + PerlIO_define_layer(aTHX_ &PerlIO_mmap); #endif - PerlIO_define_layer(&PerlIO_utf8); - PerlIO_define_layer(&PerlIO_byte); - av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0))); + PerlIO_define_layer(aTHX_ &PerlIO_utf8); + PerlIO_define_layer(aTHX_ &PerlIO_byte); + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0))); + av_push(PerlIO_layer_av,&PL_sv_undef); if (s) { - IV buffered = 0; - while (*s) - { - while (*s && isSPACE((unsigned char)*s)) - s++; - if (*s) - { - const char *e = s; - SV *layer; - while (*e && !isSPACE((unsigned char)*e)) - e++; - if (*s == ':') - s++; - layer = PerlIO_find_layer(s,e-s); - if (layer) - { - PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); - if ((tab->kind & PERLIO_K_DUMMY) && (tab->kind & PERLIO_K_BUFFERED)) - { - if (!buffered) - PerlIO_default_buffer(aTHX); - } - PerlIO_debug("Pushing %.*s\n",(e-s),s); - av_push(PerlIO_layer_av,SvREFCNT_inc(layer)); - buffered |= (tab->kind & PERLIO_K_BUFFERED); - } - else - Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s); - s = e; - } - } + PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s); + } + else + { + PerlIO_default_buffer(aTHX_ PerlIO_layer_av); } } - len = av_len(PerlIO_layer_av); - if (len < 1) + len = av_len(PerlIO_layer_av)+1; + if (len < 2) { - PerlIO_default_buffer(aTHX); + PerlIO_default_buffer(aTHX_ PerlIO_layer_av); len = av_len(PerlIO_layer_av); } + return PerlIO_layer_av; +} + + +PerlIO_funcs * +PerlIO_default_layer(pTHX_ I32 n) +{ + AV *av = PerlIO_default_layers(aTHX); + n *= 2; if (n < 0) - n += len+1; - svp = av_fetch(PerlIO_layer_av,n,0); - if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer)))) - { - tab = INT2PTR(PerlIO_funcs *, SvIV(layer)); - } - /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */ - return tab; + n += av_len(PerlIO_layer_av)+1; + return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio); } -#define PerlIO_default_top() PerlIO_default_layer(-1) -#define PerlIO_default_btm() PerlIO_default_layer(0) +#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1) +#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0) void -PerlIO_stdstreams() +PerlIO_stdstreams(pTHX) { if (!_perlio) { - dTHX; PerlIO_allocate(aTHX); PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT); PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT); @@ -542,9 +672,8 @@ PerlIO_stdstreams() } PerlIO * -PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len) +PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg) { - dTHX; PerlIOl *l = NULL; l = PerlMemShared_calloc(tab->size,sizeof(char)); if (l) @@ -553,11 +682,11 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN l->next = *f; l->tab = tab; *f = l; - PerlIO_debug("PerlIO_push f=%p %s %s '%.*s'\n", - f,tab->name,(mode) ? mode : "(Null)",(int) len,arg); - if ((*l->tab->Pushed)(f,mode,arg,len) != 0) + PerlIO_debug("PerlIO_push f=%p %s %s '%s'\n",f,tab->name, + (mode) ? mode : "(Null)",(arg) ? SvPV_nolen(arg) : "(Null)"); + if ((*l->tab->Pushed)(f,mode,arg) != 0) { - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); return NULL; } } @@ -565,23 +694,25 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN } IV -PerlIOPop_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg) { - PerlIO_pop(f); + dTHX; + PerlIO_pop(aTHX_ f); if (*f) { PerlIO_flush(f); - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); return 0; } return -1; } IV -PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg) { /* Remove the dummy layer */ - PerlIO_pop(f); + dTHX; + PerlIO_pop(aTHX_ f); /* Pop back to bottom layer */ if (f && *f) { @@ -591,14 +722,14 @@ PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) { if (*PerlIONext(f)) { - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); } else { /* Nothing bellow - push unix on top then remove it */ - if (PerlIO_push(f,PerlIO_default_btm(),mode,arg,len)) + if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg)) { - PerlIO_pop(PerlIONext(f)); + PerlIO_pop(aTHX_ PerlIONext(f)); } break; } @@ -610,92 +741,42 @@ PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) } int -PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n) { - if (names) + IV max = av_len(layers)+1; + int code = 0; + while (n < max) { - const char *s = names; - while (*s) + PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL); + if (tab) { - while (isSPACE(*s) || *s == ':') - s++; - if (*s) + if (!PerlIO_push(aTHX_ f,tab,mode,MYARG)) { - STRLEN llen = 0; - const char *e = s; - const char *as = Nullch; - STRLEN alen = 0; - if (!isIDFIRST(*s)) - { - /* Message is consistent with how attribute lists are passed. - Even though this means "foo : : bar" is seen as an invalid separator - character. */ - char q = ((*s == '\'') ? '"' : '\''); - Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q); - return -1; - } - do - { - e++; - } while (isALNUM(*e)); - llen = e-s; - if (*e == '(') - { - int nesting = 1; - as = ++e; - while (nesting) - { - switch (*e++) - { - case ')': - if (--nesting == 0) - alen = (e-1)-as; - break; - case '(': - ++nesting; - break; - case '\\': - /* It's a nul terminated string, not allowed to \ the terminating null. - Anything other character is passed over. */ - if (*e++) - { - break; - } - /* Drop through */ - case '\0': - e--; - Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s); - return -1; - default: - /* boring. */ - break; - } - } - } - if (e > s) - { - SV *layer = PerlIO_find_layer(s,llen); - if (layer) - { - PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); - if (tab) - { - if (!PerlIO_push(f,tab,mode,as,alen)) - return -1; - } - } - else { - Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s); - return -1; - } - } - s = e; + code -1; + break; } } + n += 2; } - return 0; + return code; } +int +PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +{ + int code = 0; + if (names) + { + AV *layers = newAV(); + code = PerlIO_parse_layers(aTHX_ layers,names); + if (code == 0) + { + code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0); + } + SvREFCNT_dec((SV *) layers); + } + return code; +} /*--------------------------------------------------------------------------------------*/ @@ -750,10 +831,11 @@ PerlIO_fdupopen(pTHX_ PerlIO *f) int PerlIO_close(PerlIO *f) { + dTHX; int code = (*PerlIOBase(f)->tab->Close)(f); while (*f) { - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); } return code; } @@ -765,44 +847,139 @@ PerlIO_fileno(PerlIO *f) return (*PerlIOBase(f)->tab->Fileno)(f); } +static const char * +PerlIO_context_layers(pTHX_ const char *mode) +{ + const char *type = NULL; + /* Need to supply default layer info from open.pm */ + if (PL_curcop) + { + SV *layers = PL_curcop->cop_io; + if (layers) + { + STRLEN len; + type = SvPV(layers,len); + if (type && mode[0] != 'r') + { + /* Skip to write part */ + const char *s = strchr(type,0); + if (s && (s-type) < len) + { + type = s+1; + } + } + } + } + return type; +} + +AV * +PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args) +{ + AV *def = PerlIO_default_layers(aTHX); + if (!_perlio) + PerlIO_stdstreams(aTHX); + /* FIXME !!! */ + if (!layers) + layers = PerlIO_context_layers(aTHX_ mode); + if (layers && *layers) + { + AV *av = newAV(); + IV n = av_len(def)+1; + while (n-- > 0) + { + SV **svp = av_fetch(def,n,0); + av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef); + } + PerlIO_parse_layers(aTHX_ av,layers); + return av; + } + else + { + SvREFCNT_inc(def); + return def; + } +} + +PerlIO * +PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) +{ + AV *layera; + IV n; + PerlIO_funcs *tab; + if (f && *f) + { + PerlIOl *l = *f; + layera = newAV(); + while (l) + { + SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef; + av_unshift(layera,2); + av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab)); + av_store(layera,1,arg); + l = *PerlIONext(&l); + } + } + else + { + layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); + } + n = av_len(layera)-1; + while (n >= 0) + { + PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL); + if (t && t->Open) + { + tab = t; + break; + } + n -= 2; + } + if (tab) + { + PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", + tab->name,layers,mode,fd,imode,perm,f,narg,args); + f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args); + if (f) + { + if (n+2 < av_len(layera)+1) + { + if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0) + { + f = NULL; + } + } + } + } + SvREFCNT_dec(layera); + return f; +} #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 @@ -1025,12 +1202,13 @@ PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) /* utf8 and raw dummy layers */ IV -PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg) { if (PerlIONext(f)) { + dTHX; PerlIO_funcs *tab = PerlIOBase(f)->tab; - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); if (tab->kind & PERLIO_K_UTF8) PerlIOBase(f)->flags |= PERLIO_F_UTF8; else @@ -1040,47 +1218,14 @@ PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) return -1; } -PerlIO * -PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode) -{ - PerlIO_funcs *tab = PerlIO_default_layer(-2); - PerlIO *f = (*tab->Fdopen)(tab,fd,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 * -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, + PerlIOUtf8_pushed, + NULL, NULL, - PerlIOUtf8_fdopen, - PerlIOUtf8_open, NULL, - PerlIOUtf8_pushed, NULL, NULL, NULL, @@ -1105,11 +1250,10 @@ PerlIO_funcs PerlIO_byte = { "bytes", sizeof(PerlIOl), PERLIO_K_DUMMY, + PerlIOUtf8_pushed, + NULL, NULL, - PerlIOUtf8_fdopen, - PerlIOUtf8_open, NULL, - PerlIOUtf8_pushed, NULL, NULL, NULL, @@ -1131,29 +1275,21 @@ PerlIO_funcs PerlIO_byte = { }; PerlIO * -PerlIORaw_fdopen(PerlIO_funcs *self, int fd,const char *mode) +PerlIORaw_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n,const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args) { PerlIO_funcs *tab = PerlIO_default_btm(); - return (*tab->Fdopen)(tab,fd,mode); -} - -PerlIO * -PerlIORaw_open(PerlIO_funcs *self, const char *path,const char *mode) -{ - PerlIO_funcs *tab = PerlIO_default_btm(); - return (*tab->Open)(tab,path,mode); + return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args); } PerlIO_funcs PerlIO_raw = { "raw", sizeof(PerlIOl), PERLIO_K_DUMMY, - NULL, - PerlIORaw_fdopen, - PerlIORaw_open, - NULL, PerlIORaw_pushed, PerlIOBase_popped, + PerlIORaw_open, + NULL, + NULL, NULL, NULL, NULL, @@ -1218,7 +1354,7 @@ PerlIO_modestr(PerlIO *f,char *buf) } IV -PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg) { PerlIOl *l = PerlIOBase(f); const char *omode = mode; @@ -1289,9 +1425,10 @@ PerlIOBase_popped(PerlIO *f) SSize_t PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count) { + dTHX; Off_t old = PerlIO_tell(f); SSize_t done; - PerlIO_push(f,&PerlIO_pending,"r",Nullch,0); + PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv); done = PerlIOBuf_unread(f,vbuf,count); PerlIOSelf(f,PerlIOBuf)->posn = old - done; return done; @@ -1436,9 +1573,9 @@ PerlIOUnix_fileno(PerlIO *f) } IV -PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg) { - IV code = PerlIOBase_pushed(f,mode,arg,len); + IV code = PerlIOBase_pushed(f,mode,arg); if (*PerlIONext(f)) { PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix); @@ -1450,65 +1587,53 @@ PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) } PerlIO * -PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode) +PerlIOUnix_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { - dTHX; - PerlIO *f = NULL; - if (*mode == 'I') - mode++; - if (fd >= 0) + if (f) { - int oflags = PerlIOUnix_oflags(mode); - if (oflags != -1) + if (PerlIOBase(f)->flags & PERLIO_F_OPEN) + (*PerlIOBase(f)->tab->Close)(f); + } + if (narg > 0) + { + char *path = SvPV_nolen(*args); + if (*mode == '#') + mode++; + else + { + imode = PerlIOUnix_oflags(mode); + perm = 0666; + } + if (imode != -1) { - PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix); - s->fd = fd; - s->oflags = oflags; + fd = PerlLIO_open3(path,imode,perm); } } - return f; -} - -PerlIO * -PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode) -{ - dTHX; - PerlIO *f = NULL; - int oflags = PerlIOUnix_oflags(mode); - if (oflags != -1) + if (fd >= 0) { - int fd = PerlLIO_open3(path,oflags,0666); - if (fd >= 0) + PerlIOUnix *s; + if (*mode == 'I') + mode++; + if (!f) { - 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; + f = PerlIO_allocate(aTHX); + s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,MYARG),PerlIOUnix); } + else + s = PerlIOSelf(f,PerlIOUnix); + s->fd = fd; + s->oflags = imode; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + return f; } - 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) + else { - dTHX; - int fd = PerlLIO_open3(path,oflags,0666); - if (fd >= 0) + if (f) { - s->fd = fd; - s->oflags = oflags; - PerlIOBase(f)->flags |= PERLIO_F_OPEN; - return 0; + /* FIXME: pop layers ??? */ } + return NULL; } - return -1; } SSize_t @@ -1594,12 +1719,11 @@ PerlIO_funcs PerlIO_unix = { "unix", sizeof(PerlIOUnix), PERLIO_K_RAW, - PerlIOUnix_fileno, - PerlIOUnix_fdopen, - PerlIOUnix_open, - PerlIOUnix_reopen, PerlIOUnix_pushed, PerlIOBase_noop_ok, + PerlIOUnix_open, + NULL, + PerlIOUnix_fileno, PerlIOUnix_read, PerlIOBase_unread, PerlIOUnix_write, @@ -1651,52 +1775,9 @@ PerlIOStdio_mode(const char *mode,char *tmode) return ret; } -PerlIO * -PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode) -{ - dTHX; - 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 ... */ IV -PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg) { dTHX; if (*PerlIONext(f)) @@ -1709,7 +1790,7 @@ PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) else return -1; } - return PerlIOBase_pushed(f,mode,arg,len); + return PerlIOBase_pushed(f,mode,arg); } #undef PerlIO_importFILE @@ -1720,40 +1801,86 @@ PerlIO_importFILE(FILE *stdio, int fl) PerlIO *f = NULL; if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); + PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio); s->stdio = stdio; } return f; } PerlIO * -PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode) +PerlIOStdio_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, 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(aTHX_ (f = PerlIO_allocate(aTHX)), self, + (mode = PerlIOStdio_mode(mode,tmode)),MYARG), + 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(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,MYARG),PerlIOStdio); + s->stdio = stdio; + return f; + } + } + } + return NULL; } SSize_t @@ -1994,12 +2121,11 @@ PerlIO_funcs PerlIO_stdio = { "stdio", sizeof(PerlIOStdio), PERLIO_K_BUFFERED, - PerlIOStdio_fileno, - PerlIOStdio_fdopen, - PerlIOStdio_open, - PerlIOStdio_reopen, PerlIOBase_pushed, PerlIOBase_noop_ok, + PerlIOStdio_open, + NULL, + PerlIOStdio_fileno, PerlIOStdio_read, PerlIOStdio_unread, PerlIOStdio_write, @@ -2043,7 +2169,8 @@ PerlIO_exportFILE(PerlIO *f, int fl) stdio = fdopen(PerlIO_fileno(f),"r+"); if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); + dTHX; + PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio); s->stdio = stdio; } return stdio; @@ -2076,7 +2203,7 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f) /* perlio buffer layer */ IV -PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg) { PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); int fd = PerlIO_fileno(f); @@ -2090,64 +2217,50 @@ PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) { b->posn = posn; } - return PerlIOBase_pushed(f,mode,arg,len); + return PerlIOBase_pushed(f,mode,arg); } PerlIO * -PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode) +PerlIOBuf_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, 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 = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab); + next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args); + if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,MYARG) != 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_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm()); + int init = 0; + if (*mode == 'I') + { + init = 1; + mode++; + } + f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args); + if (f) + { + PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,MYARG),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 */ @@ -2517,12 +2630,11 @@ PerlIO_funcs PerlIO_perlio = { "perlio", sizeof(PerlIOBuf), PERLIO_K_BUFFERED, - PerlIOBase_fileno, - PerlIOBuf_fdopen, - PerlIOBuf_open, - PerlIOBuf_reopen, PerlIOBuf_pushed, PerlIOBase_noop_ok, + PerlIOBuf_open, + NULL, + PerlIOBase_fileno, PerlIOBuf_read, PerlIOBuf_unread, PerlIOBuf_write, @@ -2573,14 +2685,14 @@ PerlIOPending_seek(PerlIO *f, Off_t offset, int whence) IV PerlIOPending_flush(PerlIO *f) { + dTHX; PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) &b->oneword) { - dTHX; PerlMemShared_free(b->buf); b->buf = NULL; } - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); return 0; } @@ -2598,9 +2710,9 @@ PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) } IV -PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len) +PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg) { - IV code = PerlIOBase_pushed(f,mode,arg,len); + IV code = PerlIOBase_pushed(f,mode,arg); PerlIOl *l = PerlIOBase(f); /* Our PerlIO_fast_gets must match what we are pushed on, or sv_gets() etc. get muddled when it changes mid-string @@ -2629,17 +2741,15 @@ PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count) return got; } - PerlIO_funcs PerlIO_pending = { "pending", sizeof(PerlIOBuf), PERLIO_K_BUFFERED, - PerlIOBase_fileno, - NULL, - NULL, - NULL, PerlIOPending_pushed, PerlIOBase_noop_ok, + NULL, + NULL, + PerlIOBase_fileno, PerlIOPending_read, PerlIOBuf_unread, PerlIOBuf_write, @@ -2675,11 +2785,11 @@ typedef struct } PerlIOCrlf; IV -PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) +PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg) { IV code; PerlIOBase(f)->flags |= PERLIO_F_CRLF; - code = PerlIOBuf_pushed(f,mode,arg,len); + code = PerlIOBuf_pushed(f,mode,arg); #if 0 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n", f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)", @@ -2941,12 +3051,11 @@ PerlIO_funcs PerlIO_crlf = { "crlf", sizeof(PerlIOCrlf), PERLIO_K_BUFFERED|PERLIO_K_CANCRLF, - PerlIOBase_fileno, - PerlIOBuf_fdopen, - PerlIOBuf_open, - PerlIOBuf_reopen, PerlIOCrlf_pushed, PerlIOBase_noop_ok, /* popped */ + PerlIOBuf_open, + NULL, + PerlIOBase_fileno, PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */ PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */ PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */ @@ -3247,12 +3356,11 @@ PerlIO_funcs PerlIO_mmap = { "mmap", sizeof(PerlIOMmap), PERLIO_K_BUFFERED, - PerlIOBase_fileno, - PerlIOBuf_fdopen, - PerlIOBuf_open, - PerlIOBuf_reopen, PerlIOBuf_pushed, PerlIOBase_noop_ok, + PerlIOBuf_open, + NULL, + PerlIOBase_fileno, PerlIOBuf_read, PerlIOMmap_unread, PerlIOMmap_write, @@ -3285,14 +3393,15 @@ PerlIO_init(void) } } - - #undef PerlIO_stdin PerlIO * PerlIO_stdin(void) { if (!_perlio) - PerlIO_stdstreams(); + { + dTHX; + PerlIO_stdstreams(aTHX); + } return &_perlio[1]; } @@ -3301,7 +3410,10 @@ PerlIO * PerlIO_stdout(void) { if (!_perlio) - PerlIO_stdstreams(); + { + dTHX; + PerlIO_stdstreams(aTHX); + } return &_perlio[2]; } @@ -3310,7 +3422,10 @@ PerlIO * PerlIO_stderr(void) { if (!_perlio) - PerlIO_stdstreams(); + { + dTHX; + PerlIO_stdstreams(aTHX); + } return &_perlio[3]; } @@ -3438,7 +3553,7 @@ PerlIO_tmpfile(void) FILE *stdio = PerlSIO_tmpfile(); if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio); + PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio); s->stdio = stdio; } return f; @@ -80,10 +80,10 @@ typedef PerlIOl *PerlIO; #define PerlIO PerlIO #define PERLIO_LAYERS 1 -extern void PerlIO_define_layer (PerlIO_funcs *tab); -extern SV * PerlIO_find_layer (const char *name, STRLEN len); -extern PerlIO * PerlIO_push (PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len); -extern void PerlIO_pop (PerlIO *f); +extern void PerlIO_define_layer (pTHX_ PerlIO_funcs *tab); +extern SV * PerlIO_find_layer (pTHX_ const char *name, STRLEN len); +extern PerlIO * PerlIO_push (pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg); +extern void PerlIO_pop (pTHX_ PerlIO *f); #endif /* PerlIO */ @@ -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_openn +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 @@ -6,12 +6,16 @@ struct _PerlIO_funcs char * name; 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); - IV (*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len); + IV (*Pushed)(PerlIO *f,const char *mode,SV *arg); IV (*Popped)(PerlIO *f); + PerlIO * (*Open)(pTHX_ PerlIO_funcs *tab, + AV *layers, IV n, + const char *mode, + int fd, int imode, int perm, + PerlIO *old, + int narg, SV **args); + SV * (*Getarg)(PerlIO *f); + IV (*Fileno)(PerlIO *f); /* 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); @@ -100,7 +104,7 @@ extern PerlIO *PerlIO_allocate(pTHX); /* Generic, or stub layer functions */ extern IV PerlIOBase_fileno (PerlIO *f); -extern IV PerlIOBase_pushed (PerlIO *f, const char *mode,const char *arg,STRLEN len); +extern IV PerlIOBase_pushed (PerlIO *f, const char *mode,SV *arg); extern IV PerlIOBase_popped (PerlIO *f); extern SSize_t PerlIOBase_unread (PerlIO *f, const void *vbuf, Size_t count); extern IV PerlIOBase_eof (PerlIO *f); @@ -131,9 +135,8 @@ 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, AV *layers, IV n, 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 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); |