%s',
+ $ENV{PATH_INFO});
+}
+if ($ENV{SCRIPT_NAME}) {
+ ($scriptname) = ($ENV{SCRIPT_NAME} =~ VALID_PATH)
+ or fatal('500 Internal Error',
+ 'Illegal SCRIPT_NAME in environment: %s',
+ $ENV{SCRIPT_NAME});
+}
-##### End of configuration variables #####
+$scriptname = '' unless defined($scriptname);
-use Time::Local ();
-use IPC::Open2 qw(open2);
+$where = $pathinfo;
+$doCheckout = $where =~ s|^/$CheckoutMagic/|/|o;
+$where =~ s|^/||;
+$scriptname =~ s|^/*|/|;
-# Check if the zlib C library interface is installed, and if yes
-# we can avoid using the extra gzip process.
-eval { require Compress::Zlib; };
-$has_zlib = !$@;
-
-$verbose = $v;
-$checkoutMagic = "~checkout~";
-$pathinfo = defined($ENV{PATH_INFO}) ? $ENV{PATH_INFO} : '';
-$where = $pathinfo;
-$doCheckout = ($where =~ m|^/$checkoutMagic/|);
-$where =~ s|^/$checkoutMagic/|/|;
-$where =~ s|^/||;
-$scriptname = defined($ENV{SCRIPT_NAME}) ? $ENV{SCRIPT_NAME} : '';
-$scriptname =~ s|^/*|/|;
-
# Let's workaround thttpd's stupidity..
if ($scriptname =~ m|/$|) {
- $pathinfo .= '/';
- my $re = quotemeta $pathinfo;
- $scriptname =~ s/$re$//;
+ $pathinfo .= '/';
+ my $re = quotemeta $pathinfo;
+ $scriptname =~ s/$re$//;
}
-$scriptwhere = $scriptname;
-$scriptwhere .= '/' . urlencode($where);
-$where = '/' if ($where eq '');
+# $scriptname : the URI escaped path to this script
+# $where : the path in the CVS repository (without leading /, or only /)
+# $scriptwhere: the URI escaped $scriptname + '/' + $where
+$scriptname = uri_escape_path($scriptname);
+$scriptwhere = join('/', $scriptname, uri_escape_path($where));
+$where = '/' if ($where eq '');
-$is_mod_perl = defined($ENV{MOD_PERL});
+# In text-based browsers, it's very annoying to have two links per file;
+# skip linking the image for them.
-# 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} || '';
-$is_links = ($Browser =~ m`^Links `);
+$Browser = $ENV{HTTP_USER_AGENT} || '';
+$is_links = ($Browser =~ m`^E?Links `);
$is_lynx = ($Browser =~ m`^Lynx/`i);
$is_w3m = ($Browser =~ m`^w3m/`i);
$is_msie = ($Browser =~ m`MSIE`);
@@ -301,803 +338,943 @@ $nofilelinks = $is_textbased;
# display garbage then :-/
# Turn off gzip if running under mod_perl and no zlib is available,
# piping does not work as expected inside the server.
-$maycompress =
- (((defined($ENV{HTTP_ACCEPT_ENCODING})
- && $ENV{HTTP_ACCEPT_ENCODING} =~ m`gzip`) || $is_mozilla3) && !$is_msie
- && !($is_mod_perl && !$has_zlib));
+$maycompress = (
+ ((defined($ENV{HTTP_ACCEPT_ENCODING})
+ && $ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/)
+ || $is_mozilla3)
+ && !$is_msie
+ && !(defined($ENV{MOD_PERL}) && !HAS_ZLIB)
+);
-# 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 = qw(cvsroot hideattic sortby logsort f only_with_tag);
-@unsafevars = qw(logsort only_with_tag r1 r2 rev sortby tr1 tr2);
+# Parameters that will be sticky in all constructed links/query strings.
+@stickyvars =
+ qw(cvsroot hideattic ignorecase sortby logsort f only_with_tag ln
+ hidecvsroot hidenonreadable);
+#
+# Load configuration.
+#
if (-f $config) {
- do "$config" or fatal("500 Internal Error",
- 'Error in loading configuration file: %s%s
', - $config, $@); + do "$config" or config_error($config, $@); } else { - fatal("500 Internal Error", - 'Configuration not found. Set the variable
$config in cvsweb.cgi to your cvsweb.conf configuration file first.'
- );
+ fatal("500 Internal Error",
+ 'Configuration not found. Set the parameter $config in cvsweb.cgi to your cvsweb.conf configuration file first.');
}
+# Try to find a readable dir where we can cd into. Some abs_path()
+# implementations as well as various cvs operations require such a dir to
+# work properly.
+{
+ local $^W = 0;
+ for my $dir (tmpdir(), rootdir()) {
+ last if (-r $dir && chdir($dir));
+ }
+}
+
+$CSS = $cssurl ?
+ sprintf("\n",
+ htmlquote($cssurl)) : '';
+
+# --- input parameters
+
+my %query = ();
+if (defined($ENV{QUERY_STRING})) {
+ for my $p (split(/[;&]+/, $ENV{QUERY_STRING})) {
+ next unless $p;
+ $p =~ y/+/ /;
+ my ($key, $val) = split(/=/, $p, 2);
+ next unless defined($key);
+ $val = 1 unless defined($val);
+ ($key = uri_unescape($key)) =~ /[[:graph:]]/ or next;
+ ($val = uri_unescape($val)) =~ /[[:graph:]]/ or next;
+ $query{$key} = $val;
+ }
+}
+
undef %input;
-$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 "");
- } else {
- $input{$_}++;
- }
- }
+my $t;
+for my $p (qw(graph hideattic hidecvsroot hidenonreadable ignorecase ln copt
+ makeimage options tarball)) {
+ $t = $query{$p};
+ if (defined($t)) {
+ ($input{$p}) = ($t =~ /^([01]|on)$/)
+ or fatal('500 Internal Error',
+ 'Invalid boolean value: %s=%s', $p, $t);
+ }
}
+for my $p (qw(annotate r1 r2 rev tr1 tr2)) {
+ $t = $query{$p};
+ if (defined($t)) {
+ if (($p eq 'r1' || $p eq 'r2') && $t eq 'text') {
+ # Special case for the "Use text field" option in the log view diff form.
+ $input{$p} = $t;
+ next;
+ } elsif (($p eq 'rev' || $p eq 'annotate') && ($t eq '.' || $t eq 'HEAD')){
+ # Another special case, allow linking to latest revision using these.
+ $input{$p} = '.';
+ next;
+ }
+ my ($rev, $tag) = split(/:/, $t, 2);
+ ($input{$p}) = ($rev =~ /^(\d+(?:\.\d+)*)$/)
+ or fatal('500 Internal Error',
+ 'Invalid revision: %s=%s', $p, $t);
+ if (defined($tag)) {
+ ($tag) = ($tag =~ VALID_TAG1)
+ or fatal('500 Internal Error',
+ 'Invalid tag/branch name in revision: %s=%s',
+ $p, $t);
+ ($tag) = ($tag =~ VALID_TAG2)
+ or fatal('500 Internal Error',
+ 'Invalid tag/branch name in revision: %s=%s',
+ $p, $t);
+ $input{$p} .= ':' . $tag;
+ }
+ }
+}
+$t = defined($query{only_with_tag}) ?
+ $query{only_with_tag} : $query{only_on_branch}; # Backwards compatibility.
+if (defined($t)) {
+ ($input{only_with_tag}) = ($t =~ VALID_TAG1)
+ or fatal('500 Internal Error',
+ 'Invalid tag/branch name: %s', $t);
+ ($input{only_with_tag}) = ($t =~ VALID_TAG2)
+ or fatal('500 Internal Error',
+ 'Invalid tag/branch name: %s', $t);
+}
+$t = $query{logsort};
+if (defined($t)) {
+ ($input{logsort}) = ($t =~ /^(cvs|date|rev)$/)
+ or fatal('500 Internal Error',
+ 'Unsupported log sort key: %s', $t);
+}
+$t = $query{f};
+if (defined($t)) {
+ ($input{f}) = ($t =~ /^(([hH]|[ucs]c?)|ext\d*)$/)
+ or fatal('500 Internal Error',
+ 'Unsupported diff format: %s', $t);
+}
+$t = $query{sortby};
+if (defined($t)) {
+ ($input{sortby}) = ($t =~ /^(file|date|rev|author|log)$/)
+ or fatal('500 Internal Error',
+ 'Unsupported dir sort key: %s', $t);
+}
+$t = $query{'content-type'};
+if (defined($t)) {
+ ($input{'content-type'}) = ($t =~ m|^([-0-9A-Za-z]+/[-0-9A-Za-z\.\+]+)$|)
+ or fatal('500 Internal Error',
+ 'Unsupported content type: %s', $t);
+}
+$t = $query{cvsroot};
+if (defined($t)) {
+ ($input{cvsroot}) = ($t =~ /^([[:print:]]+)$/)
+ or fatal('500 Internal Error',
+ 'Invalid symbolic CVS root name: %s', $t);
+}
+$t = $query{path};
+if (defined($t)) {
+ ($input{path}) = ($t =~ VALID_PATH)
+ or fatal('500 Internal Error',
+ 'Invalid path: %s', $t);
+}
+undef($t);
+undef(%query);
-# For backwards compability, set only_with_tag to only_on_branch if set.
-$input{only_with_tag} = $input{only_on_branch}
- if (defined($input{only_on_branch}));
+# --- end input parameters
-# Prevent cross-site scripting
-foreach (@unsafevars) {
- # Colons are needed in diffs between tags.
- if (defined($input{$_}) && $input{$_} =~ /[^\w\-.:]/) {
- fatal("500 Internal Error",
- 'Malformed query (%s=%s)',
- $_, $input{$_});
- }
+#
+# CVS roots
+#
+my $rootfound = 0;
+for (my $i = 0; $i < scalar(@CVSrepositories); $i += 2) {
+ my $key = $CVSrepositories[$i];
+ my ($descr, $root) = @{$CVSrepositories[$i+1]};
+ $root = canonpath($root);
+ unless (-d $root) {
+ warn("Root '$root' defined in \@CVSrepositories is not a directory, " .
+ 'entry ignored');
+ next;
+ }
+ $rootfound ||= 1;
+ $cvstreedefault = $key unless defined($cvstreedefault);
+ $CVSROOTdescr{$key} = $descr;
+ $CVSROOT{$key} = $root;
+ push(@CVSROOT, $key);
}
+unless ($rootfound) {
+ fatal('500 Internal Error',
+ 'No valid CVS roots found! See @CVSrepositories in ' .
+ 'the configuration file (%s).',
+ $config);
+}
+undef $rootfound;
-if (defined($input{"content-type"})) {
- fatal("500 Internal Error", "Unsupported content-type")
- if ($input{"content-type"} !~ /^[-0-9A-Za-z]+\/[-0-9A-Za-z]+$/);
+#
+# Default CVS root
+#
+if (!defined($CVSROOT{$cvstreedefault})) {
+ fatal("500 Internal Error",
+ '$cvstreedefault points to a repository (%s) not ' .
+ 'defined in @CVSrepositories in your configuration ' .
+ 'file (%s).',
+ $cvstreedefault,
+ $config);
}
-$DEFAULTVALUE{'cvsroot'} = $cvstreedefault;
+$DEFAULTVALUE{cvsroot} = $cvstreedefault;
-foreach (keys %DEFAULTVALUE) {
+while (my ($key, $defval) = each %DEFAULTVALUE) {
- # replace not given parameters with the default parameters
- if (!defined($input{$_}) || $input{$_} eq "") {
+ # Replace not given parameters with defaults.
+ next unless (defined($defval) && $defval =~ /\S/ && !defined($input{$key}));
- # Empty Checkboxes in forms return -- nothing. So we define a helper
- # variable in these forms (copt) which indicates that we just set
- # parameters with a checkbox
- if (!defined($input{"copt"})) {
+ # Empty checkboxes in forms return nothing, so we define a helper parameter
+ # in these forms (copt) which indicates that we just set parameters with a
+ # checkbox.
+ if ($input{copt}) {
- # 'copt' isn't defined --> empty input is not the result
- # of empty input checkbox --> set default
- $input{$_} = $DEFAULTVALUE{$_}
- if (defined($DEFAULTVALUE{$_}));
- } else {
+ # 'copt' is set -> the result of empty input checkbox
+ # -> set to zero (disable) if default is a boolean (0|1).
+ $input{$key} = 0 if ($defval eq '0' || $defval eq '1');
- # 'copt' is defined -> the result of empty input checkbox
- # -> set to zero (disable) if default is a boolean (0|1).
- $input{$_} = 0
- if (defined($DEFAULTVALUE{$_})
- && ($DEFAULTVALUE{$_} eq "0"
- || $DEFAULTVALUE{$_} eq "1"));
- }
- }
+ } else {
+
+ # 'copt' isn't set --> empty input is not the result
+ # of empty input checkbox --> set default.
+ $input{$key} = $defval;
+ }
}
$barequery = "";
my @barequery;
foreach (@stickyvars) {
- # construct a query string with the sticky non default parameters set
- if (defined($input{$_}) && $input{$_} ne ''
- && !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_}))
- {
- push @barequery,
- join ('=', urlencode($_), urlencode($input{$_}));
- }
+ # construct a query string with the sticky non default parameters set
+ if (defined($input{$_})
+ && !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_}))
+ {
+ push(@barequery, join('=', uri_escape($_), uri_escape($input{$_})));
+ }
}
+if ($allow_enscript) {
+ push(@DIFFTYPES, qw(uc cc sc));
+ @DIFFTYPES{qw(uc cc sc)} = (
+ {
+ 'descr' => 'unified, colored',
+ 'opts' => ['-u'],
+ 'colored' => 0,
+ },
+ {
+ 'descr' => 'context, colored',
+ 'opts' => ['-c'],
+ 'colored' => 0,
+ },
+ {
+ 'descr' => 'side by side, colored',
+ # width=168 should be enough to support 80 character line lengths
+ 'opts' => ['--side-by-side', '--width=168'],
+ 'colored' => 0,
+ },
+ );
+} else {
+ # No Enscript -> respect difftype, but don't offer colorization.
+ if ($input{f} && $input{f} =~ /^([ucs])c$/) {
+ $input{f} = $1;
+ }
+}
+
# is there any query ?
if (@barequery) {
- $barequery = join ('&', @barequery);
- $query = "?$barequery";
- $barequery = "&$barequery";
+ $barequery = join (';', @barequery);
+ $query = "?$barequery";
+ $barequery = ";$barequery";
} else {
- $query = "";
+ $query = "";
}
undef @barequery;
if (defined($input{path})) {
- redirect("$scriptname/$input{path}$query");
+ redirect("$scriptname/$input{path}$query");
}
# get actual parameters
-$sortby = $input{"sortby"};
-$bydate = 0;
-$byrev = 0;
-$byauthor = 0;
-$bylog = 0;
-$byfile = 0;
-if ($sortby eq "date") {
- $bydate = 1;
-} elsif ($sortby eq "rev") {
- $byrev = 1;
-} elsif ($sortby eq "author") {
- $byauthor = 1;
-} elsif ($sortby eq "log") {
- $bylog = 1;
-} else {
- $byfile = 1;
-}
-
-$defaultDiffType = $input{'f'};
-
-$logsort = $input{'logsort'};
-
{
- my @tmp = @CVSrepositories;
- my @pair;
-
- while (@pair = splice(@tmp, 0, 2)) {
- my ($key, $val) = @pair;
- my ($descr, $cvsroot) = @$val;
-
- next if !-d $cvsroot;
-
- $CVSROOTdescr{$key} = $descr;
- $CVSROOT{$key} = $cvsroot;
- push @CVSROOT, $key;
- }
+ my $sortby = $input{sortby} || 'file';
+ $bydate = 0;
+ $byrev = 0;
+ $byauthor = 0;
+ $bylog = 0;
+ $byfile = 0;
+ if ($sortby eq 'date') {
+ $bydate = 1;
+ } elsif ($sortby eq 'rev') {
+ $byrev = 1;
+ } elsif ($sortby eq 'author') {
+ $byauthor = 1;
+ } elsif ($sortby eq 'log') {
+ $bylog = 1;
+ } else {
+ $byfile = 1;
+ }
}
-## Default CVS-Tree
-if (!defined($CVSROOT{$cvstreedefault})) {
- fatal("500 Internal Error",
- '$cvstreedefault points to a repository (%s) not defined in %%CVSROOT (edit your configuration file %s)',
- $cvstreedefault, $config);
-}
+$defaultDiffType = $input{f};
+$logsort = $input{logsort};
+
# alternate CVS-Tree, configured in cvsweb.conf
-if ($input{'cvsroot'} && $CVSROOT{$input{'cvsroot'}}) {
- $cvstree = $input{'cvsroot'};
+if ($input{cvsroot} && $CVSROOT{$input{cvsroot}}) {
+ $cvstree = $input{cvsroot};
} else {
- $cvstree = $cvstreedefault;
+ $cvstree = $cvstreedefault;
}
$cvsroot = $CVSROOT{$cvstree};
# create icons out of description
foreach my $k (keys %ICONS) {
- no strict 'refs';
- my ($itxt, $ipath, $iwidth, $iheight) = @{$ICONS{$k}};
- if ($ipath) {
- ${"${k}icon"} =
- sprintf(
- '%s
', - $config_cvstree, $@); + do "$config_cvstree" + or fatal("500 Internal Error", + 'Error in loading configuration file: %s
%s
', + $config_cvstree, $@); } undef $config_cvstree; -$re_prcategories = '(?:' . join ('|', @prcategories) . ')' if @prcategories; -$re_prkeyword = quotemeta($prkeyword) if defined($prkeyword); -$prcgi .= '%s' if defined($prcgi) && $prcgi !~ /%s/; +$re_prcategories = '(?:' . join ('|', @prcategories) . ')' if @prcategories; +$re_prkeyword = quotemeta($prkeyword) if defined($prkeyword); +$prcgi .= '%s' if defined($prcgi) && $prcgi !~ /%s/; -$fullname = "$cvsroot/$where"; -$mimetype = &getMimeTypeFromSuffix($fullname); -$defaultTextPlain = ($mimetype eq "text/plain"); -$defaultViewable = $allow_markup && viewable($mimetype); +$fullname = catfile($cvsroot, $where); my $rewrite = 0; - if ($pathinfo =~ m|//|) { - $pathinfo =~ y|/|/|s; - $rewrite = 1; + $pathinfo =~ y|/|/|s; + $rewrite = 1; } - -if (-d $fullname && $pathinfo !~ m|/$|) { - $pathinfo .= '/'; - $rewrite = 1; +if (-d $fullname) { + if ($pathinfo !~ m|/$|) { + $pathinfo .= '/'; + $rewrite = 1; + } +} elsif ($pathinfo =~ m|/$|) { + chop $pathinfo; + $rewrite = 1; } - -if (!-d $fullname && $pathinfo =~ m|/$|) { - chop $pathinfo; - $rewrite = 1; -} - if ($rewrite) { - redirect($scriptname . urlencode($pathinfo) . $query); + redirect($scriptname . uri_escape_path($pathinfo) . $query, 1); } - undef $rewrite; +undef $pathinfo; + 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.'); + 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.'); } # -# See if the module is in our forbidden list. +# Short-circuit forbidden things. Note that $fullname should not change +# after this, because the rest of the code assumes this check has already +# been done. # -$where =~ m:([^/]*):; -$module = $1; -if ($module && &forbidden_module($module)) { - fatal("403 Forbidden", - 'Access to %s forbidden.', - $where); -} +fatal('403 Forbidden', 'Access to %s forbidden.', $where) + if forbidden($fullname); # # 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 ($ext) = ($1 =~ /(\.tar\.gz|\.zip)$/); - my ($basedir) = ($module =~ m,([^/]+)$,); + fatal('403 Forbidden', 'Downloading tarballs is prohibited.') + unless $allow_tar; - if ($basedir eq '' || $module eq '') { - fatal("500 Internal Error", - 'You cannot download the top level directory.'); - } + my ($module) = ($where =~ m,^/?(.*),); # untaint + $module =~ s,/([^/]*)$,,; + my ($ext) = ($1 =~ /(\.t(?:ar\.)?gz|\.zip)$/); + my ($basedir) = ($module =~ m,([^/]+)$,); - my $tmpexportdir = "$tmpdir/.cvsweb.$$." . int(time); + if ($basedir eq '' || $module eq '') { + fatal('500 Internal Error', + 'You cannot download the top level directory.'); + } - mkdir($tmpexportdir, 0700) - or fatal("500 Internal Error", - 'Unable to make temporary directory: %s', - $!); + my $istar = ($ext eq '.tar.gz' || $ext eq '.tgz'); + if ($istar) { + fatal('500 Internal Error', 'tar command not found.') unless $CMD{tar}; + fatal('500 Internal Error', 'gzip command not found.') unless $CMD{gzip}; + } + my $iszip = ($ext eq '.zip'); + if ($iszip && !$CMD{zip}) { + fatal('500 Internal Error', 'zip command not found.'); + } + if (!$istar && !$iszip) { + fatal('500 Internal Error', 'Unsupported archive type.'); + } - my @fatal; + my $tmpexportdir; + eval { + local $SIG{__DIE__}; + # Don't use the CLEANUP argument to tempdir() here, since we might be under + # mod_perl (the process runs for a long time), unlink explicitly later. + $tmpexportdir = tempdir('.cvsweb.XXXXXXXX', TMPDIR => 1); + }; + if ($@) { + fatal('500 Internal Error', 'Unable to make temporary directory: %s', $@); + } + if (!chdir($tmpexportdir)) { + fatal('500 Internal Error', + "Can't cd to temporary directory %s: %s", $tmpexportdir, $!); + } - my $tag = - (exists $input{only_with_tag} && length $input{only_with_tag}) ? - $input{only_with_tag} : "HEAD"; + my @fatal; + my $tag = $input{only_with_tag} || 'HEAD'; + $tag = 'HEAD' if ($tag eq 'MAIN'); - if ($tag eq 'MAIN') { - $tag = 'HEAD'; - } + my @cmd = + ($CMD{cvs}, @cvs_options, '-Qd', $cvsroot, 'export', '-r', $tag, + '-d', $basedir, $module); + my $export_err; + my ($errcode, $err) = runproc(\@cmd, '2>', \$export_err); + if ($errcode) { + @fatal = + ('500 Internal Error', + 'Export failure (exit status %s), output:
%s', + $errcode, $err || $export_err); - if (system $CMD{cvs}, @cvs_options, '-Qd', $cvsroot, 'export', '-r', - $tag, '-d', "$tmpexportdir/$basedir", $module) - { - @fatal = ("500 Internal Error", - 'cvs co failure: %s: %s', - $!, $module); - } else { - $| = 1; # Essential to get the buffering right. + } else { - if ($ext eq '.tar.gz') { - print "Content-Type: application/x-gzip\r\n\r\n"; + $| = 1; # Essential to get the buffering right. + local (*TAR_OUT); - system - "$CMD{tar} @tar_options -cf - -C $tmpexportdir $basedir | $CMD{gzip} @gzip_options -c" - and @fatal = - ("500 Internal Error", - 'tar zc failure: %s: %s', - $!, $basedir); - } elsif ($ext eq '.zip' && $CMD{zip}) { - print "Content-Type: application/zip\r\n\r\n"; + my (@cmd, $ctype); + if ($istar) { + my @tar = ($CMD{tar}, @tar_options, '-cf', '-', $basedir); + my @gzip = ($CMD{gzip}, @gzip_options, '-c'); + push(@cmd, \@tar, '|', \@gzip); + $ctype = 'application/x-gzip'; + } elsif ($iszip) { + my @zip = ($CMD{zip}, @zip_options, '-r', '-', $basedir); + push(@cmd, \@zip, \''); + $ctype = 'application/zip'; + } + push(@cmd, '>pipe', \*TAR_OUT); - system - "cd $tmpexportdir && $CMD{zip} @zip_options -r - $basedir" - and @fatal = - ("500 Internal Error", - 'zip failure: %s: %s', - $!, $basedir); - } else { - @fatal = - ("500 Internal Error", - 'unsupported file type'); - } - } + my ($h, $err) = startproc(@cmd); + if ($h) { + print "Content-Type: $ctype\r\n\r\n"; + local $/ = undef; + print
%s', + $istar ? 'Tar' : 'Zip', $? >> 8 || -1, $err); + } + } - system $CMD{rm}, '-rf', $tmpexportdir if -d $tmpexportdir; + # Clean up. + rmtree($tmpexportdir); - &fatal(@fatal) if @fatal; + &fatal(@fatal) if @fatal; - exit; + exit; } ############################## # View a directory ############################### if (-d $fullname) { - my $dh = do { local (*DH); }; - opendir($dh, $fullname) or fatal("404 Not Found", - '%s: %s', - $where, $!); - my @dir = readdir($dh); - closedir($dh); - my @subLevelFiles = findLastModifiedSubdirs(@dir) - if ($show_subdir_lastmod); - getDirLogs($cvsroot, $where, @subLevelFiles); - if ($where eq '/') { - html_header($defaulttitle); - $long_intro =~ s/!!CVSROOTdescr!!/$CVSROOTdescr{$cvstree}/g; - print $long_intro; - } else { - html_header($where); - print $short_instruction; - } + my $dh = do { local (*DH); }; + opendir($dh, $fullname) or fatal("404 Not Found", '%s: %s', $where, $!); + my @dir = grep(!forbidden(catfile($fullname, $_)), readdir($dh)); + closedir($dh); + my @subLevelFiles = findLastModifiedSubdirs(@dir) if $show_subdir_lastmod; + my @unreadable = getDirLogs($cvsroot, $where, @subLevelFiles); - if ($use_descriptions && open(DESC, "<$cvsroot/CVSROOT/descriptions")) - { - while (
%s', $cr);
+ }
+ my @cmd = ($CMD{cvs}, @cvs_options, '-d', $cr, 'co', '-p', "-r$rev",$co);
+ local (*CVS_OUT, *CVS_ERR);
+ my ($h, $err) = startproc(\@cmd, \"", '>pipe', \*CVS_OUT,
+ '2>pipe', \*CVS_ERR);
+ fatal('500 Internal Error', $err) unless $h;
+ if ($html) {
+ local $/ = undef;
+ print \n";
+ while (
';
+ }
+ print "
Current directory: ", &clickablePath($where, 0), - "
\n"; + print "\n"; - print "Current tag: ", $input{only_with_tag},"
\n" - if $input{only_with_tag}; + # give direct access to dirs + if ($where eq '/') { + chooseMirror(); + chooseCVSRoot(); - } + } else { + print 'Current directory: ', clickablePath($where, 0), ''; + if ($cvshistory_url) { + (my $d = $where) =~ s|^/*(.*?)/*$|$1|; + print ' - ', history_link($d, ''); + } + print "
\n"; + print "Current tag: ", htmlquote($input{only_with_tag}), "
\n" + if $input{only_with_tag}; + } - print "\n"; + print "
\n"; - # Using \n"); + print "\n"; - if ($filesexists && !$filesfound) { - print - "
NOTE: There are $filesexists files, but none matches the current tag ($input{only_with_tag}).
\n"; - } - if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}})) - { - %tags = %alltags - } + if ((my $num = scalar(@unreadable)) && ! $input{hidenonreadable}) { + printf(<+ %s + +EOF + } - if (scalar %tags || $input{only_with_tag} || $edit_option_form - || defined($input{"options"})) - { - print "
\n"; - } + if ($filesexists && !$filesfound) { + my $currtag = defined($input{only_with_tag}) ? + sprintf(' (%s)', htmlquote($input{only_with_tag})) : ''; + printf(<
\n"; + } - if ($allow_tar) { - my ($basefile) = ($where =~ m,(?:.*/)?([^/]+),); + if (scalar %tags || $input{only_with_tag}) { + print " +EOF + } - if (defined($basefile) && $basefile ne '') { - print "
\n", - "
Download this directory in ";
+ if ($allow_tar && $filesfound) {
+ my ($basefile) = ($where =~ m,(?:.*/)?([^/]+),);
+ my $havetar = $CMD{tar} && $CMD{gzip};
+ my $havezip = $CMD{zip};
+ if (defined($basefile) && $basefile ne '' && ($havetar || $havezip)) {
+ my $q = ($query ? "$query;" : '?') . 'tarball=1';
+ print "
\n", + '
\n";
- }
- }
+ if ($edit_option_form || defined($input{options})) {
- if ($edit_option_form || defined($input{"options"})) {
-
- my $formwhere = $scriptwhere;
- $formwhere =~ s|Attic/?$|| if ($input{'hideattic'});
-
- print "\n";
- }
- html_footer();
+ print <\n", + '
Download this directory in ';
+ # Mangle the filename so browsers show a reasonable filename to download.
+ my @types = ();
+ $basefile = uri_escape($basefile);
+ push(@types, &link('tarball', "$basefile.tar.gz$q")) if $havetar;
+ push(@types, &link('zip archive', "$basefile.zip$q")) if $havezip;
+ print join(' or ', @types), "
\n";
+ }
+ }
- # Mangle the filename so browsers show a reasonable
- # filename to download.
- print &link("tarball", "./$basefile.tar.gz$query"
- . ($query ? "&" : "?") . "tarball=1");
- if ($CMD{zip}) {
- print " or ",
- &link("zip archive", "./$basefile.zip$query"
- . ($query ? "&" : "?") . "tarball=1");
- }
- print "Error: ',
+ sprintf($format, map(htmlquote($_), @args)), "
\n";
+ html_footer();
+ exit(1);
}
-sub fatal($$@) {
- my ($errcode, $format, @args) = @_;
- if ($is_mod_perl) {
- Apache->request->status((split (/ /, $errcode))[0]);
- } else {
- print "Status: $errcode\r\n";
- }
- html_header("Error");
- print "Error: ", - sprintf($format, map(htmlquote($_), @args)), - "
\n"; - html_footer(); - exit(1); + +# +# Signal a (fatal) configuration error. +# +sub config_error($$) +{ + fatal('500 Internal Error', + 'Error loading configuration file "%s":' . + '%s
', @_); } -sub redirect($) { - my ($url) = @_; - if ($is_mod_perl) { - Apache->request->status(301); - Apache->request->header_out(Location => $url); - } else { - print "Status: 301 Moved\r\n"; - print "Location: $url\r\n"; - } - html_header("Moved"); - print "
This document is located ", &link('here', $url), "
\n"; - html_footer(); - exit(1); + +# +# Sends a redirect to the given URL. +# +sub redirect($;$) +{ + my ($url, $permanent) = @_; + my ($status, $text); + if ($permanent) { + $status = '301'; + $text = 'Moved Permanently'; + } else { + $status = '302'; + $text = 'Found'; + } + print "Status: $status $text\r\n", "Location: $url\r\n"; + html_header($text); + print "This document has moved ", &link('here', $url), ".
\n"; + html_footer(); + exit(1); } -sub safeglob($) { - my ($filename) = @_; - my ($dirname); - my (@results); - my $dh = do { local (*DH); }; - ($dirname = $filename) =~ s|/[^/]+$||; - $filename =~ s|.*/||; +sub safeglob($) +{ + my ($filename) = @_; - if (opendir($dh, $dirname)) { - my $glob = $filename; - my $t; + (my $dirname = $filename) =~ s|/[^/]+$||; + $filename =~ s|.*/||; - # transform filename from glob to regex. Deal with: - # [, {, ?, * as glob chars - # make sure to escape all other regex chars - $glob =~ s/([\.\(\)\|\+])/\\$1/g; - $glob =~ s/\*/.*/g; - $glob =~ s/\?/./g; - $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg; - foreach (readdir($dh)) { + my @results; + my $dh = do { local (*DH); }; + if (opendir($dh, $dirname)) { + my $glob = $filename; + my $t; - if (/^${glob}$/) { - push (@results, "$dirname/" . $_); - } - } - closedir($dh); - } + # transform filename from glob to regex. Deal with: + # [, {, ?, * as glob chars + # make sure to escape all other regex chars + $glob =~ s/([\.\(\)\|\+])/\\$1/g; + $glob =~ s/\*/.*/g; + $glob =~ s/\?/./g; + $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg; + $glob = qr/^$glob$/; - @results; + foreach (readdir($dh)) { + if ($_ =~ $glob && $_ =~ VALID_PATH) { + push(@results, catfile($dirname, $1)); # untaint + } + } + closedir($dh); + } + + return @results; } -sub search_path($) { - my ($command) = @_; - my $d; - for $d (split (/:/, $command_path)) { - return "$d/$command" if -x "$d/$command"; - } +# +# Searches @command_path for the given executable file. +# +sub search_path($) +{ + my ($command) = @_; + for my $d (@command_path) { + my $cmd = catfile($d, $command); + return $cmd if (-x $cmd && !-d _); + } + return ''; +} - ''; + +# +# Gets the enscript(1) highlight mode corresponding to the given filename, +# or undef if unsupported. +# +sub getEnscriptHL($) +{ + return undef unless $allow_enscript; + my ($filename) = @_; + while (my ($hl, $regex) = each %enscript_types) { + return $hl if ($filename =~ $regex); + } + return undef; } -sub getMimeTypeFromSuffix($) { - my ($fullname) = @_; - my ($mimetype, $suffix); - my $fh = do { local (*FH); }; - ($suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/; - $mimetype = $MTYPES{$suffix}; - $mimetype = $MTYPES{'*'} if (!$mimetype); +# +# Gets the MIME type for the given file name. +# +sub getMimeType($;$) +{ + my ($fullname, $binary) = @_; + $binary = ($keywordsubstitution && $keywordsubstitution =~ /b/) + unless defined($binary); - if (!$mimetype && -f $mime_types) { + (my $suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/; - # okey, this is something special - search the - # mime.types database - open($fh, "<$mime_types"); - while (<$fh>) { - if ($_ =~ /^\s*(\S+\/\S+).*\b$suffix\b/) { - $mimetype = $1; - last; - } - } - close($fh); - } + my $mimetype = $MTYPES{$suffix}; + $mimetype ||= $MimeTypes->mimeTypeOf($fullname) if defined($MimeTypes); - # okey, didn't find anything useful .. - if (!($mimetype =~ /\S\/\S/)) { - $mimetype = "text/plain"; - } - return $mimetype; + if (!$mimetype && $suffix ne '*' && -f $mime_types && -r _) { + my $fh = do { local (*FH); }; + if (open($fh, $mime_types)) { + my $re = sprintf('^\s*(\S+\/\S+)\s.+\b%s\b', quotemeta($suffix)); + $re = qr/$re/; + while (my $line = <$fh>) { + if ($line =~ $re) { + $mimetype = $1; + $MTYPES{$suffix} = $mimetype; + last; + } + } + close($fh); + } else { + warn("Can't open MIME types file $mime_types for reading: $!"); + } + } + + $mimetype ||= $MTYPES{'*'}; + $mimetype ||= $binary ? 'application/octet-stream' : 'text/plain'; + return $mimetype; } + ############################### # read first lines like head(1) ############################### -sub head($;$) { - my $fh = $_[0]; - my $linecount = $_[1] || 10; +sub head($;$) +{ + my ($fh, $linecount) = @_; + $linecount ||= 10; - my @buf; - - if ($linecount > 0) { - my $i; - for ($i = 0 ; !eof($fh) && $i < $linecount ; $i++) { - push @buf, scalar <$fh>; - } - } else { - @buf = <$fh>; - } - - @buf; + my @buf; + if ($linecount > 0) { + for (my $i = 0; !eof($fh) && $i < $linecount; $i++) { + push @buf, scalar <$fh>; + } + } else { + @buf = <$fh>; + } + return @buf; } + ############################### # scan vim and Emacs directives ############################### -sub scan_directives(@) { - my $ts = undef; +sub scan_directives(@) +{ + my $ts = undef; - for (@_) { - $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/; - } + for (@_) { + $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/; + } - ('tabstop' => $ts); + ('tabstop' => $ts); } -sub openOutputFilter() { - return if !defined($output_filter) || $output_filter eq ''; - open(STDOUT, "|-") and return; +sub openOutputFilter() +{ + return unless $output_filter; - # child of child - open(STDERR, '>/dev/null'); - exec($output_filter) or exit -1; + open(STDOUT, "|-") and return; + + # child of child + open(STDERR, '>', devnull()) unless $DEBUG; + exec($output_filter) or exit -1; } + ############################### # show Annotation ############################### -sub doAnnotate($$) { - my ($rev) = @_; - my ($pid); - my ($pathname, $filename); - my $reader = do { local (*FH); }; - my $writer = do { local (*FH); }; +sub doAnnotate($$) +{ + my ($rev, $tag) = @_; + $rev = $tag || 'HEAD' if ($rev eq '.'); + (my $pathname = $where) =~ s|((?<=/)Attic/)?[^/]*$||; + (my $filename = $where) =~ s|^.*/||; - # make sure the revisions are wellformed, for security - # reasons .. - if ($rev =~ /[^\w.]/) { - fatal("404 Not Found", - 'Malformed query "%s"', - $ENV{QUERY_STRING}); - } + # This annotate version is based on the cvs annotate-demo Perl script by + # Cyclic Software. It was written by Cyclic Software, + # http://www.cyclic.com/, and is in the public domain. + # We could abandon the use of rlog, rcsdiff and co using + # the cvs server in a similiar way one day (..after rewrite). - ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//; - ($filename = $where) =~ s/^.*\///; + local (*CVS_IN, *CVS_OUT); + my $annotate_err; + my ($h, $err) = + startproc([ $CMD{cvs}, @annotate_options, 'server' ], + '%s', + $? >> 8 || -1, $err) + unless $h; - # this seems to be necessary - $| = 1; - $| = 0; # Flush + # OK, first send the request to the server. A simplified example is: + # Root /home/kingdon/zwork/cvsroot + # Argument foo/xx + # Directory foo + # /home/kingdon/zwork/cvsroot/foo + # Directory . + # /home/kingdon/zwork/cvsroot + # annotate + # although as you can see there are a few more details. - # Work around a mod_perl bug (?) in order to make open2() work. - # Search for "untie STDIN" in mod_perl mailing list archives. - my $old_stdin; - if ($is_mod_perl && ($old_stdin = tied *STDIN)) { - local $^W = undef; - untie *STDIN; - } + print CVS_IN "Root $cvsroot\n"; + print CVS_IN + "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n"; - # this annotate version is based on the - # cvs annotate-demo Perl script by Cyclic Software - # It was written by Cyclic Software, http://www.cyclic.com/, and is in - # 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, $CMD{cvs}, @annotate_options, 'server') - or fatal("500 Internal Error", - 'Fatal Error - unable to open cvs for annotation'); + # Don't worry about sending valid-requests, the server just needs to + # support "annotate" and if it doesn't, there isn't anything to be done. + print CVS_IN "UseUnchanged\n"; + print CVS_IN "Argument -r\n"; + print CVS_IN "Argument $rev\n"; + print CVS_IN "Argument $where\n"; - # Re-tie STDIN if we fiddled around with it earlier, just to be sure. - tie(*STDIN, ref($old_stdin), $old_stdin) if ($old_stdin && !tied(*STDIN)); + # The protocol requires us to fully fake a working directory (at + # 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 $path = ''; + foreach my $dir (split('/', $where)) { - # OK, first send the request to the server. A simplified example is: - # Root /home/kingdon/zwork/cvsroot - # Argument foo/xx - # Directory foo - # /home/kingdon/zwork/cvsroot/foo - # Directory . - # /home/kingdon/zwork/cvsroot - # annotate - # although as you can see there are a few more details. + if ($path eq "") { + # In our example, $dir is "dir". + $path = $dir; + } else { + print CVS_IN "Directory $path\n"; + print CVS_IN "$cvsroot/$path\n"; - print $writer "Root $cvsroot\n"; - print $writer - "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\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 .= "/$dir"; + } + } + undef $path; - # Don't worry about sending valid-requests, the server just needs to - # support "annotate" and if it doesn't, there isn't anything to be done. - print $writer "UseUnchanged\n"; - print $writer "Argument -r\n"; - print $writer "Argument $rev\n"; - print $writer "Argument $where\n"; + # And the last "Directory" before "annotate" is the top level. + print CVS_IN "Directory .\n"; + print CVS_IN "$cvsroot\n"; - # The protocol requires us to fully fake a working directory (at - # 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 $path = ""; - foreach (@dirs) { + print CVS_IN "annotate\n"; - if ($path eq "") { + # OK, we've sent our command to the server. Thing to do is to + # close the writer side and get all the responses. + if (!close(CVS_IN)) { + $h->finish(); + fatal('500 Internal Error', + 'Annotate failure (exit status %s):
%s, output: ' .
+ '%s', $? >> 8, $!, $annotate_err); + } - # In our example, $_ is "dir". - $path = $_; - } else { - print $writer "Directory $path\n"; - print $writer "$cvsroot/$path\n"; + navigateHeader($scriptwhere, $pathname, $filename, $rev, 'annotate'); - # 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 .= "/$_"; - } - } + my $revtype = ($rev =~ /\./) ? 'revision' : 'tag'; # TODO: tag -> branch/tag? + print '
Annotation of ', + htmlquote("$pathname$filename"), ", $revtype $rev
\n"; - # And the last "Directory" before "annotate" is the top level. - print $writer "Directory .\n"; - print $writer "$cvsroot\n"; + # Ready to get the responses from the server. + # For example: + # E Annotations for foo/xx + # E *************** + # M 1.3 (kingdon 06-Sep-97): hello + # ok + my ($lineNr) = 0; + my ($oldLrev, $oldLusr) = ("", ""); + my ($revprint, $usrprint); - print $writer "annotate\n"; + if ($annTable) { + print <"; + } - # OK, we've sent our command to the server. Thing to do is to - # close the writer side and get all the responses. If "cvs server" - # were nicer about buffering, then we could just leave it open, I think. - close($writer) or die "cannot close: $!"; + # prefetch several lines + my @buf = head(*CVS_OUT); - http_header(); + my %d = scan_directives(@buf); - navigateHeader($scriptwhere, $pathname, $filename, $rev, "annotate"); - print - ""; + } + html_footer(); +} - printf "%s%s %-8s %4d:", $revprint, - $isCurrentRev ? '!' : ' ', $usrprint, $lineNr; - print spacedHtmlText($line, $d{'tabstop'}); +############################### +# make Checkout +############################### +sub doCheckout($$$) +{ + my ($fullname, $rev, $tag) = @_; + $rev = $tag || undef if (!$rev || $rev eq '.'); - print "" if ($isCurrentRev && $is_textbased); - } elsif ($words[0] eq "ok") { + # Start resolving whether we will do a markup view or not. + my $do_markup = undef; + my $want_type = $input{'content-type'}; - # We could complain about any text received after this, like the - # CVS command line client. But for simplicity, we don't. - } elsif ($words[0] eq "error") { - fatal("500 Internal Error", - 'Error occured during annotate: %s', - $_); - } - } + # No markup if markup disallowed. + $do_markup = 0 unless $allow_markup; - if ($annTable) { - print ""; - } else { - print ""; - } - html_footer(); + # No markup if checkout magic cookie in URL. + $do_markup = 0 if (!defined($do_markup) && $doCheckout); - close($reader) or warn "cannot close: $!"; - wait; -} + # Do markup if explicitly asked using cvsweb-markup content type. If the + # asked content type is anything else, no markup. + if (!defined($do_markup) && $want_type) { + if ($want_type =~ CVSWEBMARKUP) { + $want_type = undef; + $do_markup = 1; + } else { + $do_markup = 0; + } + } -############################### -# make Checkout -############################### -sub doCheckout($$) { - my ($fullname, $rev) = @_; - my ($mimetype, $revopt); - my $fh = do { local (*FH); }; + # Ok, if $do_markup is still undefined, we know that a download has not been + # explicitly asked. For the last check further down below we'll need to + # know if the file is binary, and possibly run a log on it. + my $needlog = $do_markup || $use_moddate; - if ($rev eq 'HEAD' || $rev eq '.') { - $rev = undef; - } + my $moddate = undef; + my $revopt; + if (defined($rev)) { + $revopt = "-r$rev"; + if ($needlog) { + readLog($fullname, $rev); + $moddate = $date{$rev}; + # TODO: even this does not work for branch tags, but only normal tags :( + $moddate ||= $date{$symrev{$rev}} if defined($symrev{$rev}); + } + } else { + $revopt = "-rHEAD"; + if ($needlog) { + readLog($fullname); + $moddate = $date{$symrev{HEAD}}; + } + } - # make sure the revisions a wellformed, for security - # reasons .. - if (defined($rev) && $rev =~ /[^\w.]/) { - fatal("404 Not Found", - 'Malformed query "%s"', - $ENV{QUERY_STRING}); - } + my $cr = abs_path($cvsroot) || $cvsroot; + # abs_path() taints when run as a CGI... + if ($cr =~ VALID_PATH) { + $cr = $1; + } else { + fatal('500 Internal Error', 'Illegal CVS root:Annotation of $pathname$filename, Revision $rev
\n"; + while (@buf || !eof(*CVS_OUT)) { - # Ready to get the responses from the server. - # For example: - # E Annotations for foo/xx - # E *************** - # M 1.3 (kingdon 06-Sep-97): hello - # ok - my ($lineNr) = 0; - my ($oldLrev, $oldLusr) = ("", ""); - my ($revprint, $usrprint); + $_ = @buf ? shift @buf :; + my @words = split; - if ($annTable) { - print " \n"; - } else { - print "
"; + } else { + print ""; - } + # Adding one is for the (single) space which follows $words[0]. + my $rest = substr($_, length($words[0]) + 1); + if ($words[0] eq "E") { + next; + } elsif ($words[0] eq "M") { + $lineNr++; + (my $lrev = substr($_, 2, 13)) =~ y/ //d; + (my $lusr = substr($_, 16, 9)) =~ y/ //d; + my $line = substr($_, 36); + # TODO: this does not work for branch/tag revisions. + my $isCurrentRev = ($rev eq $lrev); - # prefetch several lines - my @buf = head($reader); + # we should parse the date here .. + if ($lrev eq $oldLrev) { + $revprint = sprintf('%-8s', ''); + } else { + $revprint = sprintf('%-8s', $lrev); + $revprint =~ s|(\S+)|&link($1, uri_escape($filename)."$query#rev$1")|e; + $oldLusr = ''; + } - my %d = scan_directives(@buf); + $usrprint = ($lusr eq $oldLusr) ? '' : $lusr; + $oldLrev = $lrev; + $oldLusr = $lusr; - while (@buf || !eof($reader)) { - $_ = @buf ? shift @buf : <$reader>; + print $is_textbased ? '' : '' + if $isCurrentRev; - my @words = split; + $usrprint = sprintf('%-8s', $usrprint); + printf '%s%s %s %4d:', $revprint, $isCurrentRev ? '!' : ' ', + htmlquote($usrprint), $lineNr; + print spacedHtmlText($line, $d{tabstop}); - # Adding one is for the (single) space which follows $words[0]. - my $rest = substr($_, length($words[0]) + 1); - if ($words[0] eq "E") { - next; - } elsif ($words[0] eq "M") { - $lineNr++; - (my $lrev = substr($_, 2, 13)) =~ y/ //d; - (my $lusr = substr($_, 16, 9)) =~ y/ //d; - my $line = substr($_, 36); - my $isCurrentRev = ($rev eq $lrev); + print $is_textbased ? '' : '' if $isCurrentRev; - # we should parse the date here .. - if ($lrev eq $oldLrev) { - $revprint = sprintf('%-8s', ''); - } else { - $revprint = sprintf('%-8s', $lrev); - $revprint =~ - s`\S+`&link($&, "$scriptwhere$query#rev$&")`e - ; # ` - $oldLusr = ''; - } + } elsif ($words[0] eq "ok") { + # We could complain about any text received after this, like the + # CVS command line client. But for simplicity, we don't. - if ($lusr eq $oldLusr) { - $usrprint = ''; - } else { - $usrprint = $lusr; - } - $oldLrev = $lrev; - $oldLusr = $lusr; + } elsif ($words[0] eq "error") { + fatal("500 Internal Error", + 'Error occured during annotate: %s', $_); + } + } + $h->finish(); - # Set bold for text-based browsers only - graphical - # browsers show bold fonts a bit wider than regular fonts, - # so it looks irregular. - print "" if ($isCurrentRev && $is_textbased); + if ($annTable) { + print "
%s', $cr);
+ }
+ # Use abs_path() to work around a bug of cvs -p; expand symlinks if we can.
+ my @cmd = ($CMD{cvs}, @cvs_options, '-d', $cr, 'co', '-p', $revopt, $where);
- # get mimetype
- if (defined($input{"content-type"})
- && ($input{"content-type"} =~ /\S\/\S/))
- {
- $mimetype = $input{"content-type"}
- } else {
- $mimetype = &getMimeTypeFromSuffix($fullname);
- }
+ local (*CVS_OUT, *CVS_ERR);
+ my ($h, $err) =
+ startproc(\@cmd, \"", '>pipe', \*CVS_OUT, '2>pipe', \*CVS_ERR);
+ fatal('500 Internal Error',
+ 'Checkout failure (exit status %s), output: %s', + $? >> 8 || -1, $err) + unless $h; - if (defined($rev)) { - $revopt = "-r$rev"; - if ($use_moddate) { - readLog($fullname, $rev); - $moddate = $date{$rev}; - } - } else { - $revopt = "-rHEAD"; + if (eof(CVS_ERR)) { + $h->finish(); + fatal("404 Not Found", '%s is not (any longer) pertinent', $where); + } - if ($use_moddate) { - readLog($fullname); - $moddate = $date{$symrev{HEAD}}; - } - } + #=================================================================== + #Checking out squid/src/ftp.c + #RCS: /usr/src/CVS/squid/src/ftp.c,v + #VERS: 1.1.1.28.6.2 + #*************** - ### just for the record: - ### 'cvs co' seems to have a bug regarding single checkout of - ### directories/files having spaces in it; - ### this is an issue that should be resolved on cvs's side - # - # Safely for a child process to read from. - if (!open($fh, "-|")) { # child - # chdir to $tmpdir before to avoid non-readable cgi-bin directories - chdir($tmpdir); - open(STDERR, ">&STDOUT"); # Redirect stderr to stdout + # Parse CVS header + my ($revision, $filename, $cvsheader); + $filename = ""; + while (
%s' . + '(expected "
%s" but got "%s")',
+ $cvsheader, $where, $filename);
+ }
- #===================================================================
- #Checking out squid/src/ftp.c
- #RCS: /usr/src/CVS/squid/src/ftp.c,v
- #VERS: 1.1.1.28.6.2
- #***************
+ # Last checks whether we'll do markup or not.
+ my $isbin = $keywordsubstitution && $keywordsubstitution =~ /b/;
+ my $mimetype = getMimeType($fullname, $isbin);
- # Parse CVS header
- my ($revision, $filename, $cvsheader);
- $filename = "";
- while (<$fh>) {
- last if (/^\*\*\*\*/);
- $revision = $1 if (/^VERS: (.*)$/);
+ # If we still are not sure whether to do markup or not:
+ # if the MIME type is "viewable" or this is not a binary file, do.
+ $do_markup = !$isbin || viewable($mimetype) unless defined($do_markup);
- if (/^Checking out (.*)$/) {
- $filename = $1;
- $filename =~ s/^\.\/*//;
- }
- $cvsheader .= $_;
- }
+ if ($do_markup) {
- if ($filename ne $where) {
- fatal("500 Internal Error",
- 'Unexpected output from cvs co: %s',
- $cvsheader);
- }
- $| = 1;
+ # If this is something we'll be linking to in the markup view, we are
+ # done with this particular output from "cvs co" and must discard it.
+ my $linked = $mimetype =~ m{^image/|application/pdf$}i;
+ if ($linked) {
+ close(CVS_OUT);
+ $h->finish();
+ }
- if ($mimetype eq "text/x-cvsweb-markup") {
- &cvswebMarkup($fh, $fullname, $revision);
- } else {
- http_header($mimetype);
- print <$fh>;
- }
- close($fh);
+ # Here we know the last modified date, but don't know if tags have been
+ # added afterwards (those are shown in the markup view): no last-modified.
+ cvswebMarkup(\*CVS_OUT, $fullname, $revision, $isbin, $mimetype, $needlog);
+
+ $h->finish() unless $linked;
+
+ } else {
+ http_header($want_type || $mimetype, $moddate);
+ local $/ = undef;
+ print "; - print "
| ";
- print "File: ", &clickablePath($where, 1);
- print " (";
- &download_link($fileurl, $revision, "download");
- print ")";
+ navigateHeader($scriptwhere, $pathname, $filename, $rev, 'view', $mod);
- if (!$defaultTextPlain) {
- print " (";
- &download_link($fileurl, $revision, "as text", "text/plain");
- print ")";
- }
- print " \n"; + print <
+File:
+EOF
+ print &clickablePath($where, 1), " \n"; - if ($show_log_in_markup) { - readLog($fullname); #,$revision); - printLog($revision, 0); - } else { - print "Version: $revision \n"; - print "Tag: ", $input{only_with_tag}, " \n" - if $input{only_with_tag}; - } - print " | \n
"; + if ($show_log_in_markup) { + readLog($fullname) unless $logged; #,$rev); + printLog($rev, $mimetype, $isbin); + } else { + print "Revision: $rev
\n"; + print 'Tag: ', htmlquote($input{only_with_tag}), "
\n" + if $input{only_with_tag}; + } + print "\n
"; + my $url = download_url(uri_escape($filename), $rev, $mimetype); - if ($mimetype =~ /^image/) { - printf '
', hrefquote("$url$barequery"); - } elsif ($mimetype =~ m%^application/pdf%) { - printf '