You are viewing a plain text version of this content. The canonical link for it is here.
Posted to dev@perl.apache.org by Stas Bekman <st...@stason.org> on 2001/12/14 19:25:51 UTC
[patch] APR::PerlIO
This patch:
- implements APR::PerlIO layer
- implements apr_file_t to APR::PerlIO hooks (one way)
- tests (hooks are tested in Apache::SubProcess, patch coming next)
Issues:
- PerlIOAPR_tell is broken (under investigation)
- Read is non-buffered, which sucks. waiting for apr-dev to respond to my
question about exposing apr buffer. Otherwise we will have to implement
buffering ourselves, which will slow things down :(
- needs a lot more error checking and probably many more tests
--- /dev/null Thu Jan 1 07:30:00 1970
+++ t/response/TestAPR/perlio.pm Sat Dec 15 01:50:00 2001
@@ -0,0 +1,141 @@
+package TestAPR::perlio;
+
+use strict;
+use warnings;# FATAL => 'all';
+
+use Apache::Const -compile => 'OK';
+
+use Apache::Test;
+use Apache::TestUtil;
+
+use APR::PerlIO ();
+
+use Fcntl ();
+use File::Spec::Functions qw(catfile);
+
+sub handler {
+ my $r = shift;
+
+ plan $r, tests => 10, todo => [5], have_perl 'iolayers';
+
+ my $vars = Apache::Test::config()->{vars};
+ my $dir = catfile $vars->{documentroot}, "perlio";
+
+ t_mkdir($dir);
+
+ # write file
+ my $file = catfile $dir, "test";
+ t_debug "open file $file";
+ my $foo = "bar";
+ open my $fh, ">:APR", $file, $r
+ or die "Cannot open $file for writing: $!";
+ ok ref($fh) eq 'GLOB';
+
+ my $expected = "This is a test: $$";
+ t_debug "write to a file: $expected";
+ print $fh $expected;
+ close $fh;
+
+ # open() other tests
+ {
+ # non-existant file
+ my $file = "/this/file/does/not/exist";
+ t_write_file("/tmp/testing", "some stuff");
+ if (open my $fh, "<:APR", $file, $r) {
+ t_debug "must not be able to open $file!";
+ ok 0;
+ close $fh;
+ }
+ else {
+ t_debug "good! cannot open/doesn't exist: $!";
+ ok 1;
+ }
+ }
+
+ # read() test
+ {
+ open my $fh, "<:APR", $file, $r
+ or die "Cannot open $file for reading: $!";
+ ok ref($fh) eq 'GLOB';
+
+ my $received = <$fh>;
+ close $fh;
+
+ ok t_cmp($expected,
+ $received,
+ "read/write file");
+ }
+
+ # seek/tell() tests
+ {
+ open my $fh, "<:APR", $file, $r
+ or die "Cannot open $file for reading: $!";
+
+ my $pos = 3;
+ seek $fh, $pos, Fcntl::SEEK_SET();
+ # XXX: broken
+ my $got = tell($fh);
+ ok t_cmp($pos,
+ $got,
+ "seek/tell the file");
+
+ # XXX: test Fcntl::SEEK_CUR() Fcntl::SEEK_END()
+ close $fh;
+
+ }
+
+ # eof() tests
+ {
+ open my $fh, "<:APR", $file, $r
+ or die "Cannot open $file for reading: $!";
+
+ ok t_cmp(0,
+ int eof($fh), # returns false, not 0
+ "not end of file");
+ # go to the end and read
+ seek $fh, 0, Fcntl::SEEK_END();
+ my $received = <$fh>;
+
+ ok t_cmp(1,
+ eof($fh),
+ "end of file");
+ close $fh;
+ }
+
+ # dup() test
+ {
+ open my $fh, "<:APR", $file, $r
+ or die "Cannot open $file for reading: $!";
+
+ open my $dup_fh, "<&:APR", $fh
+ or die "Cannot dup $file for reading: $!";
+ close $fh;
+ ok ref($dup_fh) eq 'GLOB';
+
+ my $received = <$dup_fh>;
+
+ close $dup_fh;
+ ok t_cmp($expected,
+ $received,
+ "read/write a dupped file");
+ }
+
+ my $stderr = APR::PerlIO::get_stderr();
+ ok ref $stderr;
+ print $stderr "foo";
+ close $stderr;
+
+ # XXX: need tests
+ # - for stdin/out/err as they are handled specially
+ # - unbuffered read $|=1?
+
+ # XXX: tmpfile is missing:
+ # consider to use 5.8's syntax:
+ # open $fh, "+>", undef;
+
+ # cleanup: t_mkdir will remove the whole tree including the file
+
+ Apache::OK;
+}
+
+1;
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/APR/PerlIO/apr_perlio.c Sat Dec 15 01:41:43 2001
@@ -0,0 +1,391 @@
+
+#include "mod_perl.h"
+#include "apr_perlio.h"
+
+/* XXX: prerequisites to have things working
+ * open(): perl 5.7.2 patch 13534 is required
+ * dup() : apr cvs date: 2001/12/06 13:43:45
+ * tell(): the patch isn't in yet.
+ *
+ * XXX: it's not enough to check for PERLIO_LAYERS, some functionality
+ * and bug fixes were added only in the late 5.7.2, whereas
+ * PERLIO_LAYERS is available in 5.7.1
+ */
+
+#ifdef PERLIO_LAYERS
+
+/**********************************************************************
+ * The Perl IO APR layer.
+ * PerlIO API is documented in perliol.pod.
+ **********************************************************************/
+
+typedef struct {
+ PerlIOBuf base; /* PerlIOBuf stuff */
+ apr_file_t *file;
+ apr_pool_t *pool;
+} PerlIOAPR;
+
+
+/* clean up any structures linked from PerlIOAPR. a layer can be
+ * popped without being closed if the program is dynamically managing
+ * layers on the stream.
+ */
+static IV PerlIOAPR_popped(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+
+ return 0;
+}
+
+
+static PerlIO *PerlIOAPR_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)
+{
+ AV *av_arg;
+ SV *arg = (narg > 0) ? *args : PerlIOArg;
+ PerlIOAPR *st;
+ const char *path;
+ apr_int32_t apr_flag;
+ int len;
+ apr_status_t rc;
+ SV *sv;
+
+ if ( !(SvROK(arg) || SvPOK(arg)) ) {
+ return NULL;
+ }
+
+ /* XXX: why passing only SV* for arg, check this out in PerlIO_push */
+ if (!f) {
+ f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX), self, mode, arg);
+ }
+ else {
+ f = PerlIO_push(aTHX_ f, self, mode, arg);
+ }
+
+ /* grab the last arg as a filepath */
+ path = (const char *)SvPV_nolen(args[narg-2]);
+
+ switch (*mode) {
+ case 'a':
+ apr_flag = APR_APPEND | APR_CREATE;
+ break;
+ case 'w':
+ apr_flag = APR_WRITE | APR_CREATE | APR_TRUNCATE;
+ break;
+ case 'r':
+ apr_flag = APR_READ;
+ break;
+ }
+
+ st = PerlIOSelf(f, PerlIOAPR);
+
+ sv = args[narg-1];
+ st->pool = modperl_sv2pool(aTHX_ sv);
+
+ rc = apr_file_open(&st->file, path, apr_flag, APR_OS_DEFAULT, st->pool);
+ if (rc != APR_SUCCESS) {
+ PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ return NULL;
+ }
+ else {
+ PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+ return f;
+ }
+
+
+
+}
+
+
+
+static IV PerlIOAPR_fileno(PerlIO *f)
+{
+ /* apr_file_t* is an opaque struct, so fileno is not available */
+ /* XXX: this should be documented in perliol.pod */
+ /* see: http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-11/thrd21.html#02040 */
+ /* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-12/threads.html#00217 */
+ return -1;
+}
+
+static PerlIO *PerlIOAPR_dup(pTHX_ PerlIO *f, PerlIO *o,
+ CLONE_PARAMS *param, int flags)
+{
+ Size_t count;
+ apr_status_t rc;
+
+ if ( (f = PerlIOBase_dup(aTHX_ f, o, param, flags)) ) {
+ PerlIOAPR *fst = PerlIOSelf(f, PerlIOAPR);
+ PerlIOAPR *ost = PerlIOSelf(o, PerlIOAPR);
+
+ rc = apr_file_dup(&fst->file, ost->file, ost->pool);
+ if (rc == APR_SUCCESS) {
+ fst->pool = ost->pool;
+ return f;
+ }
+ }
+
+ return NULL;
+
+}
+
+static SSize_t PerlIOAPR_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_status_t rc;
+ dTHX;
+
+// fprintf(stderr, "in read: count %d, %s\n", (int)count, (char*) vbuf);
+ rc = apr_file_read(st->file, vbuf, &count);
+// fprintf(stderr, "out read: count %d, %s\n", (int)count, (char*) vbuf);
+ if (rc == APR_SUCCESS) {
+ return (SSize_t) count;
+ }
+ else {
+ return (SSize_t) -1;
+ }
+}
+
+
+static SSize_t PerlIOAPR_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_status_t rc;
+
+// fprintf(stderr, "in write: count %d, %s\n", (int)count, (char*) vbuf);
+ rc = apr_file_write(st->file, vbuf, &count);
+ if (rc == APR_SUCCESS) {
+ return (SSize_t) count;
+ }
+ else {
+ return (SSize_t) -1;
+ }
+}
+
+static IV PerlIOAPR_seek(PerlIO *f, Off_t offset, int whence)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_seek_where_t where;
+ apr_status_t rc;
+
+ /* XXX: must flush before seek? */
+ rc = apr_file_flush(st->file);
+ if (rc != APR_SUCCESS) {
+ return -1;
+ }
+
+ switch(whence) {
+ case 0:
+ where = APR_SET;
+ break;
+ case 1:
+ where = APR_CUR;
+ break;
+ case 2:
+ where = APR_END;
+ break;
+ }
+
+ rc = apr_file_seek(st->file, where, (apr_off_t *)&offset);
+ if (rc == APR_SUCCESS) {
+ return 0;
+ }
+ else {
+ return -1;
+ }
+}
+
+
+static Off_t PerlIOAPR_tell(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_off_t offset = 0;
+ apr_status_t rc;
+
+ /* this is broken, for some reason it returns 6e17 */
+
+ rc = apr_file_seek(st->file, APR_CUR, &offset);
+ if (rc == APR_SUCCESS) {
+ return (Off_t) offset;
+ }
+ else {
+ return (Off_t) -1;
+ }
+}
+
+
+static IV PerlIOAPR_close(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ IV code = PerlIOBase_close(f);
+ apr_status_t rc;
+
+ const char *new_path;
+ apr_file_name_get(&new_path, st->file);
+ fprintf(stderr, "closing file %s\n", new_path);
+
+ rc = apr_file_flush(st->file);
+ if (rc != APR_SUCCESS) {
+ return -1;
+ }
+
+ rc = apr_file_close(st->file);
+ if (rc != APR_SUCCESS) {
+ return -1;
+ }
+
+ return code;
+}
+
+
+static IV PerlIOAPR_flush(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_status_t rc;
+
+ rc = apr_file_flush(st->file);
+ if (rc == APR_SUCCESS) {
+ return 0;
+ }
+ else {
+ return -1;
+ }
+}
+
+static IV PerlIOAPR_fill(PerlIO *f)
+{
+ return -1;
+}
+
+static IV PerlIOAPR_eof(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_status_t rc;
+
+ rc = apr_file_eof(st->file);
+ switch (rc) {
+ case APR_SUCCESS:
+ return 0;
+ case APR_EOF:
+ return 1;
+ }
+}
+
+static PerlIO_funcs PerlIO_APR = {
+ "APR",
+ sizeof(PerlIOAPR),
+ PERLIO_K_BUFFERED | PERLIO_K_MULTIARG, /* XXX: document the flag in perliol.pod */
+ PerlIOBase_pushed,
+ PerlIOAPR_popped,
+ PerlIOAPR_open,
+ NULL, /* no getarg needed */
+ PerlIOAPR_fileno,
+ PerlIOAPR_dup,
+ PerlIOAPR_read,
+ PerlIOBuf_unread,
+ PerlIOAPR_write,
+ PerlIOAPR_seek,
+ PerlIOAPR_tell,
+ PerlIOAPR_close,
+ PerlIOAPR_flush,
+ PerlIOAPR_fill,
+ PerlIOAPR_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBase_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOBuf_set_ptrcnt,
+};
+
+void apr_perlio_init(pTHX)
+{
+ APR_REGISTER_OPTIONAL_FN(apr_perlio_apr_file_to_PerlIO);
+ APR_REGISTER_OPTIONAL_FN(apr_perlio_apr_file_to_glob);
+ PerlIO_define_layer(aTHX_ &PerlIO_APR);
+}
+
+
+/* ***** End of PerlIOAPR tab ***** */
+
+/**********************************************************************
+ * The implementation of the Perl IO layer using APR. See perliol.pod *
+ * for the used API's documentation. *
+ **********************************************************************/
+
+
+
+
+
+PerlIO *apr_perlio_apr_file_to_PerlIO(pTHX_ apr_file_t *file,
+ apr_pool_t *pool)
+{
+ const char *mode = "w";
+ const char *layers = ":APR";
+ PerlIO *f = PerlIO_allocate(aTHX);
+
+ PerlIO_apply_layers(aTHX_ f, mode, layers);
+
+ if (f) {
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+
+ st->pool = pool;
+ st->file = file;
+ PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+
+ return f;
+ }
+ else {
+ return NULL;
+ }
+}
+
+/* XXX: this will go away */
+PerlIO *apr_perlio_test(pTHX)
+{
+ char *path = "/tmp/perlio_test";
+ apr_file_t *file;
+ apr_pool_t *pool = modperl_global_get_pconf();
+
+ apr_file_open(&file, path, APR_WRITE | APR_CREATE | APR_TRUNCATE, APR_OS_DEFAULT,pool );
+ return apr_perlio_apr_file_to_PerlIO(aTHX_ file, pool);
+}
+
+/*
+ * pio : PerlIO*
+ * type: "r", "w"
+ */
+static SV *apr_perlio_PerlIO_to_glob(pTHX_ PerlIO *pio, int type)
+{
+ SV *retval = modperl_perl_gensym(aTHX_ "APR::PerlIO");
+ GV *gv = (GV*)SvRV(retval);
+
+ gv_IOadd(gv);
+
+ switch (type) {
+ case APR_PERLIO_HOOK_WRITE:
+ IoOFP(GvIOp(gv)) = pio;
+ IoFLAGS(GvIOp(gv)) |= IOf_FLUSH;
+ break;
+ case APR_PERLIO_HOOK_READ:
+ IoIFP(GvIOp(gv)) = pio;
+ break;
+ default:
+ /* */
+ };
+
+ return sv_2mortal(retval);
+}
+
+SV *apr_perlio_apr_file_to_glob(pTHX_ apr_file_t *file,
+ apr_pool_t *pool, int type)
+{
+ return apr_perlio_PerlIO_to_glob(aTHX_
+ apr_perlio_apr_file_to_PerlIO(aTHX_ file, pool),
+ type);
+}
+
+#endif /* PERLIO_LAYERS */
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/APR/PerlIO/apr_perlio.h Sat Dec 15 02:05:41 2001
@@ -0,0 +1,45 @@
+#ifndef APR_PERLIO_H
+#define APR_PERLIO_H
+
+#ifdef PERLIO_LAYERS
+
+#include "perliol.h"
+#include "apr_file_io.h"
+
+#ifndef MP_SOURCE_SCAN
+#include "apr_optional.h"
+#endif
+
+#define APR_PERLIO_HOOK_READ 0
+#define APR_PERLIO_HOOK_WRITE 1
+
+/* XXX: this goes away */
+PerlIO *apr_perlio_test(pTHX);
+
+/* XXX: May need to make this one optional too, if PerlIO.so is used
+ * by some C lib, without loading APR::PerlIO perl module, which will
+ * boot with apr_perlio_init
+ */
+void apr_perlio_init(pTHX);
+
+/* The following functions can be used from other .so libs, they just
+ * need to load APR::PerlIO perl module first
+ */
+#ifndef MP_SOURCE_SCAN
+PerlIO *apr_perlio_apr_file_to_PerlIO(pTHX_ apr_file_t *file,
+ apr_pool_t *pool);
+APR_DECLARE_OPTIONAL_FN(PerlIO *,
+ apr_perlio_apr_file_to_PerlIO,
+ (pTHX_ apr_file_t *file, apr_pool_t *pool));
+
+
+SV *apr_perlio_apr_file_to_glob(pTHX_ apr_file_t *file,
+ apr_pool_t *pool, int type);
+APR_DECLARE_OPTIONAL_FN(SV *,
+ apr_perlio_apr_file_to_glob,
+ (pTHX_ apr_file_t *file, apr_pool_t *pool, int type));
+#endif /* MP_SOURCE_SCAN */
+
+#endif /* PERLIO_LAYERS */
+
+#endif /* APR_PERLIO_H */
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/APR/PerlIO/Makefile.PL Tue Dec 11 18:02:58 2001
@@ -0,0 +1,8 @@
+use lib qw(../lib);
+use ModPerl::MM ();
+
+ModPerl::MM::WriteMakefile(
+ NAME => 'APR::PerlIO',
+ VERSION_FROM => 'PerlIO.pm',
+ OBJECT => 'PerlIO.o apr_perlio.o');
+
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/APR/PerlIO/PerlIO.xs Sat Dec 15 01:58:03 2001
@@ -0,0 +1,21 @@
+#include "mod_perl.h"
+#include "apr_perlio.h"
+
+MODULE = APR::PerlIO PACKAGE = APR::PerlIO
+
+PROTOTYPES: disabled
+
+BOOT:
+ apr_perlio_init(aTHX);
+
+PerlIO *
+get_stderr()
+
+ PREINIT:
+ /*nada*/
+
+ CODE:
+ RETVAL = apr_perlio_test(aTHX);
+
+ OUTPUT:
+ RETVAL
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/APR/PerlIO/PerlIO.pm Fri Dec 14 13:41:02 2001
@@ -0,0 +1,8 @@
+package APR::PerlIO;
+
+our $VERSION = '0.01';
+
+use APR::XSLoader ();
+APR::XSLoader::load __PACKAGE__;
+
+1;
_____________________________________________________________________
Stas Bekman JAm_pH -- Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide http://perl.apache.org/guide
mailto:stas@stason.org http://ticketmaster.com http://apacheweek.com
http://singlesheaven.com http://perl.apache.org http://perlmonth.com/
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org
Re: [patch] APR::PerlIO
Posted by Doug MacEachern <do...@covalent.net>.
i probably won't be able to to a close review for a couple of days, but a
quick skim looks good. as long as modperl-2.0 will compile and pass
all tests with 5.6.1 (doesn't look like it will as-is?), go ahead and
commit, we can work out any issues after that.
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org