stas 01/12/17 08:20:27
Added: t/response/TestAPR perlio.pm
xs/APR/PerlIO apr_perlio.c apr_perlio.h Makefile.PL
PerlIO.xs PerlIO.pm
Log:
- implements APR::PerlIO layer
- implements apr_file_t to APR::PerlIO conversion hooks (one way) (two
different sets for 5.6.1 and 5.7.2+)
- tests (conversion hooks are tested in Apache::SubProcess)
Revision Changes Path
1.1 modperl-2.0/t/response/TestAPR/perlio.pm
Index: perlio.pm
===================================================================
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 => 9, 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");
}
# 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;
1.1 modperl-2.0/xs/APR/PerlIO/apr_perlio.c
Index: apr_perlio.c
===================================================================
#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 /* 5.7.2+ */
/**********************************************************************
* The PerlIO APR layer.
* The 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 -1 workaround 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;
}
/* currrently read is very not-optimized, since in many cases the read
* process happens a char by char. Need to find a way to snoop on APR
* read buffer from PerlIO, or implement our own buffering layer here
*/
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 ***** */
/* ***** PerlIO <=> apr_file_t helper functions ***** */
PerlIO *apr_perlio_apr_file_to_PerlIO(pTHX_ apr_file_t *file,
apr_pool_t *pool, int type)
{
char *mode;
const char *layers = ":APR";
PerlIO *f = PerlIO_allocate(aTHX);
switch (type) {
case APR_PERLIO_HOOK_WRITE:
mode = "w";
break;
case APR_PERLIO_HOOK_READ:
mode = "r";
break;
default:
/* */
};
PerlIO_apply_layers(aTHX_ f, mode, layers);
if (f) {
PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
/* XXX: should we dup first? the timeout could close the fh! */
st->pool = pool;
st->file = file;
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
return f;
}
else {
return NULL;
}
}
/*
* type: APR_PERLIO_HOOK_READ | APR_PERLIO_HOOK_WRITE
*/
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),
type);
}
#else /* NOT PERLIO_LAYERS (5.6.1) */
FILE *apr_perlio_apr_file_to_FILE(pTHX_ apr_file_t *file, int type)
{
FILE *retval;
char *mode;
int fd;
apr_os_file_t os_file;
apr_status_t rc;
switch (type) {
case APR_PERLIO_HOOK_WRITE:
mode = "w";
break;
case APR_PERLIO_HOOK_READ:
mode = "r";
break;
default:
/* */
};
/* convert to the OS representation of file */
rc = apr_os_file_get(&os_file, file);
if (rc != APR_SUCCESS) {
croak("filedes retrieval failed!");
}
fd = PerlLIO_dup(os_file);
// Perl_warn(aTHX_ "fd old: %d, new %d\n", os_file, fd);
if (!(retval = PerlIO_fdopen(fd, mode))) {
PerlLIO_close(fd);
croak("fdopen failed!");
}
return retval;
}
/*
*
* type: APR_PERLIO_HOOK_READ | APR_PERLIO_HOOK_WRITE
*/
SV *apr_perlio_apr_file_to_glob(pTHX_ apr_file_t *file,
apr_pool_t *pool, 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)) = apr_perlio_apr_file_to_FILE(aTHX_ file, type);
IoFLAGS(GvIOp(gv)) |= IOf_FLUSH;
break;
case APR_PERLIO_HOOK_READ:
IoIFP(GvIOp(gv)) = apr_perlio_apr_file_to_FILE(aTHX_ file, type);
break;
default:
/* */
};
return sv_2mortal(retval);
}
void apr_perlio_init(pTHX)
{
APR_REGISTER_OPTIONAL_FN(apr_perlio_apr_file_to_glob);
}
#endif /* PERLIO_LAYERS */
1.1 modperl-2.0/xs/APR/PerlIO/apr_perlio.h
Index: apr_perlio.h
===================================================================
#ifndef APR_PERLIO_H
#define APR_PERLIO_H
#ifdef PERLIO_LAYERS
#include "perliol.h"
#else
#include "iperlsys.h"
#endif
#include "apr_portable.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
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
#ifdef PERLIO_LAYERS
PerlIO *apr_perlio_apr_file_to_PerlIO(pTHX_ apr_file_t *file,
apr_pool_t *pool, int type);
APR_DECLARE_OPTIONAL_FN(PerlIO *,
apr_perlio_apr_file_to_PerlIO,
(pTHX_ apr_file_t *file, apr_pool_t *pool, int type));
#endif /* PERLIO_LAYERS */
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 /* APR_PERLIO_H */
1.1 modperl-2.0/xs/APR/PerlIO/Makefile.PL
Index: Makefile.PL
===================================================================
use lib qw(../lib);
use ModPerl::MM ();
ModPerl::MM::WriteMakefile(
NAME => 'APR::PerlIO',
VERSION_FROM => 'PerlIO.pm',
OBJECT => 'PerlIO.o apr_perlio.o');
1.1 modperl-2.0/xs/APR/PerlIO/PerlIO.xs
Index: PerlIO.xs
===================================================================
#include "mod_perl.h"
#include "apr_perlio.h"
MODULE = APR::PerlIO PACKAGE = APR::PerlIO
PROTOTYPES: disabled
BOOT:
apr_perlio_init(aTHX);
1.1 modperl-2.0/xs/APR/PerlIO/PerlIO.pm
Index: PerlIO.pm
===================================================================
package APR::PerlIO;
require 5.6.1;
our $VERSION = '0.01';
use APR::XSLoader ();
APR::XSLoader::load __PACKAGE__;
# XXX: The PerlIO layer is available only since 5.8.0 (5.7.2 p13534)
1;
