dougm at hyperreal
May 7, 1998, 7:40 PM
Post #1 of 1
(541 views)
Permalink
|
|
cvs commit: modperl/t/net/perl dirty-script.cgi test
|
|
dougm 98/05/07 19:40:52
Modified: . Changes MANIFEST Makefile.PL ToDo
apache-modlist.html
Apache Apache.pm
lib/Apache PerlRun.pm Status.pm
src/modules/perl Apache.xs mod_perl.c mod_perl.h
perl_config.c
t TEST
t/docs startup.pl
t/net/perl dirty-script.cgi test
Log:
overload the get_basic_auth_pw function so we can change AuthType on
the fly via $r->connection->auth_type
add code to deal with 1.3b7-dev's SERVER_SUBVERSION replacement
a few doc patches [John D Groenveld <jdg117 [at] elvis>]
re-implemented $r->read to properly use *client_block methods and call
reset_timeout after each read in the loop. until this is well tested,
the method is called new_read. to test on tie'd STDIN reads, a startup
script can say this:
*Apache::READ = \&Apache::new_read;
added setup_client_block, should_client_block and get_client_block
methods
some Apache::PerlRun enhancements
Submitted by: Doug MacEachern
Revision Changes Path
1.28 +10 -2 modperl/Changes
Index: Changes
===================================================================
RCS file: /export/home/cvs/modperl/Changes,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -r1.27 -r1.28
--- Changes 1998/05/05 22:34:38 1.27
+++ Changes 1998/05/08 02:40:44 1.28
@@ -18,10 +18,18 @@
=item 1.11_01-dev
-$r->read_client_block is deprecated
+overload the get_basic_auth_pw function so we can change AuthType on
+the fly via $r->connection->auth_type
+add code to deal with 1.3b7-dev's SERVER_SUBVERSION replacement
+
+a few doc patches [John D Groenveld <jdg117 [at] elvis>]
+
re-implemented $r->read to properly use *client_block methods and call
-reset_timeout after each read in the loop
+reset_timeout after each read in the loop. until this is well tested,
+the method is called new_read. to test on tie'd STDIN reads, a startup
+script can say this:
+*Apache::READ = \&Apache::new_read;
added setup_client_block, should_client_block and get_client_block
methods
1.12 +2 -0 modperl/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /export/home/cvs/modperl/MANIFEST,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- MANIFEST 1998/05/04 23:52:54 1.11
+++ MANIFEST 1998/05/08 02:40:44 1.12
@@ -45,6 +45,7 @@
Symbol/Symbol.pm
Symbol/Symbol.xs
Symbol/test.pl
+src/modules/perl/mod_perl_version.h
src/modules/perl/Constants.xs
src/modules/perl/Apache.xs
src/modules/perl/ldopts
@@ -143,4 +144,5 @@
faq/mod_perl_api.pod
faq/mod_perl_cgi.pod
faq/mod_perl_faq.pod
+faq/mjtg-news.txt
htdocs/manual/mod/mod_perl.html
1.24 +11 -0 modperl/Makefile.PL
Index: Makefile.PL
===================================================================
RCS file: /export/home/cvs/modperl/Makefile.PL,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- Makefile.PL 1998/05/04 23:59:18 1.23
+++ Makefile.PL 1998/05/08 02:40:44 1.24
@@ -32,6 +32,7 @@
gen_script("t/net/perl/cgi.pl");
gen_script("t/report");
+write_version_h("src/modules/perl");
if($] < 5.004_04) {
print <<EOF;
@@ -1367,6 +1368,16 @@
#endif
+EOF
+ close FH;
+}
+
+sub write_version_h {
+ my $d = shift;
+ local *FH;
+ open FH, ">$d/mod_perl_version.h" or die "can't write $d/mod_perl_version.h $!";
+ print FH <<EOF;
+#define MOD_PERL_STRING_VERSION "mod_perl/$VERSION"
EOF
close FH;
}
1.18 +4 -0 modperl/ToDo
Index: ToDo
===================================================================
RCS file: /export/home/cvs/modperl/ToDo,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- ToDo 1998/05/05 22:34:39 1.17
+++ ToDo 1998/05/08 02:40:45 1.18
@@ -24,6 +24,7 @@
+ Frank's FAQ update: http://www.ping.de/~fdc/mod_perl/mod_perl_faq.tar.gz
+ DONE
+ SUID access http://www.courtesan.com/sudo/
+ + $ENV{PATH}/PerlSetEnv and PerlTaintCheck
- rand() broken under win32!
Jeff Baker <jeff [at] godzilla>
@@ -96,6 +97,9 @@
---------------------------------------------------------------------------
NEW STUFF
---------------------------------------------------------------------------
+
+- make 'PerlSetVar $Foo value' work like 'local $Foo = value'
+ for the given location
- PerlInitHandler - alias to first available
PerlCleanupHandler - register_cleanup
1.11 +4 -4 modperl/apache-modlist.html
Index: apache-modlist.html
===================================================================
RCS file: /export/home/cvs/modperl/apache-modlist.html,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- apache-modlist.html 1998/05/05 22:34:39 1.10
+++ apache-modlist.html 1998/05/08 02:40:45 1.11
@@ -7,7 +7,7 @@
<h1>The Apache/Perl Module List</h1>
Maintained by <a href="mailto:dougm [at] osf">Doug MacEachern</a>,
-<br><i> $Revision: 1.10 $ $Date: 1998/05/05 22:34:39 $</i>
+<br><i> $Revision: 1.11 $ $Date: 1998/05/08 02:40:45 $</i>
<h3>Contents</h3>
<a href="#intro">Introduction</a><br>
@@ -227,16 +227,16 @@
GRICHTER Gerald Richter <richter [at] ecos>
HMUELLER Hanno Mueller <hmueller [at] mail>
IKLUFT Ian Kluft <ikluft [at] cisco>
-JANPAZ Honza Pazdziora <adelton [at] INFORMATICS>
+JANPAZ Honza Pazdziora <adelton [at] informatics>
JBAKER Jeffrey Baker <jeff [at] tamu>
-JGROV John D Groenveld <groenvel [at] cse>
+JGROV John D Groenveld <jdg117 [at] elvis>
JROWE Jeff Rowe <beowulf [at] lava>
KWILLIAM Ken Williams <ken [at] forum>
LDS Lincoln D. Stein <lstein [at] genome>
MARKC Mark Constable <markc [at] goldcoast>
MARKIM Mark A. Imbriaco <mark [at] itribe>
MARKK Mark Kennedy <mtk [at] ny>
-MAURICE Maurice Aubrey <maurice [at] HEVANET>
+MAURICE Maurice Aubrey <maurice [at] hevanet>
MDORMAN Michael Alan Dorman <mdorman [at] calder>
MERGL Edmund Mergl <E.Mergl [at] bawue>
MJS Michael Smith <mjs [at] iii>
1.8 +31 -2 modperl/Apache/Apache.pm
Index: Apache.pm
===================================================================
RCS file: /export/home/cvs/modperl/Apache/Apache.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- Apache.pm 1998/05/05 22:34:41 1.7
+++ Apache.pm 1998/05/08 02:40:46 1.8
@@ -67,7 +67,8 @@
return $val;
}
-*READ = \&read;
+*READ = \&read unless defined &READ;
+
sub read {
my($r, $bufsiz) = @_[0,2];
my($nrd, $buf, $total);
@@ -76,6 +77,34 @@
$_[1] ||= "";
#$_[1] = " " x $bufsiz unless defined $_[1]; #XXX?
+ $r->hard_timeout("Apache->read");
+
+ while($bufsiz) {
+ $nrd = $r->read_client_block($buf, $bufsiz) || 0;
+ if(defined $nrd and $nrd > 0) {
+ $bufsiz -= $nrd;
+ $_[1] .= $buf;
+ #substr($_[1], $total, $nrd) = $buf;
+ $total += $nrd;
+ next if $bufsiz;
+ last;
+ }
+ else {
+ $_[1] = undef;
+ last;
+ }
+ }
+ $r->kill_timeout;
+ return $total;
+}
+
+sub new_read {
+ my($r, $bufsiz) = @_[0,2];
+ my($nrd, $buf, $total);
+ $nrd = $total = 0;
+ $buf = "";
+ $_[1] ||= "";
+
if(my $rv = $r->setup_client_block) {
$r->log_error("Apache->read: setup_client_block returned $rv");
die $rv;
@@ -115,7 +144,7 @@
return $total;
}
-sub GETC { my $c; shift->read($c,1); $c; }
+sub GETC { my $c; shift->READ($c,1); $c; }
#shouldn't use <STDIN> anyhow, but we'll be nice
sub READLINE {
1.2 +90 -12 modperl/lib/Apache/PerlRun.pm
Index: PerlRun.pm
===================================================================
RCS file: /export/home/cvs/modperl/lib/Apache/PerlRun.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- PerlRun.pm 1998/04/26 00:16:39 1.1
+++ PerlRun.pm 1998/05/08 02:40:47 1.2
@@ -1,13 +1,37 @@
package Apache::PerlRun;
use strict;
+use vars qw($Debug);
use Apache::Constants qw(:common OPT_EXECCGI);
use File::Basename ();
use IO::File ();
use Cwd ();
+unless ($Apache::Registry::{NameWithVirtualHost}) {
+ $Apache::Registry::NameWithVirtualHost = 1;
+}
+
+$Debug ||= 0;
my $Is_Win32 = $^O eq "MSWin32";
+@Apache::PerlRun::ISA = qw(Apache);
+
+sub new {
+ my($class, $r) = @_;
+ return $r unless ref($r) eq "Apache";
+ if(ref $r) {
+ $r->request($r);
+ }
+ else {
+ $r = Apache->request;
+ }
+ my $filename = $r->filename;
+ $r->log_error("Apache::PerlRun->new for $filename in process $$")
+ if $Debug && $Debug & 4;
+
+ bless $r, $class;
+}
+
sub can_compile {
my($r) = @_;
my $filename = $r->filename;
@@ -33,7 +57,8 @@
}
sub compile {
- my $eval = shift;
+ my($r, $eval) = @_;
+ $r->log_error("Apache::PerlRun->compile") if $Debug && $Debug & 4;
Apache->untaint($$eval);
{
no strict; #so eval'd code doesn't inherit our bits
@@ -42,7 +67,11 @@
}
sub namespace {
- my($r) = @_;
+ my($r, $root) = @_;
+
+ $r->log_error(sprintf "Apache::PerlRun->namespace escaping %s",
+ $r->uri) if $Debug && $Debug & 4;
+
my $script_name = $r->path_info ?
substr($r->uri, 0, length($r->uri)-length($r->path_info)) :
$r->uri;
@@ -63,29 +92,79 @@
}[
"::" . ($2 ? sprintf("_%2x",unpack("C",$2)) : "")
]egx;
+
+ $Apache::Registry::curstash = $script_name if
+ scalar(caller) eq "Apache::Registry";
+
+ $root ||= "Apache::ROOT";
+
+ $r->log_error("Apache::PerlRun->namespace: package $root$script_name")
+ if $Debug && $Debug & 4;
- return "Apache::ROOT$script_name";
+ return $root.$script_name;
}
sub readscript {
my $r = shift;
- my $fh = IO::File->new($r->filename);
+ my $filename = $r->filename;
+ $r->log_error("Apache::PerlRun->readscript $filename")
+ if $Debug && $Debug & 4;
+ my $fh = IO::File->new($filename);
local $/;
my $code = <$fh>;
- #$code = parse_cmdline($code);
return \$code;
}
-sub status {
+sub error_check {
my $r = shift;
if ($@) {
- $r->log_error($@);
+ $r->log_error("PerlRun: `$@'");
$@{$r->uri} = $@;
+ $@ = ''; #XXX fix me, if we don't do this Apache::exit() breaks
return SERVER_ERROR;
}
return OK;
}
+sub chdir_file {
+ my $r = shift;
+ my $cwd = Cwd::fastcwd();
+ chdir File::Basename::dirname($r->filename);
+ *0 = \$r->filename;
+ return $cwd;
+}
+
+#XXX not good enough yet
+my(%switches) = (
+ 'T' => sub {
+ Apache::warn("Apache::PerlRun: T switch ignored, ".
+ "enable with 'PerlTaintCheck On'\n")
+ unless $Apache::__T; "";
+ },
+ 'w' => sub { 'BEGIN {$^W = 1;}; $^W = 1;' },
+);
+
+sub parse_cmdline {
+ my($r, $sub) = @_;
+ my($line) = $$sub =~ /^(.*)$/m;
+ my(@cmdline) = split /\s+/, $line;
+ return $sub unless @cmdline;
+ return $sub unless shift(@cmdline) =~ /^\#!/;
+ my($s, @s, $prepend);
+ $prepend = "";
+ for $s (@cmdline) {
+ next unless $s =~ s/^-//;
+ last if substr($s,0,1) eq "-";
+ for (split //, $s) {
+ next unless $switches{$_};
+ #print STDERR "parsed `$_' switch\n";
+ $prepend .= &{$switches{$_}};
+ }
+ }
+ $$sub =~ s/^/$prepend/ if $prepend;
+ return $sub;
+}
+
sub handler {
my $r = shift;
@@ -94,10 +173,9 @@
my $package = namespace($r);
my $code = readscript($r);
+ parse_cmdline($r, $code);
- my $cwd = Cwd::fastcwd();
- chdir File::Basename::dirname($r->filename);
- *0 = \$r->filename;
+ my $cwd = chdir_file($r);
my $eval = join '',
'package ',
@@ -106,7 +184,7 @@
"\n#line 1 ", $r->filename, "\n",
$$code,
"\n";
- compile(\$eval);
+ compile($r, \$eval);
chdir $cwd;
@@ -115,7 +193,7 @@
%{$package.'::'} = ();
}
- return status($r);
+ return error_check($r);
}
1;
1.7 +4 -2 modperl/lib/Apache/Status.pm
Index: Status.pm
===================================================================
RCS file: /export/home/cvs/modperl/lib/Apache/Status.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- Status.pm 1998/03/19 23:08:48 1.6
+++ Status.pm 1998/05/08 02:40:47 1.7
@@ -1,7 +1,7 @@
package Apache::Status;
use strict;
-$Apache::Status::VERSION = (qw$Revision: 1.6 $)[1];
+$Apache::Status::VERSION = (qw$Revision: 1.7 $)[1];
my %is_installed = ();
@@ -454,7 +454,9 @@
}
) if Apache->module("Apache::Status"); #only if Apache::Status is loaded
-
+B<WARNING>: Apache::Status must be loaded before these modules via the
+PerlModule or PerlRequire directives.
+
=head1 OPTIONS
=over 4
1.20 +51 -2 modperl/src/modules/perl/Apache.xs
Index: Apache.xs
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/Apache.xs,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- Apache.xs 1998/05/05 22:34:41 1.19
+++ Apache.xs 1998/05/08 02:40:48 1.20
@@ -310,6 +310,50 @@
return NULL;
}
+#if MODULE_MAGIC_NUMBER > 19970909
+static int mp_get_basic_auth_pw(request_rec *r, char **pw)
+{
+ const char *auth_line = ap_table_get(r->headers_in,
+ r->proxyreq ? "Proxy-Authorization"
+ : "Authorization");
+ char *t = r->connection->auth_type ?
+ r->connection->auth_type : auth_type(r);
+
+ if (!t || strcasecmp(t, "Basic"))
+ return DECLINED;
+
+ if (!auth_name(r)) {
+ aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR,
+ r->server, "need AuthName: %s", r->uri);
+ return SERVER_ERROR;
+ }
+
+ if (!auth_line) {
+ note_basic_auth_failure(r);
+ return AUTH_REQUIRED;
+ }
+
+ if (strcasecmp(getword(r->pool, &auth_line, ' '), "Basic")) {
+ /* Client tried to authenticate using wrong auth scheme */
+ aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, r->server,
+ "client used wrong authentication scheme: %s", r->uri);
+ note_basic_auth_failure(r);
+ return AUTH_REQUIRED;
+ }
+
+ t = uudecode(r->pool, auth_line);
+ /* Note that this allocation has to be made from r->connection->pool
+ * because it has the lifetime of the connection. The other allocations
+ * are temporary and can be tossed away any time.
+ */
+ r->connection->user = getword_nulls_nc (r->connection->pool, &t, ':');
+ r->connection->ap_auth_type = "Basic";
+
+ *pw = t;
+
+ return OK;
+}
+#endif
#define TABLE_GET_SET(table, do_taint) \
{ \
@@ -427,8 +471,10 @@
PREINIT:
ix = ix; /* avoid -Wall warning */
+#define APACHE_REGISTRY_CURSTASH perl_get_sv("Apache::Registry::curstash", TRUE)
+
void
-mod_perl_clear_rgy_endav(r, sv)
+mod_perl_clear_rgy_endav(r, sv=APACHE_REGISTRY_CURSTASH)
Apache r
SV *sv
@@ -832,7 +878,11 @@
int ret;
PPCODE:
+#if MODULE_MAGIC_NUMBER > 19970909
+ ret = mp_get_basic_auth_pw(r, &sent_pw);
+#else
ret = get_basic_auth_pw(r, &sent_pw);
+#endif
XPUSHs(sv_2mortal((SV*)newSViv(ret)));
if(ret == OK)
XPUSHs(sv_2mortal((SV*)newSVpv(sent_pw, 0)));
@@ -894,7 +944,6 @@
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 ) {
1.17 +5 -0 modperl/src/modules/perl/mod_perl.c
Index: mod_perl.c
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/mod_perl.c,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- mod_perl.c 1998/05/04 05:08:47 1.16
+++ mod_perl.c 1998/05/08 02:40:48 1.17
@@ -355,6 +355,11 @@
SV *pool_rv, *server_rv;
GV *gv, *shgv;
+#if MODULE_MAGIC_NUMBER >= 19980507
+#include "mod_perl_version.h"
+ ap_add_version_component(MOD_PERL_STRING_VERSION);
+#endif
+
#ifndef WIN32
argv[0] = server_argv0;
#endif
1.19 +1 -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.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- mod_perl.h 1998/05/04 23:52:57 1.18
+++ mod_perl.h 1998/05/08 02:40:49 1.19
@@ -895,6 +895,7 @@
CHAR_P perl_end_section (cmd_parms *cmd, void *dummy);
CHAR_P perl_pod_section (cmd_parms *cmd, void *dummy, CHAR_P arg);
CHAR_P perl_pod_end_section (cmd_parms *cmd, void *dummy);
+CHAR_P perl_cmd_autoload (cmd_parms *parms, void *dummy, const char *arg);
CHAR_P perl_config_END (cmd_parms *cmd, void *dummy, CHAR_P arg);
CHAR_P perl_limit_section(cmd_parms *cmd, void *dummy, HV *hv);
CHAR_P perl_urlsection (cmd_parms *cmd, void *dummy, HV *hv);
1.15 +4 -8 modperl/src/modules/perl/perl_config.c
Index: perl_config.c
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/perl_config.c,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- perl_config.c 1998/05/04 04:09:16 1.14
+++ perl_config.c 1998/05/08 02:40:49 1.15
@@ -633,7 +633,6 @@
static SV *perl_perl_create_dir_config(SV **sv, HV *class)
{
GV *gv;
- SV *obj = Nullsv;
if(SvTRUE(*sv) && SvROK(*sv) && sv_isobject(*sv))
return *sv;
@@ -690,14 +689,11 @@
PUTBACK;
count = perl_call_sv((SV*)cv, G_EVAL | G_SCALAR);
SPAGAIN;
-#if 0
+#if 1
if(count == 1) {
- SV *config = POPs;
- if(config && SvROK(config) && data && *data) {
- ++SvREFCNT(config);
- SvREFCNT_dec(*data);
- *data = config;
- }
+ char *retval = POPp;
+ if(strEQ(retval, DECLINE_CMD))
+ return DECLINE_CMD;
}
#endif
FREETMPS;LEAVE;
1.3 +0 -3 modperl/t/TEST
Index: TEST
===================================================================
RCS file: /export/home/cvs/modperl/t/TEST,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- TEST 1998/03/21 04:00:55 1.2
+++ TEST 1998/05/08 02:40:50 1.3
@@ -1,8 +1,5 @@
#!/usr/local/bin/perl
-# This script is run Test::Harness on the tests found under the
-# "t" directory.
-
# First we check if we already are within the "t" directory
if (-d "t") {
# try to move into test directory
1.8 +4 -0 modperl/t/docs/startup.pl
Index: startup.pl
===================================================================
RCS file: /export/home/cvs/modperl/t/docs/startup.pl,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- startup.pl 1998/04/28 02:26:25 1.7
+++ startup.pl 1998/05/08 02:40:51 1.8
@@ -38,6 +38,10 @@
die "mod_perl.pm is broken\n";
}
+if($ENV{PERL_TEST_NEW_READ}) {
+ *Apache::READ = \&Apache::new_read;
+}
+
$ENV{KeyForPerlSetEnv} eq "OK" or warn "PerlSetEnv is broken\n";
#test Apache::RegistryLoader
1.2 +2 -0 modperl/t/net/perl/dirty-script.cgi
Index: dirty-script.cgi
===================================================================
RCS file: /export/home/cvs/modperl/t/net/perl/dirty-script.cgi,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- dirty-script.cgi 1998/04/26 00:16:40 1.1
+++ dirty-script.cgi 1998/05/08 02:40:51 1.2
@@ -14,4 +14,6 @@
print __PACKAGE__, " is dirty";
+exit;
+
__END__
1.6 +2 -1 modperl/t/net/perl/test
Index: test
===================================================================
RCS file: /export/home/cvs/modperl/t/net/perl/test,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- test 1998/03/19 23:09:06 1.5
+++ test 1998/05/08 02:40:51 1.6
@@ -43,7 +43,8 @@
$r->post_connection(sub {
my $r = shift;
unless(Apache::test::WIN32()) { #XXX
- $r->uri =~ /test/i or die "post_connection can't see \$r->uri!\n";
+ my $loc = $r->uri;
+ $loc =~ /test/i or die "post_connection can't see \$r->uri! ($loc)\n";
}
#$r->warn("post connection handler called for ", $r->uri);
return 0;
|
