=================================================================== RCS file: /cvs/cvsweb/cvsweb.cgi,v retrieving revision 3.1 retrieving revision 3.11 diff -u -p -r3.1 -r3.11 --- cvsweb/cvsweb.cgi 2000/07/19 21:59:47 3.1 +++ cvsweb/cvsweb.cgi 2000/08/13 18:58:24 3.11 @@ -1,4 +1,4 @@ -#!/usr/bin/perl -ws +#!/usr/bin/perl5 -ws # # cvsweb - a CGI interface to CVS trees. # @@ -12,7 +12,7 @@ # # Based on: # * Bill Fenners cvsweb.cgi revision 1.28 available from: -# http://www.freebsd.org/cgi/cvsweb.cgi/www/en/cgi/cvsweb.cgi +# http://www.FreeBSD.org/cgi/cvsweb.cgi/www/en/cgi/cvsweb.cgi # # Copyright (c) 1996-1998 Bill Fenner # (c) 1998-1999 Henner Zeller @@ -41,7 +41,8 @@ # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF # SUCH DAMAGE. # -# $Id: cvsweb.cgi,v 3.1 2000/07/19 21:59:47 knu Exp $ +# $zId: cvsweb.cgi,v 1.93 2000/07/27 17:42:28 hzeller Exp $ +# $Id: cvsweb.cgi,v 3.11 2000/08/13 18:58:24 knu Exp $ # ### @@ -55,8 +56,9 @@ use vars qw ( @revisions %state %difflines %log %branchpoint @revorder $prcgi @prcategories $prcategories $checkoutMagic $doCheckout $scriptname $scriptwhere - $where $Browser $nofilelinks $maycompress @stickyvars - %functionlineregexp + $where $pathinfo $Browser $nofilelinks $maycompress @stickyvars + %funcline_regexp $is_mod_perl + $is_lynx $is_w3m $is_msie $is_mozilla3 $is_textbased %input $query $barequery $sortby $bydate $byrev $byauthor $bylog $byfile $hr_default $logsort $cvstree $cvsroot $mimetype $defaultTextPlain $defaultViewable $allow_compress @@ -64,7 +66,7 @@ use vars qw ( $cvstreedefault $body_tag $logo $defaulttitle $address $backcolor $long_intro $short_instruction $shortLogLen $show_author $dirtable $tablepadding $columnHeaderColorDefault - $columnHeaderColorSorted $hr_breakable $hr_funout $hr_ignwhite + $columnHeaderColorSorted $hr_breakable $showfunc $hr_ignwhite $hr_ignkeysubst $diffcolorHeading $diffcolorEmpty $diffcolorRemove $diffcolorChange $diffcolorAdd $diffcolorDarkChange $difffontface $difffontsize $inputTextSize $mime_types $allow_annotate @@ -78,10 +80,16 @@ use vars qw ( ); ##### Start of Configuration Area ######## +use Cwd; + # == EDIT this == # User configuration is stored in -$config = $ENV{'CVSWEB_CONFIG'} || '/usr/local/etc/cvsweb.conf'; +$config = undef; +for ($ENV{CVSWEB_CONFIG}, '/usr/local/etc/cvsweb.conf', getcwd . '/cvsweb.conf') { + $config = $_ if -r $_; +} + # == Configuration defaults == # Defaults for configuration variables that shouldn't need # to be configured.. @@ -96,7 +104,7 @@ $allow_version_select = 1; $cvstreedefault = $body_tag = $logo = $defaulttitle = $address = $backcolor = $long_intro = $short_instruction = $shortLogLen = $show_author = $dirtable = $tablepadding = $columnHeaderColorDefault = -$columnHeaderColorSorted = $hr_breakable = $hr_funout = $hr_ignwhite = +$columnHeaderColorSorted = $hr_breakable = $showfunc = $hr_ignwhite = $hr_ignkeysubst = $diffcolorHeading = $diffcolorEmpty = $diffcolorRemove = $diffcolorChange = $diffcolorAdd = $diffcolorDarkChange = $difffontface = $difffontsize = $inputTextSize = $mime_types = $allow_annotate = @@ -113,26 +121,34 @@ use IPC::Open2; $verbose = $v; $checkoutMagic = "~checkout~"; -$where = defined($ENV{'PATH_INFO'}) ? $ENV{'PATH_INFO'} : ""; +$pathinfo = defined($ENV{PATH_INFO}) ? $ENV{PATH_INFO} : ''; +$where = $pathinfo; $doCheckout = ($where =~ /^\/$checkoutMagic/); $where =~ s|^/($checkoutMagic)?||; $where =~ s|/+$||; -($scriptname = $ENV{'SCRIPT_NAME'}) =~ s|^/?|/|; +$scriptname = defined($ENV{SCRIPT_NAME}) ? $ENV{SCRIPT_NAME} : ''; +$scriptname =~ s|^/?|/|; $scriptname =~ s|/+$||; +$scriptwhere = $scriptname; if ($where) { - $scriptwhere = $scriptname . '/' . urlencode($where); + $scriptwhere .= '/' . urlencode($where); } -else { - $scriptwhere = $scriptname; -} -$scriptwhere =~ s|/+$||; +$is_mod_perl = defined($ENV{MOD_PERL}); + # in lynx, it it very annoying to have two links # per file, so disable the link at the icon # in this case: -$Browser = $ENV{'HTTP_USER_AGENT'}; -$nofilelinks = ($Browser =~ m'^Lynx/'); +$Browser = $ENV{HTTP_USER_AGENT} || ''; +$is_lynx = ($Browser =~ m`^Lynx/`i); +$is_w3m = ($Browser =~ m`^w3m/`i); +$is_msie = ($Browser =~ m`MSIE`); +$is_mozilla3 = ($Browser =~ m`^Mozilla/[3-9]`); +$is_textbased = ($is_lynx || $is_w3m); + +$nofilelinks = $is_textbased; + # newer browsers accept gzip content encoding # and state this in a header # (netscape did always but didn't state it) @@ -143,19 +159,19 @@ $nofilelinks = ($Browser =~ m'^Lynx/'); # Turn off gzip if running under mod_perl. piping does # not work as expected inside the server. One can probably # achieve the same result using Apache::GZIPFilter. -$maycompress =(($ENV{'HTTP_ACCEPT_ENCODING'} =~ m|gzip| - || $Browser =~ m%^Mozilla/3%) - && ($Browser !~ m/MSIE/) - && !defined($ENV{'MOD_PERL'})); +$maycompress =(($ENV{HTTP_ACCEPT_ENCODING} =~ m`gzip` + || $is_mozilla3) + && !$is_msie + && !$is_mod_perl); # put here the variables we need in order # to hold our state - they will be added (with # their current value) to any link/query string # you construct -@stickyvars = ('cvsroot','hideattic','sortby','logsort','f','only_with_tag'); +@stickyvars = qw(cvsroot hideattic sortby logsort f only_with_tag); if (-f $config) { - do "$config"; + do $config; } else { &fatal("500 Internal Error", @@ -166,7 +182,9 @@ else { } undef %input; -if ($query = $ENV{'QUERY_STRING'}) { +$query = $ENV{QUERY_STRING}; + +if ($query ne '') { foreach (split(/&/, $query)) { s/%(..)/sprintf("%c", hex($1))/ge; # unquote %-quoted if (/(\S+)=(.*)/) { @@ -209,8 +227,9 @@ foreach (keys %DEFAULTVALUE) $barequery = ""; foreach (@stickyvars) { # construct a query string with the sticky non default parameters set - if (defined($input{$_}) && $input{$_} ne "" && $input{$_} ne $DEFAULTVALUE{$_}) { - if ($barequery) { + if (defined($input{$_}) && $input{$_} ne '' && + !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_})) { + if ($barequery) { $barequery = $barequery . "&"; } my $thisval = urlencode($_) . "=" . urlencode($input{$_}); @@ -251,7 +270,7 @@ else { $hr_default = $input{'f'} eq 'h'; -$logsort = $input{"logsort"}; +$logsort = $input{'logsort'}; ## Default CVS-Tree @@ -276,10 +295,10 @@ foreach my $k (keys %ICONS) { no strict 'refs'; my ($itxt,$ipath,$iwidth,$iheight) = @{$ICONS{$k}}; if ($ipath) { - $ {"${k}icon"} = "\"$itxt\""; + ${"${k}icon"} = "\"$itxt\""; } else { - $ {"${k}icon"} = $itxt; + ${"${k}icon"} = $itxt; } } @@ -312,7 +331,6 @@ if (-d $fullname) { # ensure, that directories always end with (exactly) one '/' # to allow relative URL's. If they're not, make a redirect. ## - my $pathinfo = defined($ENV{'PATH_INFO'}) ? $ENV{'PATH_INFO'} : ""; if (!($pathinfo =~ m|/$|) || ($pathinfo =~ m |/{2,}$|)) { redirect ($scriptwhere . '/' . $query); } @@ -347,11 +365,12 @@ elsif (-d $fullname) { getDirLogs($cvsroot,$where,@subLevelFiles); if ($where eq '/') { - html_header("$defaulttitle"); + html_header($defaulttitle); + $long_intro =~ s/!!CVSROOTdescr!!/$CVSROOTdescr{$cvstree}/g; print $long_intro; } else { - html_header("$where"); + html_header($where); print $short_instruction; } @@ -842,8 +861,8 @@ sub htmlify { # get #PR as link .. if ($pr && defined($prcgi)) { - 1 while $string =~ s`\b(pr[:#]?\s*(?:#?\d+[,\s]\s*)*#?)(\d+)\b`$1$2`i; - $string =~ s`\b${prcategories}/(\d+)\b`$&`igo; + 1 while $string =~ s`\b(pr[:#]?\s*(?:#?\d+[,\s]\s*)*#?)(\d+)\b`$1$2`i; + $string =~ s`\b${prcategories}/(\d+)\b`$&`igo; } return $string; @@ -906,11 +925,11 @@ sub revcmp { sub fatal { my($errcode, $errmsg) = @_; - if (defined($ENV{'MOD_PERL'})) { + if ($is_mod_perl) { Apache->request->status((split(/ /, $errcode))[0]); } else { - print "Status: $errcode\n"; + print "Status: $errcode\r\n"; } html_header("Error"); print "Error: $errmsg\n"; @@ -920,13 +939,13 @@ sub fatal { sub redirect { my($url) = @_; - if (defined($ENV{'MOD_PERL'})) { + if ($is_mod_perl) { Apache->request->status(301); Apache->request->header_out(Location => $url); } else { - print "Status: 301 Moved\n"; - print "Location: $url\n"; + print "Status: 301 Moved\r\n"; + print "Location: $url\r\n"; } html_header("Moved"); print "This document is located here.\n"; @@ -1006,7 +1025,7 @@ sub doAnnotate ($$) { # reasons .. if (!($rev =~ /^[\d\.]+$/)) { &fatal("404 Not Found", - "Malformed query \"$ENV{'QUERY_STRING'}\""); + "Malformed query \"$ENV{QUERY_STRING}\""); } ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//; @@ -1052,7 +1071,7 @@ sub doAnnotate ($$) { # least to the point of including the directories down to the one # containing the file in question). # So if $where is "dir/sdir/file", then @dirs will be ("dir","sdir","file") - my @dirs = split (/\//, $where); + my @dirs = split('/', $where); my $path = ""; foreach (@dirs) { if ($path eq "") { @@ -1060,12 +1079,12 @@ sub doAnnotate ($$) { $path = $_; } else { - print $writer "Directory " . $path . "\n"; - print $writer "$cvsroot/" . $path ."\n"; + print $writer "Directory $path\n"; + print $writer "$cvsroot/$path\n"; # In our example, $_ is "sdir" and $path becomes "dir/sdir" # And the next time, "file" and "dir/sdir/file" (which then gets # ignored, because we don't need to send Directory for the file). - $path = $path . "/" . $_; + $path .= "/$_"; } } # And the last "Directory" before "annotate" is the top level. @@ -1122,7 +1141,7 @@ sub doAnnotate ($$) { $oldLusr = $lusr; # is there a less timeconsuming way to strip spaces ? ($lrev = $lrev) =~ s/\s+//g; - my $isCurrentRev = ("$rev" eq "$lrev"); + my $isCurrentRev = ($rev eq $lrev); print "" if ($isCurrentRev); printf ("%8s%s%8s %4d:", $revprint, ($isCurrentRev ? "|" : " "), $usrprint, $lineNr); @@ -1159,7 +1178,7 @@ sub doCheckout { # reasons .. if (defined($rev) && !($rev =~ /^[\d\.]+$/)) { &fatal("404 Not Found", - "Malformed query \"$ENV{'QUERY_STRING'}\""); + "Malformed query \"$ENV{QUERY_STRING}\""); } # get mimetype @@ -1193,7 +1212,7 @@ sub doCheckout { # Safely for a child process to read from. if (! open($fh, "-|")) { # child open(STDERR, ">&STDOUT"); # Redirect stderr to stdout - exec("cvs", "-d", "$cvsroot", "co", "-p", "$revopt", "$where"); + exec("cvs", "-d", $cvsroot, "co", "-p", $revopt, $where); } #=================================================================== #Checking out squid/src/ftp.c @@ -1316,7 +1335,7 @@ sub doDiff { # reasons .. if (!($rev1 =~ /^[\d\.]+$/) || !($rev2 =~ /^[\d\.]+$/)) { &fatal("404 Not Found", - "Malformed query \"$ENV{'QUERY_STRING'}\""); + "Malformed query \"$ENV{QUERY_STRING}\""); } # # rev1 and rev2 are now both numeric revisions. @@ -1355,19 +1374,19 @@ sub doDiff { } # apply special options - if ($human_readable) { - if ($hr_funout) { - push @difftype, '-p'; + if ($showfunc) { + push @difftype, '-p'; - my($re1, $re2); + my($re1, $re2); - while (($re1, $re2) = each %functionlineregexp) { - if ($fullname =~ /$re1/) { - push @difftype, '-F', '$re2'; - last; - } + while (($re1, $re2) = each %funcline_regexp) { + if ($fullname =~ /$re1/) { + push @difftype, '-F', '$re2'; + last; } } + } + if ($human_readable) { if ($hr_ignwhite) { push @difftype, '-w'; } @@ -1376,8 +1395,8 @@ sub doDiff { } } if (! open($fh, "-|")) { # child - open(STDERR, ">&STDOUT"); # Redirect stderr to stdout - exec("rcsdiff",@difftype,"-r$rev1","-r$rev2",$fullname); + open(STDERR, ">&STDOUT"); # Redirect stderr to stdout + exec("rcsdiff",@difftype,"-r$rev1","-r$rev2",$fullname); } if ($human_readable) { http_header(); @@ -1460,15 +1479,15 @@ sub getDirLogs { if ($tag) { #can't use -r as - is allowed in tagnames, but misinterpreated by rlog.. if (! open($fh, "-|")) { - close(STDERR); # rlog may complain; ignore. - exec("rlog",@files); + open(STDERR, '>/dev/null'); # rlog may complain; ignore. + exec('rlog', @files); } } else { my $kidpid = open($fh, "-|"); if (! $kidpid) { - close(STDERR); # rlog may complain; ignore. - exec("rlog","-r",@files); + open(STDERR, '>/dev/null'); # rlog may complain; ignore. + exec('rlog', '-r', @files); } } $state = "start"; @@ -2018,11 +2037,12 @@ sub doLog { $backurl = $scriptname . "/" . urlencode($upwhere) . $query; print &link($backicon, "$backurl#$filename"), " Up to ", &clickablePath($upwhere, 1), "

