===================================================================
RCS file: /cvs/cvsweb/cvsweb.cgi,v
retrieving revision 1.1.1.11
retrieving revision 1.1.1.19
diff -u -p -r1.1.1.11 -r1.1.1.19
--- cvsweb/cvsweb.cgi 2000/10/20 15:54:58 1.1.1.11
+++ cvsweb/cvsweb.cgi 2001/01/02 12:41:38 1.1.1.19
@@ -1,4 +1,4 @@
-#!/usr/bin/perl5 -ws
+#!/usr/bin/perl -wT
#
# cvsweb - a CGI interface to CVS trees.
#
@@ -42,11 +42,13 @@
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
-# $zId: cvsweb.cgi,v 1.103 2000/09/20 17:02:29 jumager Exp $
-# $kId: cvsweb.cgi,v 1.37 2000/10/20 15:46:01 knu Exp $
+# $zId: cvsweb.cgi,v 1.104 2000/11/01 22:05:12 hnordstrom Exp $
+# $kId: cvsweb.cgi,v 1.55 2001/01/02 12:23:20 knu Exp $
#
###
+require 5.000;
+
use strict;
use vars qw (
@@ -56,17 +58,17 @@ use vars qw (
%alltags @tabcolors %fileinfo %tags @branchnames %nameprinted
%symrev %revsym @allrevisions %date %author @revdisplayorder
@revisions %state %difflines %log %branchpoint @revorder
- $prcgi @prcategories $prcategories $mancgi
+ $prcgi @prcategories $re_prcategories $prkeyword $re_prkeyword $mancgi
$checkoutMagic $doCheckout $scriptname $scriptwhere
$where $pathinfo $Browser $nofilelinks $maycompress @stickyvars
%funcline_regexp $is_mod_perl
$is_links $is_lynx $is_w3m $is_msie $is_mozilla3 $is_textbased
%input $query $barequery $sortby $bydate $byrev $byauthor
$bylog $byfile $defaultDiffType $logsort $cvstree $cvsroot
- $mimetype $defaultTextPlain $defaultViewable $allow_compress
- $GZIPBIN $backicon $diricon $fileicon $fullname $newname
- $cvstreedefault $body_tag $body_tag_for_src
- $logo $defaulttitle $address
+ $mimetype $charset $defaultTextPlain $defaultViewable
+ $allow_compress $GZIPBIN $backicon $diricon $fileicon
+ $fullname $newname $cvstreedefault
+ $body_tag $body_tag_for_src $logo $defaulttitle $address
$long_intro $short_instruction $shortLogLen
$show_author $dirtable $tablepadding $columnHeaderColorDefault
$columnHeaderColorSorted $hr_breakable $showfunc $hr_ignwhite
@@ -75,11 +77,11 @@ use vars qw (
$difffontsize $inputTextSize $mime_types $allow_annotate
$allow_markup $use_java_script $open_extern_window
$extern_window_width $extern_window_height $edit_option_form
- $show_subdir_lastmod $show_log_in_markup $v
+ $show_subdir_lastmod $show_log_in_markup $preformat_in_markup $v
$navigationHeaderColor $tableBorderColor $markupLogColor
$tabstop $state $annTable $sel $curbranch @HideModules
$module $use_descriptions %descriptions @mytz $dwhere $moddate
- $use_moddate $has_zlib $gzip_open
+ $use_moddate $has_zlib $gzip_open $allow_tar @tar_options @cvs_options
$LOG_FILESEPARATOR $LOG_REVSEPARATOR
);
@@ -122,6 +124,7 @@ sub toggleQuery($$);
sub urlencode($);
sub htmlquote($);
sub htmlunquote($);
+sub hrefquote($);
sub http_header(;$);
sub html_header($);
sub html_footer();
@@ -129,16 +132,18 @@ sub link_tags($);
sub forbidden_module($);
##### Start of Configuration Area ########
-use Cwd;
+use File::Basename;
# == EDIT this ==
# Locations to search for user configuration, in order:
for (
- $ENV{CVSWEB_CONFIG},
- '/usr/local/etc/cvsweb.conf',
- getcwd() . '/cvsweb.conf'
+ (dirname $0) . '/cvsweb.conf',
+ '/usr/local/etc/cvsweb.conf'
) {
- $config = $_ if defined($_) && -r $_;
+ if (defined($_) && -r $_) {
+ ($config) = /(.*)/; # untaint
+ last;
+ }
}
# == Configuration defaults ==
@@ -228,9 +233,10 @@ $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|/+$||;
+$where =~ s|/$||;
$scriptname = defined($ENV{SCRIPT_NAME}) ? $ENV{SCRIPT_NAME} : '';
$scriptname =~ s|^/?|/|;
$scriptname =~ s|/+$||;
@@ -244,7 +250,7 @@ $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};
+$Browser = $ENV{HTTP_USER_AGENT} || '';
$is_links = ($Browser =~ m`^Links `);
$is_lynx = ($Browser =~ m`^Lynx/`i);
$is_w3m = ($Browser =~ m`^w3m/`i);
@@ -277,7 +283,7 @@ $maycompress = (((defined($ENV{HTTP_ACCEPT_ENCODING})
@stickyvars = qw(cvsroot hideattic sortby logsort f only_with_tag);
if (-f $config) {
- do $config
+ require $config
|| &fatal("500 Internal Error",
sprintf('Error in loading configuration file: %s
%s ',
$config, &htmlify($@)));
@@ -294,6 +300,7 @@ $query = $ENV{QUERY_STRING};
if (defined($query) && $query ne '') {
foreach (split(/&/, $query)) {
+ y/+/ /;
s/%(..)/sprintf("%c", hex($1))/ge; # unquote %-quoted
if (/(\S+)=(.*)/) {
$input{$1} = $2 if ($2 ne "");
@@ -404,7 +411,7 @@ foreach $k (keys %ICONS) {
my ($itxt,$ipath,$iwidth,$iheight) = @{$ICONS{$k}};
if ($ipath) {
${"${k}icon"} = sprintf('',
- htmlquote($ipath), htmlquote($itxt), $iwidth, $iheight)
+ hrefquote($ipath), htmlquote($itxt), $iwidth, $iheight)
}
else {
${"${k}icon"} = $itxt;
@@ -416,17 +423,18 @@ my $config_cvstree = "$config-$cvstree";
# Do some special configuration for cvstrees
if (-f $config_cvstree) {
- do $config_cvstree
+ require $config_cvstree
|| &fatal("500 Internal Error",
sprintf('Error in loading configuration file: %s
%s ',
$config_cvstree, &htmlify($@)));
}
undef $config_cvstree;
-$prcategories = '(?:' . join('|', @prcategories) . ')';
+$re_prcategories = '(?:' . join('|', @prcategories) . ')' if @prcategories;
+$re_prkeyword = quotemeta($prkeyword) if defined($prkeyword);
$prcgi .= '%s' if defined($prcgi) && $prcgi !~ /%s/;
-$fullname = $cvsroot . '/' . $where;
+$fullname = "$cvsroot/$where";
$mimetype = &getMimeTypeFromSuffix ($fullname);
$defaultTextPlain = ($mimetype eq "text/plain");
$defaultViewable = $allow_markup && viewable($mimetype);
@@ -471,10 +479,58 @@ $module = $1;
if ($module && &forbidden_module($module)) {
&fatal("403 Forbidden", "Access to $where forbidden.");
}
+
+#
+# Handle tarball downloads before any headers are output.
+#
+if ($input{tarball}) {
+ &fatal("403 Forbidden", "Downloading tarballs is prohibited.")
+ unless $allow_tar;
+ my($module) = ($where =~ m,^/?(.*),); # untaint
+ $module =~ s,/[^/]*$,,;
+ my($basedir) = ($module =~ m,([^/]+)$,);
+
+ if ($basedir eq '' || $module eq '') {
+ &fatal("500 Internal Error", "You cannot download the top level directory.");
+ }
+
+ my $tmpdir = "/tmp/.cvsweb.$$." . int(time);
+
+ mkdir($tmpdir, 0700)
+ or &fatal("500 Internal Error", "Unable to make temporary directory: $!");
+
+ my $fatal = '';
+
+ while (1) {
+ 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
+ and $fatal = "500 Internal Error","cvs co failure: $!: $module"
+ && last;
+
+ $| = 1; # Essential to get the buffering right.
+
+ print "Content-type: application/x-gzip\r\n\r\n";
+
+ system "tar", @tar_options, "-zcf", "-", "-C", $tmpdir, $basedir
+ and $fatal = "500 Internal Error","tar zc failure: $!: $basedir"
+ && last;
+
+ last;
+ }
+
+ system "rm", "-rf", $tmpdir if -d $tmpdir;
+
+ &fatal($fatal) if $fatal;
+
+ exit;
+}
+
##############################
# View a directory
###############################
-elsif (-d $fullname) {
+if (-d $fullname) {
my $dh = do {local(*DH);};
opendir($dh, $fullname) || &fatal("404 Not Found","$where: $!");
my @dir = readdir($dh);
@@ -812,6 +868,22 @@ elsif (-d $fullname) {
print "\n";
print "\n";
}
+
+ if ($allow_tar) {
+ my($basefile) = ($where =~ m,(?:.*/)?([^/]+),);
+
+ if ($basefile ne '') {
+ print "
\n",
+ "
",
+ &link("Download this directory in tarball",
+ # Mangle the filename so browsers show a reasonable
+ # filename to download.
+ "$basefile.tar.gz$query".
+ ($query ? "&" : "?")."tarball=1"),
+ "
";
+ }
+ }
+
my $formwhere = $scriptwhere;
$formwhere =~ s|Attic/?$|| if ($input{'hideattic'});
@@ -909,13 +981,13 @@ elsif (-d $fullname) {
my $fh = do {local(*FH);};
my ($xtra, $module);
# Assume it's a module name with a potential path following it.
- $xtra = $& if (($module = $where) =~ s|/.*||);
+ $xtra = (($module = $where) =~ s|/.*||) ? $& : '';
# Is there an indexed version of modules?
if (open($fh, "$cvsroot/CVSROOT/modules")) {
while (<$fh>) {
if (/^(\S+)\s+(\S+)/o && $module eq $1
- && -d "${cvsroot}/$2" && $module ne $2) {
- &redirect($scriptname . '/' . $2 . $xtra);
+ && -d "$cvsroot/$2" && $module ne $2) {
+ &redirect("$scriptname/$2$xtra");
}
}
}
@@ -1001,12 +1073,13 @@ sub findLastModifiedSubdirs(@) {
sub htmlify_sub(&$) {
(my $proc, local $_) = @_;
local @_ = split(m`(]+>[^<]*)`i);
- my ($linked, $result);
+ my $linked;
+ my $result = '';
while (($_, $linked) = splice(@_, 0, 2)) {
&$proc();
- $result .= $_;
- $result .= $linked;
+ $result .= $_ if defined($_);
+ $result .= $linked if defined($linked);
}
$result;
@@ -1035,7 +1108,7 @@ sub htmlify($;$) {
if ($extra) {
# get PR #'s as link: "PR#nnnn" "PR: nnnn, ..." "PR nnnn, ..." "bin/nnnn"
- if (defined($prcgi)) {
+ if (defined($prcgi) && defined($re_prcategories) && defined($re_prkeyword)) {
my $prev;
do {
@@ -1043,7 +1116,7 @@ sub htmlify($;$) {
$_ = htmlify_sub {
s{
- (\bPR[:\#]?\s*
+ (\b$re_prkeyword[:\#]?\s*
(?:
\#?
\d+[,\s]\s*
@@ -1051,16 +1124,16 @@ sub htmlify($;$) {
\#?)
(\d+)\b
}{
- $1 . &link($2, sprintf($prcgi, $2)) . $3
+ $1 . &link($2, sprintf($prcgi, $2))
}egix;
} $_;
} while ($_ ne $prev);
$_ = htmlify_sub {
s{
- (\b$prcategories/(\d+)\b)
+ (\b$re_prcategories/(\d+)\b)
}{
- &link($1, sprintf($prcgi, $2)) . $3
+ &link($1, sprintf($prcgi, $2))
}egox;
} $_;
}
@@ -1069,7 +1142,7 @@ sub htmlify($;$) {
if (defined($mancgi)) {
$_ = htmlify_sub {
s{
- (\b([a-zA-Z][\w_.]+)
+ (\b([a-zA-Z][\w.]+)
(?:
\( ([0-9n]) \)\B
|
@@ -1077,7 +1150,7 @@ sub htmlify($;$) {
)
)
}{
- &link($1, sprintf($mancgi, $3 ne '' ? $3 : $4, $2)) . $5
+ &link($1, sprintf($mancgi, defined($3) ? $3 : $4, $2))
}egx;
} $_;
}
@@ -1119,7 +1192,7 @@ sub spacedHtmlText($;$) {
sub link($$) {
my($name, $where) = @_;
- sprintf '%s', htmlquote($where), $name;
+ sprintf '%s', hrefquote($where), $name;
}
sub revcmp($$) {
@@ -1293,8 +1366,8 @@ sub doAnnotate($$) {
# the public domain.
# we could abandon the use of rlog, rcsdiff and co using
# the cvsserver in a similiar way one day (..after rewrite)
- $pid = open2($reader, $writer, "cvs -Rl server") || fatal ("500 Internal Error",
- "Fatal Error - unable to open cvs for annotation");
+ $pid = open2($reader, $writer, "cvs", @cvs_options, "server")
+ || fatal ("500 Internal Error", "Fatal Error - unable to open cvs for annotation");
# OK, first send the request to the server. A simplified example is:
# Root /home/kingdon/zwork/cvsroot
@@ -1486,8 +1559,13 @@ sub doCheckout($$) {
# Safely for a child process to read from.
if (! open($fh, "-|")) { # child
open(STDERR, ">&STDOUT"); # Redirect stderr to stdout
- exec("cvs", "-Rld", $cvsroot, "co", "-p", $revopt, $where);
+ exec("cvs", @cvs_options, "-d", $cvsroot, "co", "-p", $revopt, $where);
}
+
+ if (eof($fh)) {
+ &fatal("404 Not Found",
+ "$where is not (any longer) pertinent");
+ }
#===================================================================
#Checking out squid/src/ftp.c
#RCS: /usr/src/CVS/squid/src/ftp.c,v
@@ -1507,12 +1585,7 @@ sub doCheckout($$) {
}
if ($filename ne $where) {
&fatal("500 Internal Error",
- "Unexpected output from cvs co: $cvsheader"
- . "
Check whether the directory $cvsroot/CVSROOT exists "
- . "and the script has write-access to the CVSROOT/history "
- . "file if it exists."
- . " The script needs to place lock files in the "
- . "directory the file is in as well.");
+ "Unexpected output from cvs co: $cvsheader");
}
$| = 1;
@@ -1563,12 +1636,12 @@ sub cvswebMarkup($$$) {
my $url = download_url($fileurl, $revision, $mimetype);
print "