| /* 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: |
| */ |
