The APR/Perlio layer is incomplete yet, but you can see what I've done so
far and push me into the right direction if I'm on the wrong one. If i've
picked the right convention for the filename and put things into right
places I won't mind to commit this stuff, since I need it on the parallel
work that I do on Apache::SubProcess.
Look at the t/response/TestUtil/apr_io.pm for things that it does. But
ideally you should be able to continue programming in pure perl syntax,
using APR as the engine for file handling functions, which is probably
useless when you need to work with a file only on the Perl side, but
is required when you want to open a file inside Apache/APR and then work
with it from Perl or vice versa.
Things that work with APR already:
- open/close
- read/write
- seek/
- eof
- dup
- flush
open issues that I've problems with:
- howto convert APR errno to perl's errno
- tell is broken
- currently cannot pass $r|$s via open :( using modperl_global_get_pconf
other open issues:
- BOOT=1 is broken, needs a dummy function or xs file won't be created
- std* streams aren't handled yet
- functions to convert Perl fd to APR fd and vice versa
- probably many others that I didn't get to yet.
Notice that you need the latest APR for the dup() group of sub-tests to
work, or apply this patch:
Index: srclib/apr/file_io/unix/filedup.c
===================================================================
RCS file: /home/cvspublic/apr/file_io/unix/filedup.c,v
retrieving revision 1.35
diff -u -r1.35 filedup.c
--- srclib/apr/file_io/unix/filedup.c 2001/11/21 04:21:03 1.35
+++ srclib/apr/file_io/unix/filedup.c 2001/12/06 17:42:55
@@ -89,6 +89,9 @@
}
/* this is the way dup() works */
(*new_file)->blocking = old_file->blocking;
+
+ (*new_file)->ungetchar = old_file->ungetchar;
+
/* apr_file_dup() clears the inherit attribute, user must call
* apr_file_set_inherit() again on the dupped handle, as necessary.
*/
The PerlIO patch:
Index: lib/ModPerl/Code.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/Code.pm,v
retrieving revision 1.73
diff -u -r1.73 Code.pm
--- lib/ModPerl/Code.pm 2001/12/05 02:22:24 1.73
+++ lib/ModPerl/Code.pm 2001/12/06 17:36:49
@@ -531,7 +531,7 @@
);
my @c_src_names = qw(interp tipool log config cmd options callback handler
- gtop util io filter bucket mgv pcw global env cgi
+ gtop util io perlio filter bucket mgv pcw global env cgi
perl perl_global);
my @g_c_names = map { "modperl_$_" } qw(hooks directives flags xsinit);
my @c_names = ('mod_perl', (map "modperl_$_", @c_src_names));
Index: src/modules/perl/mod_perl.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.h,v
retrieving revision 1.39
diff -u -r1.39 mod_perl.h
--- src/modules/perl/mod_perl.h 2001/11/24 01:15:01 1.39
+++ src/modules/perl/mod_perl.h 2001/12/06 17:36:49
@@ -30,6 +30,7 @@
#include "modperl_options.h"
#include "modperl_directives.h"
#include "modperl_io.h"
+#include "modperl_perlio.h"
#include "modperl_filter.h"
#include "modperl_bucket.h"
#include "modperl_pcw.h"
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.29
diff -u -r1.29 modperl_functions.map
--- xs/maps/modperl_functions.map 2001/11/15 18:19:56 1.29
+++ xs/maps/modperl_functions.map 2001/12/06 17:36:49
@@ -90,3 +90,6 @@
PACKAGE=Apache
DEFINE_LOG_MARK | MPXS_Apache_LOG_MARK | ...
DEFINE_warn | MPXS_Apache__Log_log_error | ...
+
+MODULE=APR::IO PACKAGE=Apache::RequestRec BOOT=1
+ mpxs_APR__IO_dummy
--- /dev/null Thu Jan 1 07:30:00 1970
+++ t/response/TestUtil/apr_io.pm Fri Dec 7 01:41:00 2001
@@ -0,0 +1,127 @@
+package TestUtil::apr_io;
+
+use strict;
+use warnings;# FATAL => 'all';
+
+use Apache::Const -compile => 'OK';
+
+use Apache::Test;
+use Apache::TestUtil;
+use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END);
+
+use APR::IO ();
+
+sub handler {
+ my $r = shift;
+
+ plan $r, tests => 9, todo => [2, 5];
+
+ # write file
+ my $file = "/tmp/file$$";
+ t_debug "file $file";
+ open my $fh, ">:APR", $file
+ or die "Cannot open $file for writing: $!";
+ ok ref($fh) eq 'GLOB';
+
+ my $expected = "This is a test: $$";
+ print $fh $expected;
+ close $fh;
+
+ # open() other tests
+ {
+ # non-existant file
+ #my $file = "/this/file/does/not/exist";
+ my $file = "/tmp/mytest";
+ if (open my $fh, "<:APR", $file) {
+ t_debug "must not be able to open $file!";
+ ok 0;
+ close $fh;
+ } else {
+ t_debug "good: failure reason: $!";
+ ok 1;
+ }
+
+ }
+
+ # read() test
+ {
+ open my $fh, "<:APR", $file
+ 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
+ or die "Cannot open $file for reading: $!";
+
+ my $pos = 3;
+ seek $fh, $pos, SEEK_SET;
+ # XXX: broken
+ my $got = tell($fh);
+ ok t_cmp($pos,
+ $got,
+ "seek/tell the file");
+
+ # XXX: test SEEK_CUR SEEK_END
+ close $fh;
+
+ }
+
+
+ # eof() tests
+ {
+ open my $fh, "<:APR", $file
+ 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, SEEK_END;
+ my $received = <$fh>;
+
+ ok t_cmp(1,
+ eof($fh),
+ "end of file");
+ close $fh;
+ }
+
+ # dup() test
+ {
+ open my $fh, "<:APR", $file
+ 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");
+ }
+
+ # cleanup
+ unlink $file;
+
+ # need tests for stdin/out/err as they are handled specially
+
+ # tmpfile is missing:
+ # consider to use 5.8's syntax:
+ # open $fh, "+>", undef;
+
+ Apache::OK;
+}
+
+1;
--- /dev/null Thu Jan 1 07:30:00 1970
+++ src/modules/perl/modperl_perlio.c Fri Dec 7 01:54:33 2001
@@ -0,0 +1,267 @@
+#include "mod_perl.h"
+
+#ifdef PERLIO_LAYERS
+
+/**********************************************************************
+ * The implementation of the Perl IO layer using APR. See perliol.pod *
+ * for the used API's documentation. *
+ **********************************************************************/
+
+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.
+ */
+IV
+PerlIOAPR_popped(PerlIO *f)
+{
+ dTHX;
+ PerlIOAPR *st = PerlIOSelf(f,PerlIOAPR);
+ /* XXX: do cleanup here */
+ return 0;
+}
+
+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;
+
+ if (!(SvROK(arg) || SvPOK(arg))) {
+ return NULL;
+ }
+
+ 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(&arg[narg-1]);
+
+ switch (*mode) {
+ case 'a' : apr_flag = APR_APPEND | APR_CREATE; break;
+ case 'w' : apr_flag = APR_WRITE | APR_CREATE; break;
+ case 'r' : apr_flag = APR_READ; break;
+ default :
+ }
+
+ st = PerlIOSelf(f, PerlIOAPR);
+
+ /* XXX: passing r or s to get the pool? */
+ /* XXX: need to move to _pushed? */
+ st->pool = modperl_global_get_pconf();
+
+ if ( (rc = apr_file_open(&st->file, path, apr_flag,
+ APR_OS_DEFAULT, st->pool)) != APR_SUCCESS) {
+ /* XXX: how do we set $! */
+ char buf[120];
+ ap_log_error(APLOG_MARK, APLOG_STARTUP | APLOG_NOERRNO, 0, NULL,
+ "cannot open file '%s': %s",
+ path, apr_strerror(rc, buf, sizeof(buf)));
+ }
+
+ return f;
+}
+
+
+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;
+}
+
+PerlIO *
+PerlIOAPR_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
+{
+ Size_t count;
+
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
+ PerlIOAPR *fst = PerlIOSelf(f, PerlIOAPR);
+ PerlIOAPR *ost = PerlIOSelf(o, PerlIOAPR);
+ if ((apr_file_dup(&fst->file, ost->file, ost->pool) == APR_SUCCESS)) {
+ /* XXX: error? */
+ fst->pool = ost->pool;
+ }
+ }
+ /* XXX: else error? */
+ return f;
+}
+
+SSize_t
+PerlIOAPR_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_status_t rc;
+
+ if ((rc = apr_file_read(st->file, vbuf, &count) != APR_SUCCESS)) {
+ /* XXX: error? */
+ return (SSize_t) -1;
+ }
+ return (SSize_t) count;
+}
+
+
+SSize_t
+PerlIOAPR_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_status_t rc;
+
+ if ((rc = apr_file_write(st->file, vbuf, &count) != APR_SUCCESS)) {
+ /* XXX: how do we set $! */
+ char buf[120];
+ ap_log_error(APLOG_MARK, APLOG_STARTUP | APLOG_NOERRNO, 0, NULL,
+ "cannot write to file: %s",
+ apr_strerror(rc, buf, sizeof(buf)));
+ /* XXX: error? */
+ return (SSize_t) -1;
+ }
+ return (SSize_t) count;
+}
+
+IV
+PerlIOAPR_seek(PerlIO *f, Off_t offset, int whence)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_seek_where_t where;
+
+ /* must flush before seek */
+ if ((apr_file_flush(st->file) != APR_SUCCESS)) {
+ return -1;
+ }
+
+ switch(whence) {
+ case 0:
+ where = APR_SET;
+ break;
+ case 1:
+ where = APR_CUR;
+ break;
+ case 2:
+ where = APR_END;
+ break;
+ }
+
+ if ((apr_file_seek(st->file, where, (apr_off_t *)&offset) == APR_SUCCESS)) {
+ return 0;
+ }
+ else {
+ return -1;
+ }
+}
+
+
+Off_t
+PerlIOAPR_tell(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ apr_off_t offset = 0;
+ /* this is broken, for some reason it returns 6e17 */
+ return (off_t)3;
+
+ if ((apr_file_seek(st->file, APR_CUR, &offset) == APR_SUCCESS)) {
+ return (Off_t) offset;
+ }
+ return (Off_t) -1;
+}
+
+IV
+PerlIOAPR_close(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+ IV code = PerlIOBase_close(f);
+ if ((apr_file_flush(st->file) != APR_SUCCESS)) {
+ /* XXX: error? */
+ return 0;
+ }
+ if ((apr_file_close(st->file) == APR_SUCCESS)) {
+ /* XXX: log to error_log? */
+ }
+
+ /* XXX: what's this for? */
+ PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ return code;
+}
+
+
+IV
+PerlIOAPR_flush(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+
+ if ((apr_file_flush(st->file) == APR_SUCCESS)) {
+ return 0;
+ }
+ else {
+ return -1;
+ }
+}
+
+IV
+PerlIOAPR_eof(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+
+ switch (apr_file_eof(st->file)) {
+ case APR_SUCCESS:
+ return 0;
+ case APR_EOF:
+ return 1;
+ }
+}
+
+PerlIO_funcs PerlIO_APR = {
+ "APR",
+ sizeof(PerlIOAPR),
+ PERLIO_K_BUFFERED,
+ 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,
+ PerlIOBuf_fill,
+ PerlIOAPR_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBase_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOBuf_set_ptrcnt
+};
+
+void modperl_perlio_init(pTHX)
+{
+ PerlIO_define_layer(aTHX_ &PerlIO_APR);
+}
+
+#endif /* PERLIO_LAYERS */
--- /dev/null Thu Jan 1 07:30:00 1970
+++ src/modules/perl/modperl_perlio.h Fri Dec 7 01:41:00 2001
@@ -0,0 +1,13 @@
+#ifndef MODPERL_PERLIO_H
+#define MODPERL_PERLIO_H
+
+#ifdef PERLIO_LAYERS
+
+#include "perliol.h"
+#include "apr_file_io.h"
+
+void modperl_perlio_init(pTHX);
+
+#endif /* PERLIO_LAYERS */
+
+#endif /* MODPERL_PERLIO_H */
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/APR/IO/APR__IO.h Fri Dec 7 01:55:49 2001
@@ -0,0 +1,14 @@
+/* implements PerlIO layer via apr_file_t* layer */
+
+#include "modperl_io.h"
+
+static void mpxs_APR__IO_BOOT(pTHX)
+{
+ modperl_perlio_init(aTHX);
+}
+
+/* BOOT=1 won't create Wrap/XS without this dummy */
+static void mpxs_APR__IO_dummy(void)
+{
+}
+
_____________________________________________________________________
Stas Bekman JAm_pH -- Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide http://perl.apache.org/guide
mailto:[EMAIL PROTECTED] http://ticketmaster.com http://apacheweek.com
http://singlesheaven.com http://perl.apache.org http://perlmonth.com/
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
