=================================================================== RCS file: /cvs/cvsweb/cvsweb.cgi,v retrieving revision 1.1.1.20 retrieving revision 1.1.1.21 diff -u -p -r1.1.1.20 -r1.1.1.21 --- cvsweb/cvsweb.cgi 2001/01/03 03:36:03 1.1.1.20 +++ cvsweb/cvsweb.cgi 2001/01/12 04:17:16 1.1.1.21 @@ -43,7 +43,7 @@ # SUCH DAMAGE. # # $zId: cvsweb.cgi,v 1.104 2000/11/01 22:05:12 hnordstrom Exp $ -# $kId: cvsweb.cgi,v 1.57 2001/01/03 02:55:30 knu Exp $ +# $kId: cvsweb.cgi,v 1.63 2001/01/11 23:42:01 knu Exp $ # ### @@ -52,7 +52,7 @@ require 5.000; use strict; use vars qw ( - $config $allow_version_select $verbose + $mydir $uname $config $allow_version_select $verbose @CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr %MIRRORS %DEFAULTVALUE %ICONS %MTYPES @DIFFTYPES %DIFFTYPES @LOGSORTKEYS %LOGSORTKEYS @@ -67,7 +67,8 @@ use vars qw ( %input $query $barequery $sortby $bydate $byrev $byauthor $bylog $byfile $defaultDiffType $logsort $cvstree $cvsroot $mimetype $charset $defaultTextPlain $defaultViewable - $allow_compress $GZIPBIN $backicon $diricon $fileicon + $command_path %CMD $allow_compress + $backicon $diricon $fileicon $fullname $newname $cvstreedefault $body_tag $body_tag_for_src $logo $defaulttitle $address $long_intro $short_instruction $shortLogLen @@ -82,7 +83,8 @@ use vars qw ( $navigationHeaderColor $tableBorderColor $markupLogColor $tabstop $state $annTable $sel $curbranch @HideModules $module $use_descriptions %descriptions @mytz $dwhere $moddate - $use_moddate $has_zlib $gzip_open $allow_tar @tar_options @cvs_options + $use_moddate $has_zlib $gzip_open + $allow_tar @tar_options @gzip_options @cvs_options $LOG_FILESEPARATOR $LOG_REVSEPARATOR ); @@ -98,6 +100,7 @@ sub revcmp($$); sub fatal($$); sub redirect($); sub safeglob($); +sub search_path($); sub getMimeTypeFromSuffix($); sub head($;$); sub scan_directives(@); @@ -133,16 +136,20 @@ sub link_tags($); sub forbidden_module($); ##### Start of Configuration Area ######## +delete $ENV{PATH}; + use File::Basename; +($mydir) = (dirname($0) =~ /(.*)/); # untaint + # == EDIT this == # Locations to search for user configuration, in order: for ( - (dirname $0) . '/cvsweb.conf', + "$mydir/cvsweb.conf", '/usr/local/etc/cvsweb/cvsweb.conf' ) { if (defined($_) && -r $_) { - ($config) = /(.*)/; # untaint + $config = $_; last; } } @@ -235,18 +242,23 @@ $verbose = $v; $checkoutMagic = "~checkout~"; $pathinfo = defined($ENV{PATH_INFO}) ? $ENV{PATH_INFO} : ''; $where = $pathinfo; -$where =~ tr|/|/|s; -$doCheckout = ($where =~ /^\/$checkoutMagic/); -$where =~ s|^/($checkoutMagic)?||; -$where =~ s|/$||; +$doCheckout = ($where =~ m|^/$checkoutMagic/|); +$where =~ s|^/$checkoutMagic/|/|; +$where =~ s|^/||; $scriptname = defined($ENV{SCRIPT_NAME}) ? $ENV{SCRIPT_NAME} : ''; -$scriptname =~ s|^/?|/|; -$scriptname =~ s|/+$||; -$scriptwhere = $scriptname; -if ($where) { - $scriptwhere .= '/' . urlencode($where); +$scriptname =~ s|^/*|/|; + +# Let's workaround thttpd's stupidness.. +if ($scriptname =~ m|/$|) { + $pathinfo .= '/'; + my $re = quotemeta $pathinfo; + $scriptname =~ s/$re$//; } +$scriptwhere = $scriptname; +$scriptwhere .= '/' . urlencode($where); +$where = '/' if ($where eq ''); + $is_mod_perl = defined($ENV{MOD_PERL}); # in lynx, it it very annoying to have two links @@ -460,34 +472,29 @@ $mimetype = &getMimeTypeFromSuffix ($fullname); $defaultTextPlain = ($mimetype eq "text/plain"); $defaultViewable = $allow_markup && viewable($mimetype); -# search for GZIP if compression allowed -# We've to find out if the GZIP-binary exists .. otherwise -# ge get an Internal Server Error if we try to pipe the -# output through the nonexistent gzip .. -# any more elegant ways to prevent this are welcome! -if ($allow_compress && $maycompress && !$has_zlib) { - foreach (split(/:/, $ENV{PATH})) { - if (-x "$_/gzip") { - $GZIPBIN = "$_/gzip"; - last; - } - } +my $rewrite = 0; + +if ($pathinfo =~ m|//|) { + $pathinfo =~ y|/|/|s; + $rewrite = 1; } -if (-d $fullname) { - # - # ensure, that directories always end with (exactly) one '/' - # to allow relative URL's. If they're not, make a redirect. - ## - if (!($pathinfo =~ m|/$|) || ($pathinfo =~ m |/{2,}$|)) { - redirect("$scriptwhere/$query"); - } - else { - $where .= '/'; - $scriptwhere .= '/'; - } +if (-d $fullname && $pathinfo !~ m|/$|) { + $pathinfo .= '/'; + $rewrite = 1; } +if (!-d $fullname && $pathinfo =~ m|/$|) { + chop $pathinfo; + $rewrite = 1; +} + +if ($rewrite) { + redirect($scriptname . urlencode($pathinfo) . $query); +} + +undef $rewrite; + if (!-d $cvsroot) { &fatal("500 Internal Error",'$CVSROOT not found!
The server on which the CVS tree lives is probably down. Please try again in a few minutes.');
}
@@ -526,7 +533,7 @@ if ($input{tarball}) {
my $tag = (exists $input{only_with_tag} && length $input{only_with_tag})
? $input{only_with_tag} : "HEAD";
- system "cvs", @cvs_options, "-Qd", $cvsroot, "export", "-r", $tag, "-d", "$tmpdir/$basedir", $module
+ system $CMD{cvs}, @cvs_options, '-Qd', $cvsroot, 'export', '-r', $tag, '-d', "$tmpdir/$basedir", $module
and $fatal = "500 Internal Error","cvs co failure: $!: $module"
&& last;
@@ -534,14 +541,14 @@ if ($input{tarball}) {
print "Content-type: application/x-gzip\r\n\r\n";
- system "tar", @tar_options, "-zcf", "-", "-C", $tmpdir, $basedir
+ system "$CMD{tar} @tar_options -cf - -C $tmpdir $basedir | $CMD{gzip} @gzip_options -c"
and $fatal = "500 Internal Error","tar zc failure: $!: $basedir"
&& last;
last;
}
- system "rm", "-rf", $tmpdir if -d $tmpdir;
+ system $CMD{rm}, '-rf', $tmpdir if -d $tmpdir;
&fatal($fatal) if $fatal;
@@ -1006,7 +1013,7 @@ if (-d $fullname) {
# Assume it's a module name with a potential path following it.
$xtra = (($module = $where) =~ s|/.*||) ? $& : '';
# Is there an indexed version of modules?
- if (open($fh, "$cvsroot/CVSROOT/modules")) {
+ if (open($fh, "< $cvsroot/CVSROOT/modules")) {
while (<$fh>) {
if (/^(\S+)\s+(\S+)/o && $module eq $1
&& -d "$cvsroot/$2" && $module ne $2) {
@@ -1213,9 +1220,9 @@ sub spacedHtmlText($;$) {
}
sub link($$) {
- my($name, $where) = @_;
+ my($name, $url) = @_;
- sprintf '%s', hrefquote($where), $name;
+ sprintf '%s', hrefquote($url), $name;
}
sub revcmp($$) {
@@ -1297,6 +1304,17 @@ sub safeglob($) {
@results;
}
+sub search_path($) {
+ my($command) = @_;
+ my $d;
+
+ for $d (split(/:/, $command_path)) {
+ return "$d/$command" if -x "$d/$command";
+ }
+
+ $command;
+}
+
sub getMimeTypeFromSuffix($) {
my ($fullname) = @_;
my ($mimetype, $suffix);
@@ -1370,7 +1388,7 @@ sub doAnnotate($$) {
my $reader = do {local(*FH);};
my $writer = do {local(*FH);};
- # make sure the revisions a wellformed, for security
+ # make sure the revisions are wellformed, for security
# reasons ..
if ($rev =~ /[^\w.]/) {
&fatal("404 Not Found",
@@ -1581,8 +1599,8 @@ sub doCheckout($$) {
#
# Safely for a child process to read from.
if (! open($fh, "-|")) { # child
- open(STDERR, ">&STDOUT"); # Redirect stderr to stdout
- exec("cvs", @cvs_options, "-d", $cvsroot, "co", "-p", $revopt, $where);
+ open(STDERR, ">&STDOUT"); # Redirect stderr to stdout
+ exec($CMD{cvs}, @cvs_options, '-d', $cvsroot, 'co', '-p', $revopt, $where);
}
if (eof($fh)) {
@@ -1762,7 +1780,7 @@ sub doDiff($$$$$$) {
}
if (! open($fh, "-|")) { # child
open(STDERR, ">&STDOUT"); # Redirect stderr to stdout
- exec("rcsdiff",@difftype,"-r$rev1","-r$rev2",$fullname);
+ exec($CMD{rcsdiff}, @difftype, "-r$rev1", "-r$rev2", $fullname);
}
if ($human_readable) {
http_header();
@@ -1846,15 +1864,14 @@ sub getDirLogs($$@) {
if (defined($tag)) {
#can't use -r did you set the \$ENV{PATH} in your configuration file correctly ?");
+ "Failed to spawn GNU rlog on '".join(", ", @files)."' Did you set the \$command_path in your configuration file correctly ? (Currently '$command_path'");
}
close($fh);
}
@@ -2012,12 +2029,12 @@ sub readLog($;$) {
print("Going to rlog '$fullname'\n") if ($verbose);
if (! open($fh, "-|")) { # child
- if ($revision ne '') {
- exec("rlog",$revision,$fullname);
- }
- else {
- exec("rlog",$fullname);
- }
+ if ($revision ne '') {
+ exec($CMD{rlog}, $revision, $fullname);
+ }
+ else {
+ exec($CMD{rlog}, $fullname);
+ }
}
while (<$fh>) {
print if ($verbose);
@@ -2738,7 +2755,7 @@ sub navigateHeader($$$$$) {
print qq``;
print "\n";
@@ -3092,7 +3109,7 @@ sub http_header(;$) {
print "Content-type: $content_type\r\n";
}
if ($allow_compress && $maycompress) {
- if ($has_zlib || (defined($GZIPBIN) && open(GZIP, "|$GZIPBIN -1 -c"))) {
+ if ($has_zlib || (defined($CMD{gzip}) && open(GZIP, "| $CMD{gzip} -1 -c"))) {
if ($is_mod_perl) {
Apache->request->content_encoding("x-gzip");
Apache->request->header_out(Vary => "Accept-Encoding");
@@ -3118,7 +3135,7 @@ sub http_header(;$) {
else {
print "\r\n"; # Close headers
}
- print "Unable to find gzip binary in the \$PATH to compress output
";
+ print "Unable to find gzip binary in the \$command_path ($command_path) to compress output
";
}
}
else {
@@ -3133,7 +3150,7 @@ sub http_header(;$) {
sub html_header($) {
my ($title) = @_;
- my $version = '$zRevision: 1.104 $ $kRevision: 1.57 $'; #'
+ my $version = '$zRevision: 1.104 $ $kRevision: 1.63 $'; #'
http_header("text/html");
print <