stas 2003/08/29 19:33:26
Modified: lib/Apache compat.pm
lib/ModPerl WrapXS.pm
src/modules/perl modperl_util.c modperl_util.h
xs/Apache/RequestUtil Apache__RequestUtil.h
xs/maps modperl_functions.map
xs/tables/current/ModPerl FunctionTable.pm
. Changes
Added: t/api slurp_filename.t
t/response/TestAPI slurp_filename.pm
t/htdocs/api slurp.pl
Log:
$r->slurp_filename is now implemented in C
Revision Changes Path
1.88 +0 -9 modperl-2.0/lib/Apache/compat.pm
Index: compat.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/Apache/compat.pm,v
retrieving revision 1.87
retrieving revision 1.88
diff -u -u -r1.87 -r1.88
--- compat.pm 5 Aug 2003 16:00:24 -0000 1.87
+++ compat.pm 30 Aug 2003 02:33:26 -0000 1.88
@@ -345,15 +345,6 @@
*log_reason = \&log_error;
-sub slurp_filename {
- my $r = shift;
- open my $fh, $r->filename;
- local $/;
- my $data = <$fh>;
- close $fh;
- return \$data;
-}
-
#XXX: would like to have a proper implementation
#that reads line-by-line as defined by $/
#the best way will probably be to use perlio in 5.8.0
1.61 +0 -2 modperl-2.0/lib/ModPerl/WrapXS.pm
Index: WrapXS.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/WrapXS.pm,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -u -r1.60 -r1.61
--- WrapXS.pm 8 Aug 2003 20:35:44 -0000 1.60
+++ WrapXS.pm 30 Aug 2003 02:33:26 -0000 1.61
@@ -726,8 +726,6 @@
'not in the Apache 2.0 API'],
log_reason => ['log_error',
'not in the Apache 2.0 API'],
- slurp_filename => [undef,
- 'not in the mod_perl 2.0 API'],
READLINE => [undef, # XXX: to be resolved
''],
send_fd_length => [undef,
1.52 +51 -0 modperl-2.0/src/modules/perl/modperl_util.c
Index: modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -u -r1.51 -r1.52
--- modperl_util.c 4 Mar 2003 09:42:42 -0000 1.51
+++ modperl_util.c 30 Aug 2003 02:33:26 -0000 1.52
@@ -668,3 +668,54 @@
}
}
}
+
+#define SLURP_SUCCESS(action) \
+ if (rc != APR_SUCCESS) { \
+ SvREFCNT_dec(sv); \
+ Perl_croak(aTHX_ "Error " action " '%s': %s ", r->filename, \
+ modperl_apr_strerror(rc)); \
+ }
+
+MP_INLINE SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted)
+{
+ SV *sv;
+ apr_status_t rc;
+ apr_size_t size;
+ apr_file_t *file;
+
+ size = r->finfo.size;
+ sv = newSV(size);
+ file = r->finfo.filehand;
+ if (!file) {
+ rc = apr_file_open(&file, r->filename, APR_READ|APR_BINARY,
+ APR_OS_DEFAULT, r->pool);
+ SLURP_SUCCESS("opening");
+ }
+
+ rc = apr_file_read(file, SvPVX(sv), &size);
+ SLURP_SUCCESS("reading");
+
+ MP_TRACE_o(MP_FUNC, "read %d bytes from '%s'\n", size, r->filename);
+
+ if (r->finfo.size != size) {
+ SvREFCNT_dec(sv);
+ Perl_croak(aTHX_ "Error: read %d bytes, expected %d ('%s')",
+ size, r->finfo.size, r->filename);
+ }
+
+ rc = apr_file_close(file);
+ SLURP_SUCCESS("closing");
+
+ SvPVX(sv)[size] = '\0';
+ SvCUR_set(sv, size);
+ SvPOK_on(sv);
+
+ if (tainted) {
+ SvTAINTED_on(sv);
+ }
+ else {
+ SvTAINTED_off(sv);
+ }
+
+ return newRV_noinc(sv);
+}
1.46 +8 -0 modperl-2.0/src/modules/perl/modperl_util.h
Index: modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -u -r1.45 -r1.46
--- modperl_util.h 20 Aug 2003 23:11:23 -0000 1.45
+++ modperl_util.h 30 Aug 2003 02:33:26 -0000 1.46
@@ -141,6 +141,14 @@
MP_INLINE int modperl_perl_module_loaded(pTHX_ const char *name);
+/**
+ * slurp the contents of r->filename and return them as a scalar
+ * @param r request record
+ * @param tainted whether the SV should be marked tainted or not
+ * @return a PV scalar with the contents of the file
+ */
+SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted);
+
SV *modperl_perl_gensym(pTHX_ char *pack);
void modperl_clear_symtab(pTHX_ HV *symtab);
1.18 +3 -0 modperl-2.0/xs/Apache/RequestUtil/Apache__RequestUtil.h
Index: Apache__RequestUtil.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/Apache/RequestUtil/Apache__RequestUtil.h,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -u -r1.17 -r1.18
--- Apache__RequestUtil.h 31 Jan 2003 04:20:20 -0000 1.17
+++ Apache__RequestUtil.h 30 Aug 2003 02:33:26 -0000 1.18
@@ -197,6 +197,9 @@
#define mpxs_Apache__RequestRec_dir_config(r, key, sv_val) \
modperl_dir_config(aTHX_ r, r->server, key, sv_val)
+#define mpxs_Apache__RequestRec_slurp_filename(r, tainted) \
+ modperl_slurp_filename(aTHX_ r, tainted)
+
static MP_INLINE
char *mpxs_Apache__RequestRec_location(request_rec *r)
{
1.58 +2 -0 modperl-2.0/xs/maps/modperl_functions.map
Index: modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -u -r1.57 -r1.58
--- modperl_functions.map 30 May 2003 12:55:14 -0000 1.57
+++ modperl_functions.map 30 Aug 2003 02:33:26 -0000 1.58
@@ -33,6 +33,8 @@
PACKAGE=Apache::RequestRec
mpxs_Apache__RequestRec_new | | classname, c, base_pool=NULL
SV *:DEFINE_dir_config | | request_rec *:r, char *:key=NULL, SV *:sv_val=Nullsv
+ SV *:DEFINE_slurp_filename | | request_rec *:r, int:tainted=1
+
PACKAGE=Apache
mpxs_Apache_request | | classname, svr=Nullsv
1.121 +21 -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.120
retrieving revision 1.121
diff -u -u -r1.120 -r1.121
--- FunctionTable.pm 28 Aug 2003 18:33:32 -0000 1.120
+++ FunctionTable.pm 30 Aug 2003 02:33:26 -0000 1.121
@@ -1569,6 +1569,27 @@
]
},
{
+ 'return_type' => 'SV *',
+ 'name' => 'modperl_slurp_filename',
+ 'attr' => [
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'request_rec *',
+ 'name' => 'r'
+ },
+ {
+ 'type' => 'int',
+ 'name' => 'tainted'
+ },
+ ]
+ },
+ {
'return_type' => 'void',
'name' => 'modperl_env_clear',
'args' => [
1.213 +2 -0 modperl-2.0/Changes
Index: Changes
===================================================================
RCS file: /home/cvs/modperl-2.0/Changes,v
retrieving revision 1.212
retrieving revision 1.213
diff -u -u -r1.212 -r1.213
--- Changes 22 Aug 2003 19:18:03 -0000 1.212
+++ Changes 30 Aug 2003 02:33:26 -0000 1.213
@@ -12,6 +12,8 @@
=item 1.99_10-dev
+$r->slurp_filename is now implemented in C. [Stas]
+
remove support for httpd 2.0.45/apr 0.9.3 and lower.
httpd 2.0.46 is now the minimum supported version.
[Geoffrey Young]
1.1 modperl-2.0/t/api/slurp_filename.t
Index: slurp_filename.t
===================================================================
use Apache::TestRequest 'GET_BODY_ASSERT';
# we want r->filename to be "/slurp/slurp.pl", even though the
# response handler is TestAPI::slurp_filename
print GET_BODY_ASSERT "/slurp/slurp.pl";
1.1 modperl-2.0/t/response/TestAPI/slurp_filename.pm
Index: slurp_filename.pm
===================================================================
package TestAPI::slurp_filename;
# test slurp_filename()'s taintness options and the that it works properly with utf8
data
use strict;
use warnings FATAL => 'all';
no warnings 'redefine';
use diagnostics;
use Apache::Test;
use Apache::TestUtil;
use Apache::RequestUtil ();
use ModPerl::Util;
use Apache::Const -compile => 'OK';
my $expected = <<EOI;
English: Internet
Hebrew : \x{05D0}\x{05D9}\x{05E0}\x{05D8}\x{05E8}\x{05E0}\x{05D8}
EOI
sub handler {
my $r = shift;
plan $r, tests => 5;
{
my $data = $r->slurp_filename(0); # untainted
my $received = eval $$data;
ok t_cmp($expected, $received, "slurp filename untainted");
}
{
my $data = $r->slurp_filename; # tainted
my $received;
eval { $received = eval $$data };
ok t_cmp(qr/Insecure dependency in eval/, $@, "slurp filename tainted");
ModPerl::Util::untaint($$data);
$received = eval $$data;
ok t_cmp($expected, $received, "slurp filename untainted");
}
{
# just in case we will encounter some probs in the future,
# here is pure perl function for comparison
my $data = slurp_filename_perl($r); # tainted
my $received;
eval { $received = eval $$data };
ok t_cmp(qr/Insecure dependency in eval/, $@, "slurp filename (perl)
tainted");
ModPerl::Util::untaint($$data);
$received = eval $$data;
ok t_cmp($expected, $received, "slurp filename (perl) untainted");
}
Apache::OK;
}
sub slurp_filename_perl {
my $r = shift;
open my $fh, $r->filename;
local $/;
my $data = <$fh>;
close $fh;
return \$data;
}
1;
__END__
<NoAutoConfig>
Alias /slurp/ @DocumentRoot@/api/
<Location /slurp/>
SetHandler modperl
PerlResponseHandler TestAPI::slurp_filename
</Location>
</NoAutoConfig>
1.1 modperl-2.0/t/htdocs/api/slurp.pl
Index: slurp.pl
===================================================================
my $z = <<EOI;
English: Internet
Hebrew : \x{05D0}\x{05D9}\x{05E0}\x{05D8}\x{05E8}\x{05E0}\x{05D8}
EOI
$z;
