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
