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;
  
  
  


Reply via email to