\n"; - print "Request diff between arbitrary revisions\n"; - print "

\n"; + print <Request diff between arbitrary revisions +
+EOF if ($curbranch) { - print "Default branch: "; - print ($revsym{$curbranch} || $curbranch); + print "Default branch: ", ($revsym{$curbranch} || $curbranch); } else { print "No default branch"; @@ -2316,7 +2336,7 @@ sub navigateHeader ($$$$$) { $swhere = urlencode($filename) if ($swhere eq ""); print "<\!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\">"; print "\n\n"; - print ''; + print ''; print "\n$path$filename - $title - $rev\n"; print "\n"; print ""; @@ -2372,14 +2392,14 @@ sub readableTime ($$) } $i--; $break = $breaks[$i]; - $retval = plural_write(int ($secs / $break), $desc{"$break"}); + $retval = plural_write(int ($secs / $break), $desc{$break}); if ($long == 1 && $i > 0) { my $rest = $secs % $break; $i--; $break = $breaks[$i]; my $resttime = plural_write(int ($rest / $break), - $desc{"$break"}); + $desc{$break}); if ($resttime) { $retval = $retval . ", " . $resttime; } @@ -2412,7 +2432,7 @@ sub clickablePath($$) { $retval = $retval . " / "; $wherepath = $wherepath . '/' . $_; my ($last) = "$wherepath/" eq "/$pathname" - || "$wherepath" eq "/$pathname"; + || $wherepath eq "/$pathname"; if ($clickLast || !$last) { $retval = $retval . "\n"; foreach $k (@foo) { print "\n"; } print "\n"; @@ -2617,20 +2637,19 @@ sub urlencode { sub http_header { my $content_type = shift || "text/html"; - my $is_mod_perl = defined($ENV{'MOD_PERL'}); if (defined($moddate)) { if ($is_mod_perl) { Apache->request->header_out(Last_modified => scalar gmtime($moddate) . " GMT"); } else { - print "Last-Modified: " . scalar gmtime($moddate) . " GMT\n"; + print "Last-Modified: " . scalar gmtime($moddate) . " GMT\r\n"; } } if ($is_mod_perl) { Apache->request->content_type($content_type); } else { - print "Content-type: $content_type\n"; + print "Content-type: $content_type\r\n"; } if ($allow_compress && $maycompress) { my $fh = do {local(*FH);}; @@ -2641,9 +2660,9 @@ sub http_header { Apache->request->send_http_header; } else { - print "Content-encoding: x-gzip\n"; - print "Vary: Accept-Encoding\n"; #RFC 2068, 14.43 - print "\n"; # Close headers + print "Content-encoding: x-gzip\r\n"; + print "Vary: Accept-Encoding\r\n"; #RFC 2068, 14.43 + print "\r\n"; # Close headers } $| = 1; $| = 0; # Flush header output select ($fh); @@ -2654,7 +2673,7 @@ sub http_header { Apache->request->send_http_header; } else { - print "\n"; # Close headers + print "\r\n"; # Close headers } print "Unable to find gzip binary in the \$PATH to compress output
"; } @@ -2664,21 +2683,21 @@ sub http_header { Apache->request->send_http_header; } else { - print "\n"; # Close headers + print "\r\n"; # Close headers } } } sub html_header($) { my ($title) = @_; - my $version = '$Revision: 3.1 $'; + my $version = '$zRevision: 1.93 $ $Revision: 3.11 $'; http_header(); print < $title - + $body_tag $logo

$title