You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by do...@hyperreal.org on 1998/05/05 01:52:59 UTC
cvs commit: modperl/t/modules cgi.t
dougm 98/05/04 16:52:59
Modified: . Changes MANIFEST Makefile.PL
Apache Apache.pm
src/modules/perl Apache.xs mod_perl.h
t/modules cgi.t
Log:
$r->read_client_block is deprecated
re-implemented $r->read to properly use *client_block methods and call
reset_timeout after each read in the loop
added setup_client_block, should_client_block and get_client_block
methods
modules/cgi test will attempt a fileupload of perlfunc.pod to
file_upload.cgi if HTTP::Request::Common is installed
(libwww-perl-5.09+) and $CGI::VERSION >= 2.39
Revision Changes Path
1.26 +12 -0 modperl/Changes
Index: Changes
===================================================================
RCS file: /export/home/cvs/modperl/Changes,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- Changes 1998/05/04 11:38:06 1.25
+++ Changes 1998/05/04 23:52:54 1.26
@@ -18,6 +18,18 @@
=item 1.11_01-dev
+$r->read_client_block is deprecated
+
+re-implemented $r->read to properly use *client_block methods and call
+reset_timeout after each read in the loop
+
+added setup_client_block, should_client_block and get_client_block
+methods
+
+modules/cgi test will attempt a fileupload of perlfunc.pod to
+file_upload.cgi if HTTP::Request::Common is installed
+(libwww-perl-5.09+) and $CGI::VERSION >= 2.39
+
make $r->connection->aborted work as documented again, thanks to spot
by Jens Heunemann
1.11 +1 -0 modperl/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /export/home/cvs/modperl/MANIFEST,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- MANIFEST 1998/04/26 00:32:15 1.10
+++ MANIFEST 1998/05/04 23:52:54 1.11
@@ -93,6 +93,7 @@
t/internal/stacked.t
#t/internal/resolver.t
t/internal/taint.t
+t/net/perl/file_upload.cgi
t/net/perl/qredirect.pl
t/net/perl/hooks.pl
t/net/perl/action.pl
1.22 +6 -1 modperl/Makefile.PL
Index: Makefile.PL
===================================================================
RCS file: /export/home/cvs/modperl/Makefile.PL,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- Makefile.PL 1998/04/28 02:26:19 1.21
+++ Makefile.PL 1998/05/04 23:52:55 1.22
@@ -758,7 +758,12 @@
if($ENV{TEST_PERL_DIRECTIVES}) {
#push @DIR, 't/TestDirectives';
- system "(cd t/TestDirectives && $^X Makefile.PL)";
+ if($ENV{USER} eq "dougm" and $Config{usethreads} eq "define") {
+ delete $ENV{TEST_PERL_DIRECTIVES};
+ }
+ else {
+ system "(cd t/TestDirectives && $^X Makefile.PL)";
+ }
}
WriteMakefile(
1.6 +21 -9 modperl/Apache/Apache.pm
Index: Apache.pm
===================================================================
RCS file: /export/home/cvs/modperl/Apache/Apache.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- Apache.pm 1998/03/19 23:08:27 1.5
+++ Apache.pm 1998/05/04 23:52:56 1.6
@@ -76,15 +76,33 @@
$_[1] ||= "";
#$_[1] = " " x $bufsiz unless defined $_[1]; #XXX?
- $r->hard_timeout("Apache->read");
+ if(my $rv = $r->setup_client_block) {
+ $r->log_error("Apache->read: setup_client_block returned $rv");
+ die $rv;
+ }
+
+ #XXX: must set r->read_length to 0 here,
+ #since this read() method may be called in loop
+ #in which case, the second time in, should_client_block()
+ #thinks we've already read the request body and returns 0
+ $r->read_length(0);
+
+ unless($r->should_client_block) {
+ my $rl = $r->read_length;
+ $r->log_error("Apache->read: should_client_block returned 0 (rl=$rl)");
+ return 0;
+ }
+ $r->hard_timeout("Apache->read");
+
while($bufsiz) {
- $nrd = $r->read_client_block($buf, $bufsiz) || 0;
+ $nrd = $r->get_client_block($buf, $bufsiz) || 0;
if(defined $nrd and $nrd > 0) {
$bufsiz -= $nrd;
$_[1] .= $buf;
#substr($_[1], $total, $nrd) = $buf;
$total += $nrd;
+ $r->reset_timeout;
next if $bufsiz;
last;
}
@@ -386,15 +404,9 @@
I<value> pairs are returned. *NOTE*: you can only ask for this once,
as the entire body is read from the client.
-=item $r->read_client_block($buf, $bytes_to_read)
-
-Read from the entity body sent by the client. Example of use:
-
- $r->read_client_block($buf, $r->header_in('Content-length'));
-
=item $r->read($buf, $bytes_to_read)
-This method uses read_client_block() to read data from the client,
+This method is used to read data from the client,
looping until it gets all of C<$bytes_to_read> or a timeout happens.
In addition, this method sets a timeout before reading with
1.18 +37 -9 modperl/src/modules/perl/Apache.xs
Index: Apache.xs
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/Apache.xs,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- Apache.xs 1998/05/04 11:38:07 1.17
+++ Apache.xs 1998/05/04 23:52:57 1.18
@@ -105,7 +105,7 @@
perl_save_av *save_av = (perl_save_av *)data;
if(save_av->fill != DONE) {
- AvFILL(*save_av->ptr) = save_av->fill;
+ AvFILLp(*save_av->ptr) = save_av->fill;
}
else if(save_av->av != Nullav) {
*save_av->ptr = save_av->av;
@@ -142,7 +142,7 @@
if((sv == &sv_undef) || (SvIOK(sv) && SvIV(sv) == DONE)) {
if(AvTRUE(*av)) {
save_av->fill = AvFILL(*av);
- AvFILL(*av) = -1;
+ AvFILLp(*av) = -1;
}
}
else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) {
@@ -894,6 +894,7 @@
long nrd = 0;
PPCODE:
+ if(dowarn) warn("Apache->read_client_block is deprecated");
buffer = (char*)palloc(r->pool, bufsiz);
PERL_READ_FROM_CLIENT;
if ( nrd > 0 ) {
@@ -905,6 +906,36 @@
ST(1) = &sv_undef;
}
+int
+setup_client_block(r, policy=REQUEST_CHUNKED_ERROR)
+ Apache r
+ int policy
+
+int
+should_client_block(r)
+ Apache r
+
+void
+get_client_block(r, buffer, bufsiz)
+ Apache r
+ char *buffer
+ int bufsiz
+
+ PREINIT:
+ long nrd = 0;
+
+ PPCODE:
+ buffer = (char*)palloc(r->pool, bufsiz);
+ nrd = get_client_block(r, buffer, bufsiz);
+ if ( nrd > 0 ) {
+ XPUSHs(sv_2mortal(newSViv((long)nrd)));
+ sv_setpvn((SV*)ST(1), buffer, nrd);
+ SvTAINTED_on((SV*)ST(1));
+ }
+ else {
+ ST(1) = &sv_undef;
+ }
+
void
print(r, ...)
Apache r
@@ -1372,17 +1403,14 @@
RETVAL
long
-read_length(r, ...)
+read_length(r, len=-1)
Apache r
+ long len
CODE:
- {
-#if MODULE_MAGIC_NUMBER >= 19970622
RETVAL = r->read_length;
- if(items > 1)
- r->read_length = (long)SvIV(ST(1));
-#endif
- }
+ if(len > -1)
+ r->read_length = len;
# /* MIME header environments, in and out. Also, an array containing
# * environment variables to be passed to subprocesses, so people can
1.18 +4 -0 modperl/src/modules/perl/mod_perl.h
Index: mod_perl.h
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/mod_perl.h,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- mod_perl.h 1998/05/04 05:08:47 1.17
+++ mod_perl.h 1998/05/04 23:52:57 1.18
@@ -75,6 +75,10 @@
#define ERRHV GvHV(errgv)
#endif
+#ifndef AvFILLp
+#define AvFILLp(av) ((XPVAV*) SvANY(av))->xav_fill
+#endif
+
#define MP_EXISTS_ERROR(k) \
ERRHV && hv_exists(ERRHV, k, strlen(k))
1.2 +46 -1 modperl/t/modules/cgi.t
Index: cgi.t
===================================================================
RCS file: /export/home/cvs/modperl/t/modules/cgi.t,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- cgi.t 1997/12/06 17:57:23 1.1
+++ cgi.t 1998/05/04 23:52:58 1.2
@@ -5,7 +5,19 @@
$ua = new LWP::UserAgent; # create a useragent to test
-print "1..5\nok 1\n";
+my $tests = 5;
+my $i = $tests;
+my $have_com = 0;
+
+eval {
+ require HTTP::Request::Common;
+ if($CGI::VERSION >= 2.39) {
+ $tests += 2;
+ $have_com = 1;
+ }
+};
+
+print "1..$tests\nok 1\n";
print fetch($ua, "http://$net::httpserver$net::perldir/cgi.pl?PARAM=2");
print fetch($ua, "http://$net::httpserver$net::perldir/cgi.pl?PARAM=%33");
print upload($ua, "http://$net::httpserver$net::perldir/cgi.pl", "4 (fileupload)");
@@ -34,3 +46,36 @@
$req->content($content);
$ua->request($req)->content;
}
+
+if ($have_com) {
+ my $url = "http://$net::httpserver$net::perldir/file_upload.cgi";
+ my $file = "";
+ for my $path (@INC) {
+ last if -e ($file = "$path/pod/perlfunc.pod");
+ }
+
+ $file = $0 unless -e $file;
+ my $lines = 0;
+ local *FH;
+ open FH, $file or die "open $file $!";
+ ++$lines while (<FH>);
+ close FH;
+
+ my $response = $ua->request(HTTP::Request::Common::POST($url,
+ Content_Type => 'form-data',
+ Content => [count => 'count lines',
+ filename => [$file],
+ ]));
+
+ my $page = $response->content;
+ print $response->as_string unless $response->is_success;
+ test ++$i, ($page =~ m/Lines:\s+<\D+>(\d+)/m);
+ print "$file should have $lines lines (file_upload.cgi says: $1)\n";
+ test ++$i, $1 == $lines;
+}
+elsif($CGI::VERSION < 2.39) {
+ print "you should upgrade CGI.pm from $CGI::VERSION to 2.39 or higher\n";
+}
+
+
+