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:[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]
