perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From s...@apache.org
Subject cvs commit: modperl-2.0 Changes
Date Wed, 20 Aug 2003 23:20:14 GMT
stas        2003/08/20 16:20:14

  Modified:    src/modules/perl mod_perl.c mod_perl.h modperl_io.c
                        modperl_io.h
               lib/ModPerl Code.pm
               xs/tables/current/ModPerl FunctionTable.pm
               .        Changes
  Added:       src/modules/perl modperl_io_apache.c modperl_io_apache.h
               t/modperl print_utf8.t
               t/response/TestModperl print_utf8.pm
  Log:
  when perl is built with perlio enabled (5.8+) the new PerlIO Apache
  layer is used, so now one can push layers onto STDIN, STDOUT handles
  e.g. binmode(STDOUT, ':utf8');
  
  Revision  Changes    Path
  1.179     +7 -5      modperl-2.0/src/modules/perl/mod_perl.c
  
  Index: mod_perl.c
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.c,v
  retrieving revision 1.178
  retrieving revision 1.179
  diff -u -r1.178 -r1.179
  --- mod_perl.c	19 Aug 2003 05:01:22 -0000	1.178
  +++ mod_perl.c	20 Aug 2003 23:20:14 -0000	1.179
  @@ -238,6 +238,8 @@
   
       modperl_hash_seed_set(aTHX);
   
  +    modperl_io_apache_init(aTHX);
  +
       PL_perl_destruct_level = 2;
   
       MP_boot_data_set(p, s);
  @@ -909,19 +911,19 @@
           modperl_global_request_set(r);
       }
   
  -    h_stdout = modperl_io_tie_stdout(aTHX_ r);
  -    h_stdin  = modperl_io_tie_stdin(aTHX_ r);
  +    h_stdin  = modperl_io_override_stdin(aTHX_ r);
  +    h_stdout = modperl_io_override_stdout(aTHX_ r);
   
       modperl_env_request_tie(aTHX_ r);
   
       retval = modperl_response_handler_run(r, FALSE);
   
  -    modperl_io_handle_untie(aTHX_ h_stdout);
  -    modperl_io_handle_untie(aTHX_ h_stdin);
  -
       modperl_env_request_untie(aTHX_ r);
   
       modperl_perl_global_request_restore(aTHX_ r);
  +
  +    modperl_io_restore_stdin(aTHX_ h_stdin);
  +    modperl_io_restore_stdout(aTHX_ h_stdout);
   
   #ifdef USE_ITHREADS
       if (MpInterpPUTBACK(interp)) {
  
  
  
  1.60      +1 -0      modperl-2.0/src/modules/perl/mod_perl.h
  
  Index: mod_perl.h
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.h,v
  retrieving revision 1.59
  retrieving revision 1.60
  diff -u -r1.59 -r1.60
  --- mod_perl.h	24 Apr 2003 01:51:37 -0000	1.59
  +++ mod_perl.h	20 Aug 2003 23:20:14 -0000	1.60
  @@ -59,6 +59,7 @@
   #include "modperl_options.h"
   #include "modperl_directives.h"
   #include "modperl_io.h"
  +#include "modperl_io_apache.h"
   #include "modperl_filter.h"
   #include "modperl_bucket.h"
   #include "modperl_pcw.h"
  
  
  
  1.10      +154 -40   modperl-2.0/src/modules/perl/modperl_io.c
  
  Index: modperl_io.c
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_io.c,v
  retrieving revision 1.9
  retrieving revision 1.10
  diff -u -r1.9 -r1.10
  --- modperl_io.c	22 Jan 2003 03:19:43 -0000	1.9
  +++ modperl_io.c	20 Aug 2003 23:20:14 -0000	1.10
  @@ -6,22 +6,6 @@
   #define TIED(handle) \
   modperl_io_handle_tied(aTHX_ handle, "Apache::RequestRec")
   
  -MP_INLINE void modperl_io_handle_untie(pTHX_ GV *handle)
  -{
  -#ifdef MP_TRACE
  -    if (mg_find(TIEHANDLE_SV(handle), 'q')) {
  -        MP_TRACE_g(MP_FUNC, "untie *%s(0x%lx), REFCNT=%d\n",
  -                   GvNAME(handle), (unsigned long)handle,
  -                   SvREFCNT(TIEHANDLE_SV(handle)));
  -    }
  -    else {
  -        return;
  -    }
  -#endif
  -
  -    sv_unmagic(TIEHANDLE_SV(handle), 'q');
  -}
  -
   MP_INLINE void modperl_io_handle_tie(pTHX_ GV *handle,
                                        char *classname, void *ptr)
   {
  @@ -38,29 +22,27 @@
                  SvREFCNT(TIEHANDLE_SV(handle)));
   }
   
  -MP_INLINE int modperl_io_handle_tied(pTHX_ GV *handle, char *classname)
  +MP_INLINE GV *modperl_io_tie_stdin(pTHX_ request_rec *r)
   {
  -    MAGIC *mg;
  -    SV *sv = TIEHANDLE_SV(handle);
  -
  -    if (SvMAGICAL(sv) && (mg = mg_find(sv, 'q'))) {
  -	char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj)));
  +#if defined(MP_IO_TIE_SFIO)
  +    /* XXX */
  +#else
  +    dHANDLE("STDIN");
   
  -	if (!strEQ(package, classname)) {
  -	    MP_TRACE_g(MP_FUNC, "%s tied to %s\n", GvNAME(handle), package);
  -	    return TRUE;
  -	}
  +    if (TIED(handle)) {
  +        return handle;
       }
   
  -    return FALSE;
  +    TIEHANDLE(handle, r);
  +
  +    return handle;
  +#endif
   }
   
   MP_INLINE GV *modperl_io_tie_stdout(pTHX_ request_rec *r)
   {
   #if defined(MP_IO_TIE_SFIO)
       /* XXX */
  -#elif defined(MP_IO_TIE_PERLIO)
  -    /* XXX */
   #else
       dHANDLE("STDOUT");
   
  @@ -76,21 +58,153 @@
   #endif
   }
   
  -MP_INLINE GV *modperl_io_tie_stdin(pTHX_ request_rec *r)
  +MP_INLINE int modperl_io_handle_tied(pTHX_ GV *handle, char *classname)
   {
  -#if defined(MP_IO_TIE_SFIO)
  -    /* XXX */
  -#elif defined(MP_IO_TIE_PERLIO)
  -    /* XXX */
  -#else
  -    dHANDLE("STDIN");
  +    MAGIC *mg;
  +    SV *sv = TIEHANDLE_SV(handle);
   
  -    if (TIED(handle)) {
  -        return handle;
  +    if (SvMAGICAL(sv) && (mg = mg_find(sv, 'q'))) {
  +	char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj)));
  +
  +	if (!strEQ(package, classname)) {
  +	    MP_TRACE_g(MP_FUNC, "%s tied to %s\n", GvNAME(handle), package);
  +	    return TRUE;
  +	}
       }
   
  -    TIEHANDLE(handle, r);
  +    return FALSE;
  +}
   
  -    return handle;
  +MP_INLINE void modperl_io_handle_untie(pTHX_ GV *handle)
  +{
  +#ifdef MP_TRACE
  +    if (mg_find(TIEHANDLE_SV(handle), 'q')) {
  +        MP_TRACE_g(MP_FUNC, "untie *%s(0x%lx), REFCNT=%d\n",
  +                   GvNAME(handle), (unsigned long)handle,
  +                   SvREFCNT(TIEHANDLE_SV(handle)));
  +    }
   #endif
  +
  +    sv_unmagic(TIEHANDLE_SV(handle), 'q');
  +}
  +
  +MP_INLINE GV *modperl_io_perlio_override_stdin(pTHX_ request_rec *r)
  +{
  +    dHANDLE("STDIN");
  +    int status;
  +    GV *handle_save = gv_fetchpv("STDIN_SAVED", TRUE, SVt_PVIO);
  +    SV *sv = sv_newmortal();
  +
  +    sv_setref_pv(sv, "Apache::RequestRec", (void*)r);
  +    MP_TRACE_o(MP_FUNC, "start");
  +
  +    /* open my $oldout, ">&STDIN" or die "Can't dup STDIN: $!"; */
  +    status = Perl_do_open(aTHX_ handle_save, ">&STDIN", 8, FALSE, O_RDONLY,
  +                          0, Nullfp);
  +    if (status == 0) {
  +        STRLEN n_a;
  +        Perl_croak(aTHX_ "Failed to dup STDIN: %s",
  +                   SvTRUE(ERRSV) ? SvPV(ERRSV, n_a) : "unknown error");
  +    }
  +
  +    /* similar to PerlIO::scalar, the PerlIO::Apache layer doesn't
  +     * have file descriptors, so STDOUT must be closed before it can
  +     * be reopened */
  +    Perl_do_close(aTHX_ handle, TRUE); 
  +    status = Perl_do_open9(aTHX_ handle, "<:Apache", 8, FALSE, O_RDONLY,
  +                           0, Nullfp, sv, 1);
  +    if (status == 0) {
  +        STRLEN n_a;
  +        Perl_croak(aTHX_ "Failed to open STDIN: %s",
  +                   SvTRUE(ERRSV) ? SvPV(ERRSV, n_a) : "unknown error");
  +    }
  +
  +    MP_TRACE_o(MP_FUNC, "end\n");
  +
  +    return handle_save;
  +}
  +
  +/* XXX: refactor to merge with the previous function */
  +MP_INLINE GV *modperl_io_perlio_override_stdout(pTHX_ request_rec *r)
  +{
  +    dHANDLE("STDOUT");
  +    int status;
  +    GV *handle_save = gv_fetchpv("STDOUT_SAVED", TRUE, SVt_PVIO);
  +    SV *sv = sv_newmortal();
  +
  +    MP_TRACE_o(MP_FUNC, "start");
  +
  +    sv_setref_pv(sv, "Apache::RequestRec", (void*)r);
  +
  +    /* open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!"; */
  +    status = Perl_do_open(aTHX_ handle_save, ">&STDOUT", 8, FALSE, O_RDONLY,
  +                          0, Nullfp);
  +    if (status == 0) {
  +        STRLEN n_a;
  +        Perl_croak(aTHX_ "Failed to dup STDOUT: %s",
  +                   SvTRUE(ERRSV) ? SvPV(ERRSV, n_a) : "unknown error");
  +    }
  +
  +    /* similar to PerlIO::scalar, the PerlIO::Apache layer doesn't
  +     * have file descriptors, so STDOUT must be closed before it can
  +     * be reopened */
  +    Perl_do_close(aTHX_ handle, TRUE); 
  +    status = Perl_do_open9(aTHX_ handle, ">:Apache", 8, FALSE, O_RDONLY,
  +                           0, Nullfp, sv, 1);
  +    if (status == 0) {
  +        STRLEN n_a;
  +        Perl_croak(aTHX_ "Failed to open STDOUT: %s",
  +                   SvTRUE(ERRSV) ? SvPV(ERRSV, n_a) : "unknown error");
  +    }
  +
  +    MP_TRACE_o(MP_FUNC, "end\n");
  +
  +    IoFLUSH_off(handle); /* STDOUT's $|=0 */
  +
  +    return handle_save;
  +    
  +}
  +
  +MP_INLINE void modperl_io_perlio_restore_stdin(pTHX_ GV *handle)
  +{
  +    GV *handle_orig = gv_fetchpv("STDIN", FALSE, SVt_PVIO);
  +    int status;
  +
  +    MP_TRACE_o(MP_FUNC, "start");
  +
  +    /* Perl_do_close(aTHX_ handle_orig, FALSE); */
  +
  +    /* open STDIN, ">&STDIN_SAVED" or die "Can't dup STDIN_SAVED: $!"; */
  +    status = Perl_do_open9(aTHX_ handle_orig, "<&", 2, FALSE, O_RDONLY,
  +                           0, Nullfp, (SV*)handle, 1);
  +    if (status == 0) {
  +        STRLEN n_a;
  +        Perl_croak(aTHX_ "Failed to restore STDIN: %s",
  +                   SvTRUE(ERRSV) ? SvPV(ERRSV, n_a) : "unknown error");
  +    }
  +
  +    IoFLUSH_off(handle); /* STDIN's $|=0 */
  +
  +    MP_TRACE_o(MP_FUNC, "end\n");
  +}
  +
  +MP_INLINE void modperl_io_perlio_restore_stdout(pTHX_ GV *handle)
  +{ 
  +    GV *handle_orig = gv_fetchpv("STDOUT", FALSE, SVt_PVIO);
  +    int status;
  +
  +    MP_TRACE_o(MP_FUNC, "start");
  +
  +    /* Perl_do_close(aTHX_ handle_orig, FALSE); */
  +
  +    /* open STDOUT, ">&STDOUT_SAVED" or die "Can't dup STDOUT_SAVED: $!"; */
  +    status = Perl_do_open9(aTHX_ handle_orig, ">&", 2, FALSE, O_RDONLY,
  +                           0, Nullfp, (SV*)handle, 1);
  +    if (status == 0) {
  +        STRLEN n_a;
  +        Perl_croak(aTHX_ "Failed to restore STDOUT: %s",
  +                   SvTRUE(ERRSV) ? SvPV(ERRSV, n_a) : "unknown error");
  +    }
  +
  +    MP_TRACE_o(MP_FUNC, "end\n");
   }
  
  
  
  1.3       +28 -4     modperl-2.0/src/modules/perl/modperl_io.h
  
  Index: modperl_io.h
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_io.h,v
  retrieving revision 1.2
  retrieving revision 1.3
  diff -u -r1.2 -r1.3
  --- modperl_io.h	22 Jan 2003 03:19:43 -0000	1.2
  +++ modperl_io.h	20 Aug 2003 23:20:14 -0000	1.3
  @@ -1,6 +1,8 @@
   #ifndef MODPERL_IO_H
   #define MODPERL_IO_H
   
  +#include "modperl_io_apache.h"
  +
   /*
    * bleedperl change #11639 switch tied handle magic
    * from living in the gv to the GvIOp(gv), so we have to deal
  @@ -23,15 +25,37 @@
   #define IoFLUSH(gv) \
   (IoFLAGS(GvIOp((gv))) & IOf_FLUSH)
   
  -MP_INLINE void modperl_io_handle_untie(pTHX_ GV *handle);
  -
   MP_INLINE void modperl_io_handle_tie(pTHX_ GV *handle,
                                        char *classname, void *ptr);
  +MP_INLINE GV *modperl_io_tie_stdout(pTHX_ request_rec *r);
  +
  +MP_INLINE GV *modperl_io_tie_stdin(pTHX_ request_rec *r);
   
   MP_INLINE int modperl_io_handle_tied(pTHX_ GV *handle, char *classname);
   
  -MP_INLINE GV *modperl_io_tie_stdout(pTHX_ request_rec *r);
  +MP_INLINE void modperl_io_handle_untie(pTHX_ GV *handle);
  +
  +MP_INLINE GV *modperl_io_perlio_override_stdin(pTHX_ request_rec *r);
  +
  +MP_INLINE GV *modperl_io_perlio_override_stdout(pTHX_ request_rec *r);
  +
  +MP_INLINE void modperl_io_perlio_restore_stdin(pTHX_ GV *handle);
  +
  +MP_INLINE void modperl_io_perlio_restore_stdout(pTHX_ GV *handle);
  +
  +#if defined(MP_IO_TIE_SFIO)
  +    /* XXX */
  +#elif defined(MP_IO_TIE_PERLIO)
  +#define modperl_io_override_stdin  modperl_io_perlio_override_stdin  
  +#define modperl_io_override_stdout modperl_io_perlio_override_stdout  
  +#define modperl_io_restore_stdin   modperl_io_perlio_restore_stdin  
  +#define modperl_io_restore_stdout  modperl_io_perlio_restore_stdout  
  +#else
  +#define modperl_io_override_stdin  modperl_io_tie_stdin  
  +#define modperl_io_override_stdout modperl_io_tie_stdout  
  +#define modperl_io_restore_stdin   modperl_io_handle_untie  
  +#define modperl_io_restore_stdout  modperl_io_handle_untie  
  +#endif
   
  -MP_INLINE GV *modperl_io_tie_stdin(pTHX_ request_rec *r);
   
   #endif /* MODPERL_IO_H */
  
  
  
  1.1                  modperl-2.0/src/modules/perl/modperl_io_apache.c
  
  Index: modperl_io_apache.c
  ===================================================================
  #include "mod_perl.h"
  
  #ifdef MP_IO_TIE_PERLIO
  
  /***************************
   * The PerlIO Apache layer *
   ***************************/
  
  /* PerlIO ":Apache" layer is used to use the Apache callbacks to read
   * from STDIN and write to STDOUT. The PerlIO API is documented in
   * perliol.pod */
  
  /*
   * 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;
      request_rec *r;
  } PerlIOApache;
  
  /* _open just allocates the layer, _pushed does the real job of
   * filling the data in */
  static PerlIO *
  PerlIOApache_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)
  {
      if (!f) {
          f = PerlIO_allocate(aTHX);
      }
      if ( (f = PerlIO_push(aTHX_ f, self, mode, args[0])) ) {
          PerlIOBase(f)->flags |= PERLIO_F_OPEN;
      }
  
      MP_TRACE_o(MP_FUNC, "mode %s", mode);
  
      return f;
  }
  
  /* this callback is used by pushed() and binmode() to add the layer */
  static IV
  PerlIOApache_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg,
  		    PerlIO_funcs *tab)
  {
      IV code;
      PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
  
      if (arg) {
          st->r = modperl_sv2request_rec(aTHX_ arg);
      }
      else {
          Perl_croak(aTHX_ "$r wasn't passed");
          /* XXX: try to get Apache->request? */
      }
      
      /* this method also sets the right flags according to the
       * 'mode' */
      code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
      
      MP_TRACE_o(MP_FUNC, "done");
      
      return code;
  }
  
  static IV
  PerlIOApache_fileno(pTHX_ PerlIO *f)
  {
      /* XXX: we could return STDIN => 0, STDOUT => 2, but that wouldn't
       * be correct, as the IO goes through the socket, may be we should
       * return the filedescriptor of the socket? 
       *
       * -1 in this case indicates that the layer cannot provide fileno
       */
      MP_TRACE_o(MP_FUNC, "did nothing");
      return -1;
  }
  
  
  /* XXX: FIXME */
  static MP_INLINE
  apr_status_t mpxs_setup_client_block(request_rec *r)
  {
      if (!r->read_length) {
          apr_status_t rc;
  
          /* only do this once per-request */
          if ((rc = ap_setup_client_block(r, REQUEST_CHUNKED_ERROR)) != OK) {
              ap_log_error(APLOG_MARK, APLOG_ERR, 0, r->server,
                           "mod_perl: ap_setup_client_block failed: %d", rc);
              return rc;
          }
      }
  
      return APR_SUCCESS;
  }
  
  #define mpxs_should_client_block(r) \
      (r->read_length || ap_should_client_block(r))
  
  static SSize_t
  PerlIOApache_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
  {
      PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
      request_rec *r = st->r;
      long total = 0;
      int rc;
  
      if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
          PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
  	return 0;
      }
      
      if ((rc = mpxs_setup_client_block(r)) != APR_SUCCESS) {
          return 0;
      }
  
      if (mpxs_should_client_block(r)) {
          total = ap_get_client_block(r, vbuf, count);
  
          MP_TRACE_o(MP_FUNC, "wanted %db, read %db [%s]",
                     count, total, (char *)vbuf);
  
          if (total < 0) {
              /*
               * XXX: as stated in ap_get_client_block, the real
               * error gets lots, so we only know that there was one
               */
              ap_log_error(APLOG_MARK, APLOG_ERR, 0, r->server,
                           "mod_perl: $r->read failed to read");
          }
      }
  
      return total;
  }
  
  static SSize_t
  PerlIOApache_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
  {
      PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
      modperl_config_req_t *rcfg = modperl_config_req_get(st->r);
      apr_size_t bytes = 0;
      apr_status_t rv;
  
      if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
  	return 0;
      }
      
      MP_CHECK_WBUCKET_INIT("print");
  
      MP_TRACE_o(MP_FUNC, "%d bytes [%s]", count, (char *)vbuf);
          
      rv = modperl_wbucket_write(aTHX_ rcfg->wbucket, vbuf, &count);
      if (rv != APR_SUCCESS) {
          Perl_croak(aTHX_ modperl_apr_strerror(rv)); 
      }
      bytes += count;
      
      return (SSize_t) bytes;
  }
  
  static IV
  PerlIOApache_flush(pTHX_ PerlIO *f)
  {
      PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
      modperl_config_req_t *rcfg = modperl_config_req_get(st->r);
  
      /* no flush on readonly io handle */
      if (! (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) ) {
          return -1;
      }
  
      MP_CHECK_WBUCKET_INIT("flush");
  
      MP_TRACE_o(MP_FUNC, "%d bytes [%s]", rcfg->wbucket->outcnt,
                 apr_pstrmemdup(rcfg->wbucket->pool, rcfg->wbucket->outbuf,
                                rcfg->wbucket->outcnt));
  
      MP_FAILURE_CROAK(modperl_wbucket_flush(rcfg->wbucket, FALSE));
  
      return 0;
  }
  
  /* 5.8.0 doesn't export PerlIOBase_noop_fail, so we duplicate it here */
  static IV PerlIOApache_noop_fail(pTHX_ PerlIO *f)
  {
      return -1;
  }
  
  static IV
  PerlIOApache_close(pTHX_ PerlIO *f)
  {
      /* XXX: just temp for tracing */
      MP_TRACE_o(MP_FUNC, "done");
      return PerlIOBase_close(aTHX_ f);
  }
  
  static IV
  PerlIOApache_popped(pTHX_ PerlIO *f)
  {
      /* XXX: just temp for tracing */
      MP_TRACE_o(MP_FUNC, "done");
      return PerlIOBase_popped(aTHX_ f);
  }
  
  
  static PerlIO_funcs PerlIO_Apache = {
      sizeof(PerlIO_funcs),
      "Apache",
      sizeof(PerlIOApache),
      PERLIO_K_MULTIARG,
      PerlIOApache_pushed,
      PerlIOApache_popped,
      PerlIOApache_open,
      PerlIOBase_binmode,
      NULL,                       /* no getarg needed */
      PerlIOApache_fileno,
      PerlIOBase_dup,
      PerlIOApache_read,
      PerlIOBase_unread,
      PerlIOApache_write,
      NULL,                       /* can't seek on STD{IN|OUT}, fail on call*/
      NULL,                       /* can't tell on STD{IN|OUT}, fail on call*/
      PerlIOApache_close,
      PerlIOApache_flush,        
      PerlIOApache_noop_fail,     /* fill */
      PerlIOBase_eof,
      PerlIOBase_error,
      PerlIOBase_clearerr,
      PerlIOBase_setlinebuf,
      NULL,                       /* get_base */
      NULL,                       /* get_bufsiz */
      NULL,                       /* get_ptr */
      NULL,                       /* get_cnt */
      NULL,                       /* set_ptrcnt */
  };
  
  /* ***** End of PerlIOApache tab ***** */
  
  MP_INLINE void modperl_io_apache_init(pTHX)
  {
      PerlIO_define_layer(aTHX_ &PerlIO_Apache);
  }
  
  #endif /* defined MP_IO_TIE_PERLIO */
  
  
  
  
  
  
  
  
  1.1                  modperl-2.0/src/modules/perl/modperl_io_apache.h
  
  Index: modperl_io_apache.h
  ===================================================================
  #ifndef MODPERL_IO_APACHE_H
  #define MODPERL_IO_APACHE_H
  
  #ifdef PERLIO_LAYERS
  
  #include "perliol.h"
  /* XXX: should this be a Makefile.PL config option? */
  #define MP_IO_TIE_PERLIO
  
  #include "apr_portable.h"
  #include "apr_file_io.h"
  #include "apr_errno.h"
  
  typedef enum {
      MODPERL_IO_APACHE_HOOK_READ,
      MODPERL_IO_APACHE_HOOK_WRITE
  } modperl_io_apache_hook_e;
  
  #define PERLIO_Apache_DEBUG
  
  MP_INLINE void modperl_io_apache_init(pTHX);
  
  #else /* #ifdef PERLIO_LAYERS */
  
  #define modperl_io_apache_init(pTHX)
  
  #endif /* #ifdef PERLIO_LAYERS */
      
  #endif /* MODPERL_IO_APACHE_H */
  
  
  
  1.1                  modperl-2.0/t/modperl/print_utf8.t
  
  Index: print_utf8.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestRequest;
  use Apache::TestUtil;
  
  # utf encode/decode was added only in 5.8.0
  # currently binmode is only available with perlio
  plan tests => 1, have have_min_perl_version(5.008), have_perl('perlio');
  
  #use bytes;
  #use utf8;
  
  my $location = "/TestModperl__print_utf8";
  
  my $received = GET_BODY_ASSERT $location;
  
  # the external stream already include wide-chars, but perl doesn't
  # know about it
  utf8::decode($received);
  
  binmode(STDOUT, ':utf8');
  
  
  my $expected = "Hello Ayhan \x{263A} perlio rules!";
  
  print "$expected\n";
  print "$received\n";
  
  #ok $expected eq $received;
  
  ok t_cmp($expected, $received, 'UTF8 encoding');
  
  
  
  
  1.1                  modperl-2.0/t/response/TestModperl/print_utf8.pm
  
  Index: print_utf8.pm
  ===================================================================
  package TestModperl::print_utf8;
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::RequestIO ();
  use Apache::RequestRec ();
  
  use Apache::Const -compile => 'OK';
  
  use utf8;
  
  sub handler {
      my $r = shift;
  
      $r->content_type('text/plain; charset=UTF-8');
  
      #Apache::RequestRec::BINMODE
      binmode(STDOUT, ':utf8');
  
      # must be non-$r->print(), so we go through the tied STDOUT
      print "Hello Ayhan \x{263A} perlio rules!";
  
      Apache::OK;
  }
  
  1;
  __DATA__
  # must test against a tied STDOUT
  SetHandler perl-script
  
  
  
  1.104     +2 -2      modperl-2.0/lib/ModPerl/Code.pm
  
  Index: Code.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/lib/ModPerl/Code.pm,v
  retrieving revision 1.103
  retrieving revision 1.104
  diff -u -r1.103 -r1.104
  --- Code.pm	19 Aug 2003 07:26:47 -0000	1.103
  +++ Code.pm	20 Aug 2003 23:20:14 -0000	1.104
  @@ -606,8 +606,8 @@
   );
   
   my @c_src_names = qw(interp tipool log config cmd options callback handler
  -                     gtop util io filter bucket mgv pcw global env cgi
  -                     perl perl_global perl_pp sys module svptr_table
  +                     gtop util io io_apache filter bucket mgv pcw global env
  +                     cgi perl perl_global perl_pp sys module svptr_table
                        const constants apache_compat);
   my @h_src_names = qw(perl_unembed);
   my @g_c_names = map { "modperl_$_" } qw(hooks directives flags xsinit);
  
  
  
  1.119     +81 -0     modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm
  
  Index: FunctionTable.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
  retrieving revision 1.118
  retrieving revision 1.119
  diff -u -r1.118 -r1.119
  --- FunctionTable.pm	11 Aug 2003 20:34:22 -0000	1.118
  +++ FunctionTable.pm	20 Aug 2003 23:20:14 -0000	1.119
  @@ -2783,6 +2783,40 @@
       ]
     },
     {
  +    'return_type' => 'void',
  +    'name' => 'modperl_io_perlio_restore_stdin',
  +    'attr' => [
  +      '__inline__'
  +    ],
  +    'args' => [
  +      {
  +        'type' => 'PerlInterpreter *',
  +        'name' => 'my_perl'
  +      },
  +      {
  +        'type' => 'GV *',
  +        'name' => 'handle'
  +      }
  +    ]
  +  },
  +  {
  +    'return_type' => 'void',
  +    'name' => 'modperl_io_perlio_restore_stdout',
  +    'attr' => [
  +      '__inline__'
  +    ],
  +    'args' => [
  +      {
  +        'type' => 'PerlInterpreter *',
  +        'name' => 'my_perl'
  +      },
  +      {
  +        'type' => 'GV *',
  +        'name' => 'handle'
  +      }
  +    ]
  +  },
  +  {
       'return_type' => 'GV *',
       'name' => 'modperl_io_tie_stdin',
       'attr' => [
  @@ -2814,6 +2848,53 @@
           'type' => 'request_rec *',
           'name' => 'r'
         }
  +    ]
  +  },
  +  {
  +    'return_type' => 'GV *',
  +    'name' => 'modperl_io_perlio_override_stdin',
  +    'attr' => [
  +      '__inline__'
  +    ],
  +    'args' => [
  +      {
  +        'type' => 'PerlInterpreter *',
  +        'name' => 'my_perl'
  +      },
  +      {
  +        'type' => 'request_rec *',
  +        'name' => 'r'
  +      }
  +    ]
  +  },
  +  {
  +    'return_type' => 'GV *',
  +    'name' => 'modperl_io_perlio_override_stdout',
  +    'attr' => [
  +      '__inline__'
  +    ],
  +    'args' => [
  +      {
  +        'type' => 'PerlInterpreter *',
  +        'name' => 'my_perl'
  +      },
  +      {
  +        'type' => 'request_rec *',
  +        'name' => 'r'
  +      }
  +    ]
  +  },
  +  {
  +    'return_type' => 'void',
  +    'name' => 'modperl_io_apache_init',
  +    'attr' => [
  +      '__inline__'
  +    ],
  +    'args' => [
  +      {
  +        'type' => 'PerlInterpreter *',
  +        'name' => 'my_perl'
  +      },
       ]
     },
     {
  
  
  
  1.209     +4 -0      modperl-2.0/Changes
  
  Index: Changes
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/Changes,v
  retrieving revision 1.208
  retrieving revision 1.209
  diff -u -r1.208 -r1.209
  --- Changes	11 Aug 2003 20:34:56 -0000	1.208
  +++ Changes	20 Aug 2003 23:20:14 -0000	1.209
  @@ -12,6 +12,10 @@
   
   =item 1.99_10-dev
   
  +when perl is built with perlio enabled (5.8+) the new PerlIO Apache
  +layer is used, so now one can push layers onto STDIN, STDOUT handles
  +e.g. binmode(STDOUT, ':utf8'); [Stas]
  +
   alter stacked handler interface so that mod_perl follows Apache 
   as closely as possible with respect to VOID/RUN_FIRST/RUN_ALL
   handler types.  now, for phases where OK ends the Apache
  
  
  

Mime
View raw message