Change 16215 by jhi@alpha on 2002/04/27 15:52:24
Integrate perlio;
Fix fd leak on Via(bogus).
Finish implementing PerlIOVia_open().
Export more guts of PerlIO_* so Via_open() can work.
Fix various PerlIO_allocate() features exposed by above.
Re-instate $PerlIO::encoding::check at boot.
(Retaining Dan's XS side require though I don't see need.)
Affected files ...
.... //depot/perl/embed.fnc#39 integrate
.... //depot/perl/ext/PerlIO/Via/Via.xs#12 integrate
.... //depot/perl/ext/PerlIO/encoding/encoding.pm#7 integrate
.... //depot/perl/ext/PerlIO/encoding/encoding.xs#9 integrate
.... //depot/perl/ext/PerlIO/t/via.t#3 integrate
.... //depot/perl/makedef.pl#113 integrate
.... //depot/perl/perlio.c#168 integrate
.... //depot/perl/perlio.h#40 integrate
.... //depot/perl/perliol.h#28 integrate
Differences ...
==== //depot/perl/embed.fnc#39 (text) ====
==== //depot/perl/ext/PerlIO/Via/Via.xs#12 (text) ====
Index: perl/ext/PerlIO/Via/Via.xs
--- perl/ext/PerlIO/Via/Via.xs.~1~ Sat Apr 27 10:00:05 2002
+++ perl/ext/PerlIO/Via/Via.xs Sat Apr 27 10:00:05 2002
@@ -55,6 +55,14 @@
}
}
+/*
+ * Try and call method, possibly via cached lookup.
+ * If method does not exist return Nullsv (caller may fallback to another approach
+ * If method does exist call it with flags passing variable number of args
+ * Last arg is a "filehandle" to layer below (if present)
+ * Returns scalar returned by method (if any) otherwise sv_undef
+ */
+
SV *
PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...)
{
@@ -88,6 +96,10 @@
IoOFP(s->io) = PerlIONext(f);
XPUSHs(s->fh);
}
+ else
+ {
+ PerlIO_debug("No next\n");
+ }
PUTBACK;
count = call_sv((SV *)cv,flags);
if (count)
@@ -117,6 +129,7 @@
{
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "No package specified");
+ errno = EINVAL;
code = -1;
}
else
@@ -163,7 +176,9 @@
}
PerlIO *
-PerlIOVia_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char
*mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
+PerlIOVia_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n,
+ const char *mode, int fd, int imode, int perm,
+ PerlIO *f, int narg, SV **args)
{
if (!f)
{
@@ -171,6 +186,7 @@
}
else
{
+ /* Reopen */
if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg))
return NULL;
}
@@ -206,7 +222,44 @@
}
}
else
- return NULL;
+ {
+ /* Required open method not present */
+ PerlIO_funcs *tab = NULL;
+ IV m = n-1;
+ while (m >= 0) {
+ PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layers, m, NULL);
+ if (t && t->Open) {
+ tab = t;
+ break;
+ }
+ n--;
+ }
+ if (tab) {
+ if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode, perm,
+ PerlIONext(f), narg, args)) {
+ PerlIO_debug("Opened with %s =>
+%p->%p\n",tab->name,PerlIONext(f),*PerlIONext(f));
+ if (m + 1 < n) {
+ /*
+ * More layers above the one that we used to open -
+ * apply them now
+ */
+ if (PerlIO_apply_layera(aTHX_ PerlIONext(f), mode, layers, m+1, n)
+!= 0) {
+ /* If pushing layers fails close the file */
+ PerlIO_close(f);
+ f = NULL;
+ }
+ }
+ return f;
+ }
+ else {
+ /* Sub-layer open failed */
+ }
+ }
+ else {
+ /* Nothing to do the open */
+ }
+ return NULL;
+ }
}
return f;
}
@@ -494,7 +547,7 @@
PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,
PerlIOVia_pushed,
PerlIOVia_popped,
- NULL, /* PerlIOVia_open, */
+ PerlIOVia_open, /* NULL, */
PerlIOVia_getarg,
PerlIOVia_fileno,
PerlIOVia_dup,
==== //depot/perl/ext/PerlIO/encoding/encoding.pm#7 (text) ====
Index: perl/ext/PerlIO/encoding/encoding.pm
--- perl/ext/PerlIO/encoding/encoding.pm.~1~ Sat Apr 27 10:00:05 2002
+++ perl/ext/PerlIO/encoding/encoding.pm Sat Apr 27 10:00:05 2002
@@ -1,13 +1,13 @@
package PerlIO::encoding;
use strict;
-our $VERSION = '0.04';
+our $VERSION = '0.05';
our $DEBUG = 0;
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
#
-# Now these are all done in encoding.xs DO NOT COMMENT'em out!
+# Equivalent of these are done in encoding.xs - do not uncomment them.
#
-# use Encode qw(:fallbacks);
+# use Encode ();
# our $check;
use XSLoader ();
==== //depot/perl/ext/PerlIO/encoding/encoding.xs#9 (text) ====
Index: perl/ext/PerlIO/encoding/encoding.xs
--- perl/ext/PerlIO/encoding/encoding.xs.~1~ Sat Apr 27 10:00:05 2002
+++ perl/ext/PerlIO/encoding/encoding.xs Sat Apr 27 10:00:05 2002
@@ -49,6 +49,7 @@
} PerlIOEncode;
#define NEEDS_LINES 1
+#define OUR_DEFAULT_FB "Encode::FB_QUIET"
SV *
PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
@@ -79,13 +80,6 @@
IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
SV *result = Nullsv;
- /*
- * we now "use Encode qw(:fallbacks)" here instead of
- * PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
- * is invoked without prior "use Encode". -- dankogai
- */
- require_pv("Encode.pm");
-
ENTER;
SAVETMPS;
@@ -104,7 +98,7 @@
if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
e->enc = Nullsv;
Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
- arg);
+ arg);
errno = EINVAL;
code = -1;
}
@@ -142,21 +136,8 @@
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
}
- if (SvIV(result = get_sv("PerlIO::encoding::check", 1)) == 0){
- PUSHMARK(sp);
- PUTBACK;
- if (call_pv("Encode::FB_QUIET", G_SCALAR) != 1) {
- /* should never happen */
- Perl_die(aTHX_ "Encode::FB_QUIET did not return a value");
- return -1;
- }
- SPAGAIN;
- e->chk = newSVsv(POPs);
- PUTBACK;
- sv_setsv(result, e->chk);
- }else{
- e->chk = newSVsv(result);
- }
+ e->chk = newSVsv(get_sv("PerlIO::encoding::check", 0));
+
FREETMPS;
LEAVE;
return code;
@@ -607,7 +588,29 @@
BOOT:
{
+ SV *chk = get_sv("PerlIO::encoding::check", GV_ADD|GV_ADDMULTI);
+ /*
+ * we now "use Encode ()" here instead of
+ * PerlIO/encoding.pm. This avoids SEGV when ":encoding()"
+ * is invoked without prior "use Encode". -- dankogai
+ */
+ if (!gv_stashpvn("Encode", 6, FALSE)) {
+ Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'");
+ ENTER;
+ /* The SV is magically freed by load_module */
+ load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv);
+ LEAVE;
+ }
+ PUSHMARK(sp);
+ PUTBACK;
+ if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) {
+ /* should never happen */
+ Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB);
+ }
+ SPAGAIN;
+ sv_setsv(chk, POPs);
+ PUTBACK;
#ifdef PERLIO_LAYERS
- PerlIO_define_layer(aTHX_ &PerlIO_encode);
+ PerlIO_define_layer(aTHX_ &PerlIO_encode);
#endif
}
==== //depot/perl/ext/PerlIO/t/via.t#3 (text) ====
Index: perl/ext/PerlIO/t/via.t
--- perl/ext/PerlIO/t/via.t.~1~ Sat Apr 27 10:00:05 2002
+++ perl/ext/PerlIO/t/via.t Sat Apr 27 10:00:05 2002
@@ -14,7 +14,7 @@
my $tmp = "via$$";
-use Test::More tests => 11;
+use Test::More tests => 13;
my $fh;
my $a = join("", map { chr } 0..255) x 10;
@@ -38,14 +38,32 @@
local $SIG{__WARN__} = sub { $warnings = join '', @_ };
use warnings 'layer';
+
+ # Find fd number we should be using
+ my $fd = open($fh,">$tmp") && fileno($fh);
+ print $fh "Hello\n";
+ close($fh);
+
ok( ! open($fh,">Via(Unknown::Module)", $tmp), 'open Via Unknown::Module will
fail');
like( $warnings, qr/^Cannot find package 'Unknown::Module'/, 'warn about unknown
package' );
+ # Now open normally again to see if we get right fileno
+ my $fd2 = open($fh,"<$tmp") && fileno($fh);
+ is($fd2,$fd,"Wrong fd number after failed open");
+
+ my $data = <$fh>;
+
+ is($data,"Hello\n","File clobbered by failed open");
+
+ close($fh);
+
+
+
$warnings = '';
no warnings 'layer';
ok( ! open($fh,">Via(Unknown::Module)", $tmp), 'open Via Unknown::Module will
fail');
is( $warnings, "", "don't warn about unknown package" );
-}
+}
END {
1 while unlink $tmp;
==== //depot/perl/makedef.pl#113 (text) ====
Index: perl/makedef.pl
--- perl/makedef.pl.~1~ Sat Apr 27 10:00:05 2002
+++ perl/makedef.pl Sat Apr 27 10:00:05 2002
@@ -713,7 +713,11 @@
PerlIO_allocate
PerlIO_arg_fetch
PerlIO_define_layer
- PerlIO_modestr
+ PerlIO_modestr
+ PerlIO_parse_layers
+ PerlIO_layer_fetch
+ PerlIO_list_free
+ PerlIO_apply_layera
PerlIO_pending
PerlIO_push
PerlIO_sv_dup
==== //depot/perl/perlio.c#168 (text) ====
Index: perl/perlio.c
--- perl/perlio.c.~1~ Sat Apr 27 10:00:05 2002
+++ perl/perlio.c Sat Apr 27 10:00:05 2002
@@ -1040,9 +1040,8 @@
int
PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
- PerlIO_list_t *layers, IV n)
+ PerlIO_list_t *layers, IV n, IV max)
{
- IV max = layers->cur;
int code = 0;
while (n < max) {
PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
@@ -1065,7 +1064,7 @@
PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
code = PerlIO_parse_layers(aTHX_ layers, names);
if (code == 0) {
- code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
+ code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
}
PerlIO_list_free(aTHX_ layers);
}
@@ -1356,8 +1355,9 @@
* More layers above the one that we used to open -
* apply them now
*/
- if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1)
- != 0) {
+ if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur)
+!= 0) {
+ /* If pushing layers fails close the file */
+ PerlIO_close(f);
f = NULL;
}
}
@@ -2182,7 +2182,7 @@
IV n, const char *mode, int fd, int imode,
int perm, PerlIO *f, int narg, SV **args)
{
- if (f) {
+ if (PerlIOValid(f)) {
if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
(*PerlIOBase(f)->tab->Close)(aTHX_ f);
}
@@ -2204,11 +2204,14 @@
mode++;
if (!f) {
f = PerlIO_allocate(aTHX);
+ }
+ if (!PerlIOValid(f)) {
s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
PerlIOUnix);
}
- else
+ else {
s = PerlIOSelf(f, PerlIOUnix);
+ }
s->fd = fd;
s->oflags = imode;
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
@@ -2428,7 +2431,7 @@
int perm, PerlIO *f, int narg, SV **args)
{
char tmode[8];
- if (f) {
+ if (PerlIOValid(f)) {
char *path = SvPV_nolen(*args);
PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
FILE *stdio;
@@ -2451,9 +2454,11 @@
else {
FILE *stdio = PerlSIO_fopen(path, mode);
if (stdio) {
- PerlIOStdio *s =
- PerlIOSelf(PerlIO_push
- (aTHX_(f = PerlIO_allocate(aTHX)), self,
+ PerlIOStdio *s;
+ if (!f) {
+ f = PerlIO_allocate(aTHX);
+ }
+ s = PerlIOSelf(PerlIO_push(aTHX_ f, self,
(mode = PerlIOStdio_mode(mode, tmode)),
PerlIOArg),
PerlIOStdio);
@@ -2488,10 +2493,11 @@
PerlIOStdio_mode(mode, tmode));
}
if (stdio) {
- PerlIOStdio *s =
- PerlIOSelf(PerlIO_push
- (aTHX_(f = PerlIO_allocate(aTHX)), self,
- mode, PerlIOArg), PerlIOStdio);
+ PerlIOStdio *s;
+ if (!f) {
+ f = PerlIO_allocate(aTHX);
+ }
+ s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
+PerlIOStdio);
s->stdio = stdio;
PerlIOUnix_refcnt_inc(fileno(s->stdio));
return f;
@@ -2880,7 +2886,7 @@
*/
}
f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
- NULL, narg, args);
+ f, narg, args);
if (f) {
if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
/*
==== //depot/perl/perlio.h#40 (text) ====
==== //depot/perl/perliol.h#28 (text) ====
Index: perl/perliol.h
--- perl/perliol.h.~1~ Sat Apr 27 10:00:05 2002
+++ perl/perliol.h Sat Apr 27 10:00:05 2002
@@ -154,6 +154,13 @@
IV oneword; /* Emergency buffer */
} PerlIOBuf;
+extern int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
+ PerlIO_list_t *layers, IV n, IV max);
+extern int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names);
+extern void PerlIO_list_free(pTHX_ PerlIO_list_t *list);
+extern PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs
+*def);
+
+
extern SV *PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param);
extern PerlIO *PerlIOBuf_open(pTHX_ PerlIO_funcs *self,
PerlIO_list_t *layers, IV n,
End of Patch.
