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/06 19:12:00 UTC
[patch] PerlIO layer for APR
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: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] PerlIO layer for APR
Posted by Stas Bekman <st...@stason.org>.
Doug MacEachern wrote:
> On Sat, 8 Dec 2001, Stas Bekman wrote:
>
>
>>no more dTHXs in APR PerlIO layer (at least so far), but they are used
>>internally in the base PerlIO layer to do XS.
>>
>
> right. but if that perl function took a pTHX_ (like many of the
> others do) then there would be no need for dTHX;
yes of course.
>>>>todo, I guess I need to provide an XS constant that says whether
>>>>
>>PerlIO is available, right?
>>
>
> you can do this now:
> plan tests => $tests, have_perl 'iolayers';
thanks :)
>>+ st->pool = modperl_global_get_pconf();
>>
>
> hope you can find a good solution for this problem. aside from not being
> able to use pconf after startup time, we cannot reference that function
> else APR::PerlIO will not work outside of httpd.
yes, I understand that. It probably will take some time. But it doesn't
stop us from using PerlIO with modperl_global_get_pconf() in dev.
>>+void apr_perlio_BOOT(pTHX)
>>
>
> minor nit: would rather have that called apr_perlio_initialize()
> or apr_perlio_init(). BOOT just happens to be when we call it in xs, not
> what it actually does.
done
> looks good, +1 on committing. other issues can be worked out later.
great!
_____________________________________________________________________
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] PerlIO layer for APR
Posted by Doug MacEachern <do...@covalent.net>.
On Sat, 8 Dec 2001, Stas Bekman wrote:
> no more dTHXs in APR PerlIO layer (at least so far), but they are used
> internally in the base PerlIO layer to do XS.
right. but if that perl function took a pTHX_ (like many of the
others do) then there would be no need for dTHX;
>>> todo, I guess I need to provide an XS constant that says whether
> PerlIO is available, right?
you can do this now:
plan tests => $tests, have_perl 'iolayers';
> + st->pool = modperl_global_get_pconf();
hope you can find a good solution for this problem. aside from not being
able to use pconf after startup time, we cannot reference that function
else APR::PerlIO will not work outside of httpd.
> +void apr_perlio_BOOT(pTHX)
minor nit: would rather have that called apr_perlio_initialize()
or apr_perlio_init(). BOOT just happens to be when we call it in xs, not
what it actually does.
looks good, +1 on committing. other issues can be worked out later.
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org
Re: [patch] PerlIO layer for APR
Posted by Stas Bekman <st...@stason.org>.
On Thu, 6 Dec 2001, Doug MacEachern wrote:
> On Fri, 7 Dec 2001, Stas Bekman wrote:
>
> cool! one major problem with the file layout/linking however.
> neither perlio nor apr is tied to httpd, so the APR PerlIO layer shouldn't
> be either. that is, it should be possible to use the APR PerlIO layer
> outside of httpd. there's no need to use the .map stuff for this. you
> can just create:
> xs/APR/PerlIO
> with:
> apr_perlio.h - was modperl_perlio.h
> apr_perlio.c - was modperl_perlio.c
> PerlIO.xs - just has the BOOT section to add the layer
> PerlIO.pm - use APR () and load PerlIO.so
> Makefile.PL - ModPerl::MM::WriteMakefile(
> NAME => 'APR::PerlIO',
> VERSION_FROM => 'PerlIO.pm',
> OBJECT => 'PerlIO.o apr_perlio.o');
done
> when PerlIO.pm does 'use APR ()' it is a noop inside modperl and
> outside loads libapr, libaprutil and takes care of
> apr_initialize/apr_terminate.
done
> > - currently cannot pass $r|$s via open :( using modperl_global_get_pconf
>
> we can't do that. pconf can only be used at startup.
> if builtin open doesn't support passing an APR::Pool reference, then we
> need to have an APR::PerlIO::open that does.
the good news is that's apparently a bug in PerlIO, so we may have it
working :)
> another thing to consider is how to map apr_file_t's that are returned by
> existing apache and apr functions. won't be able to use the builtin open
> for those.
yup, that was on my todo list already.
> functions themselves look good, just a few style comments...
great!
> > +IV
> > +PerlIOAPR_popped(PerlIO *f)
>
> all of these functions should be static. and should also follow the
> style where return type is on the same line as function name:
> static IV PerlIOAPR_popped(...)
fixed
> > +{
> > + dTHX;
>
> would be nice if we could "fix" Perl so dTHX is not needed for any of
> these functions.
no more dTHXs in APR PerlIO layer (at least so far), but they are used
internally in the base PerlIO layer to do XS.
> > + 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 :
> > + }
>
> should follow style of other switch statement in modperl.
fixed
> > +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;
> > + }
>
> indenting off.
fixed
> > + /* XXX: what's this for? */
> > + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
>
> turns off buffering flags, dunno if it actually needs to.
removed
> > +PerlIO_funcs PerlIO_APR = {
>
> this should be static too.
fixed
> also TestUtil::apr_io should be TestAPR::perlio.
fixed
> and of course should be
> skipped if perlio isn't available.
>> todo, I guess I need to provide an XS constant that says whether PerlIO
is available, right?
here is the new version of the new layer:
--- /dev/null Thu Jan 1 07:30:00 1970
+++ t/response/TestAPR/perlio.pm Sat Dec 8 02:16:04 2001
@@ -0,0 +1,129 @@
+package TestAPR::perlio;
+
+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::PerlIO ();
+
+
+sub handler {
+ my $r = shift;
+
+ # XXX: need to be skipped if perlio is not available
+ 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
+++ xs/APR/PerlIO/apr_perlio.c Sat Dec 8 02:14:45 2001
@@ -0,0 +1,262 @@
+#include "mod_perl.h"
+#include "apr_perlio.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.
+ */
+static IV PerlIOAPR_popped(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f,PerlIOAPR);
+
+ /* XXX: do cleanup here */
+ 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;
+
+ 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;
+ }
+
+ 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;
+}
+
+
+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;
+
+ 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;
+}
+
+static 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;
+}
+
+
+static 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;
+}
+
+static 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;
+ }
+}
+
+
+static 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;
+}
+
+static 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? */
+ }
+
+ return code;
+}
+
+
+static IV PerlIOAPR_flush(PerlIO *f)
+{
+ PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
+
+ if ((apr_file_flush(st->file) == APR_SUCCESS)) {
+ return 0;
+ }
+ else {
+ return -1;
+ }
+}
+
+static 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;
+ }
+}
+
+static 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 apr_perlio_BOOT(pTHX)
+{
+ PerlIO_define_layer(aTHX_ &PerlIO_APR);
+}
+
+#endif /* PERLIO_LAYERS */
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/APR/PerlIO/apr_perlio.h Fri Dec 7 14:08:00 2001
@@ -0,0 +1,13 @@
+#ifndef APR_PERLIO_H
+#define APR_PERLIO_H
+
+#ifdef PERLIO_LAYERS
+
+#include "perliol.h"
+#include "apr_file_io.h"
+
+void modperl_perlio_init(pTHX);
+
+#endif /* PERLIO_LAYERS */
+
+#endif /* APR_PERLIO_H */
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/APR/PerlIO/Makefile.PL Fri Dec 7 13:45:32 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 Fri Dec 7 14:12:27 2001
@@ -0,0 +1,9 @@
+#include "mod_perl.h"
+#include "apr_perlio.h"
+
+MODULE = APR::PerlIO PACKAGE = APR::PerlIO
+
+PROTOTYPES: disabled
+
+BOOT:
+ apr_perlio_BOOT(aTHXo);
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/APR/PerlIO/PerlIO.pm Fri Dec 7 14:14:56 2001
@@ -0,0 +1,10 @@
+package APR::PerlIO;
+
+use APR (); # NOOP under modperl
+use XSLoader ();
+
+our $VERSION = '0.01';
+
+XSLoader::load(__PACKAGE__, $VERSION);
+
+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] PerlIO layer for APR
Posted by Doug MacEachern <do...@covalent.net>.
On Fri, 7 Dec 2001, Stas Bekman wrote:
cool! one major problem with the file layout/linking however.
neither perlio nor apr is tied to httpd, so the APR PerlIO layer shouldn't
be either. that is, it should be possible to use the APR PerlIO layer
outside of httpd. there's no need to use the .map stuff for this. you
can just create:
xs/APR/PerlIO
with:
apr_perlio.h - was modperl_perlio.h
apr_perlio.c - was modperl_perlio.c
PerlIO.xs - just has the BOOT section to add the layer
PerlIO.pm - use APR () and load PerlIO.so
Makefile.PL - ModPerl::MM::WriteMakefile(
NAME => 'APR::PerlIO',
VERSION_FROM => 'PerlIO.pm',
OBJECT => 'PerlIO.o apr_perlio.o');
when PerlIO.pm does 'use APR ()' it is a noop inside modperl and
outside loads libapr, libaprutil and takes care of
apr_initialize/apr_terminate.
> - currently cannot pass $r|$s via open :( using modperl_global_get_pconf
we can't do that. pconf can only be used at startup.
if builtin open doesn't support passing an APR::Pool reference, then we
need to have an APR::PerlIO::open that does.
another thing to consider is how to map apr_file_t's that are returned by
existing apache and apr functions. won't be able to use the builtin open
for those.
functions themselves look good, just a few style comments...
> +IV
> +PerlIOAPR_popped(PerlIO *f)
all of these functions should be static. and should also follow the
style where return type is on the same line as function name:
static IV PerlIOAPR_popped(...)
> +{
> + dTHX;
would be nice if we could "fix" Perl so dTHX is not needed for any of
these functions.
> + 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 :
> + }
should follow style of other switch statement in modperl.
> +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;
> + }
indenting off.
> + /* XXX: what's this for? */
> + PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
turns off buffering flags, dunno if it actually needs to.
> +PerlIO_funcs PerlIO_APR = {
this should be static too.
also TestUtil::apr_io should be TestAPR::perlio. and of course should be
skipped if perlio isn't available.
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org