/* Licensed to the Apache Software Foundation (ASF) under one or more
* contributor license agreements. See the NOTICE file distributed with
* this work for additional information regarding copyright ownership.
* The ASF licenses this file to You under the Apache License, Version 2.0
* (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
*/
#include "modperl_largefiles.h"
#include "mod_perl.h"
#include "modperl_apr_perlio.h"
#if defined(PERLIO_LAYERS) && defined(PERLIO_K_MULTIARG) /* 5.7.2+ */
/**********************************************************************
* The PerlIO APR layer.
* The PerlIO API is documented in perliol.pod.
**********************************************************************/
/*
* APR::PerlIO implements a PerlIO layer using apr_file_io as the core.
*/
/*
* XXX: Since we cannot snoop on the internal apr_file_io buffer
* currently the IO is not buffered on the Perl side so every read
* requests a char at a time, which is slow. Consider copying the
* relevant code from PerlIOBuf to implement our own buffer, similar
* to what PerlIOBuf does or push :perlio layer on top of this layer
*/
typedef struct {
struct _PerlIO base;
apr_file_t *file;
apr_pool_t *pool;
} PerlIOAPR;
static IV PerlIOAPR_pushed(pTHX_ PerlIO *f, const char *mode,
SV *arg, PerlIO_funcs *tab)
{
IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
if (*PerlIONext(f)) {
/* XXX: not sure if we can do anything here, but see
* PerlIOUnix_pushed for things that it does
*/
}
return code;
}
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)
{
SV *arg = (narg > 0) ? *args : PerlIOArg;
PerlIOAPR *st;
const char *path;
apr_int32_t apr_flag;
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;
default:
Perl_croak(aTHX_ "unknown open mode: %s", mode);
}
/* APR_BINARY: we always do binary read and PerlIO is supposed
* to handle :crlf if any (by pushing this layer at
* open().
* APR_BUFFERED: XXX, not sure if it'll be needed if we will push
* :perlio (== PerlIOBuf) layer on top
*/
apr_flag |= APR_BUFFERED | APR_BINARY;
st = PerlIOSelf(f, PerlIOAPR);
/* XXX: can't reuse a wrapper mp_xs_sv2_APR__Pool */
/* XXX: should probably add checks on pool validity in all other callbacks */
sv = args[narg-1];
if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG)) {
st->pool = INT2PTR(apr_pool_t *, SvIV((SV*)SvRV(sv)));
}
else {
Perl_croak(aTHX_ "argument is not a blessed reference "
"(expecting an APR::Pool derived object)");
}
rc = apr_file_open(&st->file, path, apr_flag, APR_OS_DEFAULT, st->pool);
MP_TRACE_o(MP_FUNC, "obj=0x%lx, file=0x%lx, name=%s, rc=%d",
(unsigned long)f, (unsigned long)st->file,
path ? path : "(UNKNOWN)", rc);
if (rc != APR_SUCCESS) {
/* it just so happens that since $! is tied to errno, we get
* it set right via the system call that apr_file_open has
* performed internally, no need to do anything special */
PerlIO_pop(aTHX_ f);
return NULL;
}
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
return f;
}
static IV PerlIOAPR_fileno(pTHX_ PerlIO *f)
{
/* apr_file_t* is an opaque struct, so fileno is not available.
* -1 in this case indicates that the layer cannot provide fileno
*/
return -1;
}
static PerlIO *PerlIOAPR_dup(pTHX_ PerlIO *f, PerlIO *o,
CLONE_PARAMS *param, int flags)
{
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);
MP_TRACE_o(MP_FUNC, "obj=0x%lx, "
"file=0x%lx => 0x%lx, rc=%d",
(unsigned long)f, (unsigned long)ost->file,
(unsigned long)fst->file, rc);
if (rc == APR_SUCCESS) {
fst->pool = ost->pool;
return f;
}
}
return NULL;
}
static SSize_t PerlIOAPR_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
apr_status_t rc;
rc = apr_file_read(st->file, vbuf, &count);
MP_TRACE_o(MP_FUNC, "%db [%s]", (int)count,
MP_TRACE_STR_TRUNC(st->pool, (char *)vbuf, (int)count));
if (rc == APR_EOF) {
PerlIOBase(f)->flags |= PERLIO_F_EOF;
return count;
}
else if (rc != APR_SUCCESS) {
modperl_croak(aTHX_ rc, "APR::PerlIO::read");
}
return count;
}
static SSize_t PerlIOAPR_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
apr_status_t rc;
MP_TRACE_o(MP_FUNC, "%db [%s]", (int)count,
MP_TRACE_STR_TRUNC(st->pool, (char *)vbuf, (int)count));
rc = apr_file_write(st->file, vbuf, &count);
if (rc == APR_SUCCESS) {
return (SSize_t) count;
}
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
return (SSize_t) -1;
}
static IV PerlIOAPR_flush(pTHX_ PerlIO *f)
{
PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
apr_status_t rc;
rc = apr_file_flush(st->file);
if (rc == APR_SUCCESS) {
return 0;
}
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
return -1;
}
static IV PerlIOAPR_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
{
PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
apr_seek_where_t where;
apr_status_t rc;
apr_off_t seek_offset = 0;
#ifdef MP_LARGE_FILES_CONFLICT
if (offset != 0) {
Perl_croak(aTHX_ "PerlIO::APR::seek with non-zero offset"
"is not supported with Perl built w/ -Duselargefiles"
" and APR w/o largefiles support");
}
#else
seek_offset = offset;
#endif
/* Flush the fill buffer */
if (PerlIO_flush(f) != 0) {
return -1;
}
switch(whence) {
case 0:
where = APR_SET;
break;
case 1:
where = APR_CUR;
break;
case 2:
where = APR_END;
break;
default:
Perl_croak(aTHX_ "unknown whence mode: %d", whence);
}
rc = apr_file_seek(st->file, where, &seek_offset);
if (rc == APR_SUCCESS) {
return 0;
}
return -1;
}
static Off_t PerlIOAPR_tell(pTHX_ PerlIO *f)
{
PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
apr_off_t offset = 0;
apr_status_t rc;
rc = apr_file_seek(st->file, APR_CUR, &offset);
if (rc == APR_SUCCESS) {
return (Off_t) offset;
}
return (Off_t) -1;
}
static IV PerlIOAPR_close(pTHX_ PerlIO *f)
{
PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
IV code = PerlIOBase_close(aTHX_ f);
apr_status_t rc;
#ifdef MP_TRACE
const char *new_path = NULL;
apr_os_file_t os_file;
#ifdef PERL_PHASE_DESTRUCT
if (PL_phase != PERL_PHASE_DESTRUCT) {
#else
if (!PL_dirty) {
#endif
/* if this is called during perl_destruct we are in trouble */
apr_file_name_get(&new_path, st->file);
}
rc = apr_os_file_get(&os_file, st->file);
if (rc != APR_SUCCESS) {
Perl_croak(aTHX_ "filedes retrieval failed!");
}
MP_TRACE_o(MP_FUNC, "obj=0x%lx, file=0x%lx, fd=%d, name=%s",
(unsigned long)f, (unsigned long)st->file, os_file,
new_path ? new_path : "(UNKNOWN)");
#endif
#ifdef PERL_PHASE_DESTRUCT
if (PL_phase == PERL_PHASE_DESTRUCT) {
#else
if (PL_dirty) {
#endif
/* there should not be any PerlIOAPR handles open
* during perl_destruct
*/
Perl_warn(aTHX_ "leaked PerlIOAPR handle 0x%lx",
(unsigned long)f);
return -1;
}
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;
}
#if 0 /* we may use it if the buffering will be done at this layer */
static IV PerlIOAPR_fill(pTHX_ PerlIO *f)
{
PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
apr_status_t rc;
SSize_t avail;
Size_t count = st->base.bufsiz;
if (!st->base.buf) {
PerlIO_get_base(f); /* allocate via vtable */
}
MP_TRACE_o(MP_FUNC, "asked to fill %d chars", count);
rc = apr_file_read(st->file, st->base.ptr, &count);
if (rc != APR_SUCCESS) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
return -1;
}
MP_TRACE_o(MP_FUNC, "got to fill %d chars", count);
avail = count; /* apr_file_read() sets how many chars were read in count */
if (avail <= 0) {
if (avail == 0) {
PerlIOBase(f)->flags |= PERLIO_F_EOF;
}
else {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
}
return -1;
}
st->base.end = st->base.buf + avail;
/* indicate that the buffer this layer currently holds unconsumed
data read from layer below. */
PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
return 0;
}
#endif
static IV PerlIOAPR_eof(pTHX_ PerlIO *f)
{
PerlIOAPR *st = PerlIOSelf(f, PerlIOAPR);
apr_status_t rc;
rc = apr_file_eof(st->file);
switch (rc) {
case APR_EOF:
return 1;
default:
return 0;
}
return -1;
}
/* 5.8.0 doesn't export PerlIOBase_noop_fail, so we duplicate it here */
static IV PerlIOAPR_noop_fail(pTHX_ PerlIO *f)
{
return -1;
}
static PerlIO_funcs PerlIO_APR = {
sizeof(PerlIO_funcs),
"APR",
sizeof(PerlIOAPR),
PERLIO_K_MULTIARG | PERLIO_K_RAW,
PerlIOAPR_pushed,
PerlIOBase_popped,
PerlIOAPR_open,
PerlIOBase_binmode, /* binmode() is handled by :crlf */
NULL, /* no getarg needed */
PerlIOAPR_fileno,
PerlIOAPR_dup,
PerlIOAPR_read,
PerlIOBase_unread,
PerlIOAPR_write,
PerlIOAPR_seek,
PerlIOAPR_tell,
PerlIOAPR_close,
PerlIOAPR_flush, /* flush */
PerlIOAPR_noop_fail, /* fill */
PerlIOAPR_eof,
PerlIOBase_error,
PerlIOBase_clearerr,
PerlIOBase_setlinebuf,
NULL, /* get_base */
NULL, /* get_bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL, /* set_ptrcnt */
};
void modperl_apr_perlio_init(pTHX)
{
APR_REGISTER_OPTIONAL_FN(modperl_apr_perlio_apr_file_to_PerlIO);
APR_REGISTER_OPTIONAL_FN(modperl_apr_perlio_apr_file_to_glob);
PerlIO_define_layer(aTHX_ &PerlIO_APR);
}
/* ***** End of PerlIOAPR tab ***** */
/* ***** PerlIO <=> apr_file_t helper functions ***** */
PerlIO *modperl_apr_perlio_apr_file_to_PerlIO(pTHX_ apr_file_t *file,
apr_pool_t *pool,
modperl_apr_perlio_hook_e type)
{
char *mode;
const char *layers = ":APR";
PerlIOAPR *st;
PerlIO *f = PerlIO_allocate(aTHX);
if (!f) {
Perl_croak(aTHX_ "Failed to allocate PerlIO struct");
}
switch (type) {
case MODPERL_APR_PERLIO_HOOK_WRITE:
mode = "w";
break;
case MODPERL_APR_PERLIO_HOOK_READ:
mode = "r";
break;
default:
Perl_croak(aTHX_ "unknown MODPERL_APR_PERLIO type: %d", type);
};
PerlIO_apply_layers(aTHX_ f, mode, layers);
if (!f) {
Perl_croak(aTHX_ "Failed to apply the ':APR' layer");
}
st = PerlIOSelf(f, PerlIOAPR);
#ifdef MP_TRACE
{
apr_status_t rc;
apr_os_file_t os_file;
/* convert to the OS representation of file */
rc = apr_os_file_get(&os_file, file);
if (rc != APR_SUCCESS) {
croak("filedes retrieval failed!");
}
MP_TRACE_o(MP_FUNC, "converting to PerlIO fd %d, mode '%s'",
os_file, mode);
}
#endif
st->pool = pool;
st->file = file;
PerlIOBase(f)->flags |= PERLIO_F_OPEN;
return f;
}
static SV *modperl_apr_perlio_PerlIO_to_glob(pTHX_ PerlIO *pio,
modperl_apr_perlio_hook_e type)
{
SV *retval = modperl_perl_gensym(aTHX_ "APR::PerlIO");
GV *gv = (GV*)SvRV(retval);
gv_IOadd(gv);
switch (type) {
case MODPERL_APR_PERLIO_HOOK_WRITE:
/* if IoIFP() is not assigned to it'll be never closed, see
* Perl_io_close() */
IoIFP(GvIOp(gv)) = IoOFP(GvIOp(gv)) = pio;
IoFLAGS(GvIOp(gv)) |= IOf_FLUSH;
IoTYPE(GvIOp(gv)) = IoTYPE_WRONLY;
break;
case MODPERL_APR_PERLIO_HOOK_READ:
IoIFP(GvIOp(gv)) = pio;
IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
break;
};
return sv_2mortal(retval);
}
SV *modperl_apr_perlio_apr_file_to_glob(pTHX_ apr_file_t *file,
apr_pool_t *pool,
modperl_apr_perlio_hook_e type)
{
return modperl_apr_perlio_PerlIO_to_glob(aTHX_
modperl_apr_perlio_apr_file_to_PerlIO(aTHX_ file, pool, type),
type);
}
#else /* defined(PERLIO_LAYERS) (5.6.x) */
#ifdef USE_PERLIO /* 5.6.x + -Duseperlio */
#define MP_IO_TYPE PerlIO
#else
#define MP_IO_TYPE FILE
#endif
static MP_IO_TYPE *modperl_apr_perlio_apr_file_to_PerlIO(pTHX_ apr_file_t *file,
modperl_apr_perlio_hook_e type)
{
MP_IO_TYPE *retval;
char *mode;
int fd;
apr_os_file_t os_file;
apr_status_t rc;
switch (type) {
case MODPERL_APR_PERLIO_HOOK_WRITE:
mode = "w";
break;
case MODPERL_APR_PERLIO_HOOK_READ:
mode = "r";
break;
};
/* convert to the OS representation of file */
rc = apr_os_file_get(&os_file, file);
if (rc != APR_SUCCESS) {
Perl_croak(aTHX_ "filedes retrieval failed!");
}
MP_TRACE_o(MP_FUNC, "converting fd %d", os_file);
/* let's try without the dup, it seems to work fine:
fd = PerlLIO_dup(os_file);
MP_TRACE_o(MP_FUNC, "fd old: %d, new %d", os_file, fd);
if (!(retval = PerlIO_fdopen(fd, mode))) {
...
}
in any case if we later decide to dup, remember to:
apr_file_close(file);
after PerlIO_fdopen() or that fh will be leaked
*/
if (!(retval = PerlIO_fdopen(os_file, mode))) {
PerlLIO_close(fd);
Perl_croak(aTHX_ "fdopen failed!");
}
return retval;
}
SV *modperl_apr_perlio_apr_file_to_glob(pTHX_ apr_file_t *file,
apr_pool_t *pool,
modperl_apr_perlio_hook_e type)
{
SV *retval = modperl_perl_gensym(aTHX_ "APR::PerlIO");
GV *gv = (GV*)SvRV(retval);
gv_IOadd(gv);
switch (type) {
case MODPERL_APR_PERLIO_HOOK_WRITE:
IoIFP(GvIOp(gv)) = IoOFP(GvIOp(gv)) =
modperl_apr_perlio_apr_file_to_PerlIO(aTHX_ file, type);
IoFLAGS(GvIOp(gv)) |= IOf_FLUSH;
IoTYPE(GvIOp(gv)) = IoTYPE_WRONLY;
break;
case MODPERL_APR_PERLIO_HOOK_READ:
IoIFP(GvIOp(gv)) = modperl_apr_perlio_apr_file_to_PerlIO(aTHX_ file,
type);
IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
break;
};
return sv_2mortal(retval);
}
void modperl_apr_perlio_init(pTHX)
{
APR_REGISTER_OPTIONAL_FN(modperl_apr_perlio_apr_file_to_glob);
}
#endif /* PERLIO_LAYERS */
/*
* Local Variables:
* c-basic-offset: 4
* indent-tabs-mode: nil
* End:
*/