=================================================================== RCS file: /cvs/cvsweb/cvsweb.cgi,v retrieving revision 1.1.1.20 retrieving revision 1.1.1.22 diff -u -p -r1.1.1.20 -r1.1.1.22 --- cvsweb/cvsweb.cgi 2001/01/03 03:36:03 1.1.1.20 +++ cvsweb/cvsweb.cgi 2001/01/14 08:49:27 1.1.1.22 @@ -18,7 +18,7 @@ # Copyright (c) 1996-1998 Bill Fenner # (c) 1998-1999 Henner Zeller # (c) 1999 Henrik Nordstrom -# (c) 2000 Akinori MUSHA +# (c) 2000-2001 Akinori MUSHA # All rights reserved. # # Redistribution and use in source and binary forms, with or without @@ -42,8 +42,8 @@ # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF # 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 $ +# $zId: cvsweb.cgi,v 1.105 2000/11/26 01:51:04 jumager Exp $ +# $Idaemons: /home/cvs/cvsweb/cvsweb.cgi,v 1.64 2001/01/13 07:48:09 knu Exp $ # ### @@ -52,7 +52,8 @@ require 5.000; use strict; use vars qw ( - $config $allow_version_select $verbose + $cvsweb_revision + $mydir $uname $config $allow_version_select $verbose @CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr %MIRRORS %DEFAULTVALUE %ICONS %MTYPES @DIFFTYPES %DIFFTYPES @LOGSORTKEYS %LOGSORTKEYS @@ -67,7 +68,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 +84,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 +101,7 @@ sub revcmp($$); sub fatal($$); sub redirect($); sub safeglob($); +sub search_path($); sub getMimeTypeFromSuffix($); sub head($;$); sub scan_directives(@); @@ -133,16 +137,24 @@ sub link_tags($); sub forbidden_module($); ##### Start of Configuration Area ######## +delete $ENV{PATH}; + +$cvsweb_revision = join('.', '1.105', (split(/ /, + q$Idaemons: /home/cvs/cvsweb/cvsweb.cgi,v 1.64 2001/01/13 07:48:09 knu Exp $ +))[2]); + 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 +247,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 stupidity.. +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 +477,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 +538,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 +546,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; @@ -726,7 +738,8 @@ if (-d $fullname) { if ($_ eq '..' || -d "$fullname/$_") { next if ($_ eq '..' && $where eq '/'); - my ($rev,$date,$log,$author,$filename) = @{$fileinfo{$_}} + my ($rev,$date,$log,$author,$filename); + ($rev,$date,$log,$author,$filename) = @{$fileinfo{$_}} if (defined($fileinfo{$_})); printf '', $tabcolors[$dirrow % 2] if $dirtable; if ($_ eq '..') { @@ -1006,7 +1019,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 +1226,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 +1310,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 +1394,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 +1605,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 +1786,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 +1870,14 @@ sub getDirLogs($$@) { if (defined($tag)) { #can't use -r as - is allowed in tagnames, but misinterpreated by rlog.. if (! open($fh, "-|")) { - open(STDERR, '>/dev/null'); # rlog may complain; ignore. - exec('rlog', @files); + open(STDERR, '>/dev/null'); # rlog may complain; ignore. + exec($CMD{rlog}, @files); } } else { - my $kidpid = open($fh, "-|"); - if (! $kidpid) { - open(STDERR, '>/dev/null'); # rlog may complain; ignore. - exec('rlog', '-r', @files); + if (! open($fh, "-|")) { + open(STDERR, '>/dev/null'); # rlog may complain; ignore. + exec($CMD{rlog}, '-r', @files); } } $state = "start"; @@ -1984,7 +2007,7 @@ again: } if ($. == 0) { fatal("500 Internal Error", - "Failed to spawn GNU rlog on '".join(", ", @files)."'

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 +2035,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); @@ -2735,14 +2758,19 @@ sub navigateHeader($$$$$) { my ($swhere,$path,$filename,$rev,$title) = @_; $swhere = "" if ($swhere eq $scriptwhere); $swhere = urlencode($filename) if ($swhere eq ""); - print qq``; - print "\n\n"; - print qq`\n`; - print ''; - print "\n$path$filename - $title - $rev\n"; - print "$body_tag_for_src\n"; - print ""; - print "
"; + + print < + + + + +$path$filename - $title - $rev +$body_tag_for_src + +"; @@ -3092,7 +3120,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 +3146,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 +3161,6 @@ sub http_header(;$) { sub html_header($) { my ($title) = @_; - my $version = '$zRevision: 1.104 $ $kRevision: 1.57 $'; #' http_header("text/html"); print < $title - + $body_tag $logo

$title

+EOF + print &link($backicon, "$swhere$query#rev$rev"); print " Return to ", &link("$filename","$swhere$query#rev$rev")," CVS log"; print " $fileicon