#!/usr/bin/perl
# $Id: cvsweb.cgi,v 4.30 2019/11/29 14:29:48 schwarze Exp $
# $knu: cvsweb.cgi,v 1.299 2010/11/13 16:37:18 simon
#
# cvsweb - a CGI interface to CVS trees.
#
# Written in their spare time by
# Bill Fenner The server on which the CVS tree lives is probably down. Please try again in a few minutes.');
}
#
# 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.
#
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 =~ /(\.t(?:ar\.)?gz)$/);
my ($basedir) = ($module =~ m,([^/]+)$,);
if ($basedir eq '' || $module eq '') {
fatal('500 Internal Error',
'You cannot download the top level directory.');
}
unless ($ext eq '.tar.gz' || $ext eq '.tgz') {
fatal('404 Not Found', 'Unsupported archive type.');
}
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 @fatal;
my $tag = $input{only_with_tag} || 'HEAD';
$tag = 'HEAD' if ($tag eq 'MAIN');
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: \n";
while ( Current directory: ', clickablePath($where, 0), '';
print " Current tag: ", htmlquote($input{only_with_tag}), "%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});
}
$scriptname = '' unless defined($scriptname);
$where = $pathinfo;
$doCheckout = $where =~ s|^/$CheckoutMagic/|/|o;
$where =~ s|^/||;
$scriptname =~ s|^/+||;
# Let's workaround thttpd's stupidity..
if ($scriptname =~ m|/$|) {
$pathinfo .= '/';
my $re = quotemeta $pathinfo;
$scriptname =~ s/$re$//;
}
$scriptname = "/$scriptname" if $scriptname;
# $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 '');
# In text-based browsers, it's very annoying to have two links per file;
# skip linking the image for them.
$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`);
$is_mozilla3 = ($Browser =~ m`^Mozilla/[3-9]`);
$is_textbased = ($is_links || $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)
# It has been reported that these
# braindamaged MS-Internet Exploders claim that they
# accept gzip .. but don't in fact and
# 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} =~ /gzip/)
|| $is_mozilla3)
&& !$is_msie
&& !(defined($ENV{MOD_PERL}))
);
# 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.
{
$config =~ m|^/| or fatal '500 Internal Error',
'Configuration file name "%s
" is not an absolute path.',
$config;
defined do $config and last;
$@ and fatal '500 Internal Error',
'Error loading configuration file "%s
": %s
',
$config, $@;
fatal '500 Internal Error',
'Cannot read configuration file "%s
": %s',
$config, $! || 'unknown error';
}
# 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);
$key = uri_unescape($key);
$key =~ /([^a-z_12-])/ and fatal('404 Not Found',
'Invalid character "%s" in query parameter "%s"', $1, $key);
if (defined $val) {
$val = uri_unescape($val);
$val =~ /([^a-zA-Z_01-9.\/-])/ and fatal('404 Not Found',
'Invalid character "%s" in the value "%s" of the query parameter "%s"',
$1, $val, $key);
} else {
$val = 1;
}
$query{$key} = $val;
}
}
undef %input;
my $t;
for my $p (qw(hideattic hidecvsroot hidenonreadable ignorecase ln copt
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);
# --- end input parameters
#
# 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;
$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;
$DEFAULTVALUE{cvsroot} = $CVSrepositories[0];
while (my ($key, $defval) = each %DEFAULTVALUE) {
# 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 parameter
# in these forms (copt) which indicates that we just set parameters with a
# checkbox.
if ($input{copt}) {
# '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');
} 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{$_})
&& !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_}))
{
push(@barequery, join('=', uri_escape($_), uri_escape($input{$_})));
}
}
# is there any query ?
if (@barequery) {
$barequery = join (';', @barequery);
$query = "?$barequery";
$barequery = ";$barequery";
} else {
$query = "";
}
undef @barequery;
if (defined($input{path})) {
redirect("$scriptname/$input{path}$query");
}
# get actual parameters
{
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;
}
}
$defaultDiffType = $input{f};
$logsort = $input{logsort};
# alternate CVS-Tree, configured in cvsweb.conf
if ($input{cvsroot} && $CVSROOT{$input{cvsroot}}) {
$cvstree = $input{cvsroot};
} else {
$cvstree = $CVSrepositories[0];
}
$cvsroot = $CVSROOT{$cvstree};
# create icons out of description
foreach my $k (keys %ICONS) {
my ($itxt, $ipath, $iwidth, $iheight) = @{$ICONS{$k}};
no strict 'refs';
if ($ipath) {
${"${k}icon"} =
sprintf('',
htmlquote($ipath), htmlquote($itxt), $iwidth, $iheight);
} else {
${"${k}icon"} = $itxt;
}
}
my $config_cvstree = "$config-$cvstree";
# Do some special configuration for cvstrees
if (-f $config_cvstree) {
do "$config_cvstree"
or fatal("500 Internal Error",
'Error in loading configuration file: %s
%s
',
$config_cvstree, $@);
}
undef $config_cvstree;
$fullname = catfile($cvsroot, $where);
my $rewrite = 0;
if ($pathinfo =~ m|//|) {
$pathinfo =~ y|/|/|s;
$rewrite = 1;
}
if (-d $fullname) {
if ($pathinfo !~ m|/$|) {
$pathinfo .= '/';
$rewrite = 1;
}
} elsif ($pathinfo =~ m|/$|) {
chop $pathinfo;
$rewrite = 1;
}
if ($rewrite) {
redirect($scriptname . uri_escape_path($pathinfo) . $query, 1);
}
undef $rewrite;
undef $pathinfo;
if (!-d $cvsroot) {
fatal("500 Internal Error",
'$CVSROOT not found!%s
',
$errcode, $err || $export_err);
} else {
$| = 1; # Essential to get the buffering right.
local (*TAR_OUT);
my ($h, $err) = startproc($CMD{tar}, @tar_options, '-czf', '-',
$basedir, '>pipe', \*TAR_OUT);
if ($h) {
print "Content-Type: application/x-gzip\r\n\r\n";
local $/ = undef;
print %s
',
$? >> 8 || -1, $err);
}
}
# Clean up.
chdir("..");
rmtree($tmpexportdir);
&fatal(@fatal) if @fatal;
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 = grep(!forbidden(catfile($fullname, $_)), readdir($dh));
closedir($dh);
my @subLevelFiles = findLastModifiedSubdirs(@dir) if $show_subdir_lastmod;
my @unreadable = getDirLogs($cvsroot, $where, @subLevelFiles);
if ($where eq '/') {
html_header($defaulttitle);
$long_intro =~ s/!!CVSROOTdescr!!/$CVSROOTdescr{$cvstree}/g;
print $long_intro;
} else {
html_header($where);
my $html = (-f catfile($fullname, 'README.cvs.html,v') ||
-f catfile($fullname, 'Attic', 'README.cvs.html,v'));
my $text = (!$html &&
(-f catfile($fullname, 'README.cvs,v') ||
-f catfile($fullname, 'Attic', 'README.cvs,v')));
if ($html || $text) {
my $rev = $input{only_with_tag} || 'HEAD';
my $cr = abs_path($cvsroot) || $cvsroot;
my $co = "$where/README.cvs.html" if $html;
$co ||= "$where/README.cvs" if $text;
# abs_path() taints when run as a CGI...
if ($cr =~ VALID_PATH) {
$cr = $1;
} else {
fatal('500 Internal Error', 'Illegal CVS root: %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
';
}
print "
\n";
my $infocols = 1;
printf(<
EOF
printf(' \n";
my $dirrow = 0;
my $i;
lookingforattic:
for ($i = 0; $i <= $#dir; $i++) {
if ($dir[$i] eq "Attic") {
last lookingforattic;
}
}
if (!$input{hideattic}
&& ($i <= $#dir)
&& opendir($dh, $fullname . '/Attic'))
{
splice(@dir, $i, 1, grep((s|^|Attic/|, !m|/\.|), readdir($dh)));
closedir($dh);
}
my $hideAtticToggleLink =
$input{hideattic}
? ''
: &link('[hide]', sprintf('./%s#dirlist', &toggleQuery('hideattic')));
# Sort without the Attic/ pathname.
# place directories first
my $filesexists;
my $filesfound;
foreach my $file (sort { &fileSortCmp } @dir) {
next if ($file eq curdir());
# ignore CVS lock and stale NFS files
next if ($file =~ /^\#cvs\.|^,|^\.nfs/); # \# for XEmacs cperl-mode...
# Check whether to show the CVSROOT path
next if ($input{hidecvsroot} && $where eq '/' && $file eq 'CVSROOT');
# Is it a directory?
my $isdir = -d catdir($fullname, $file);
# Ignore non-readable files and directories?
next if ($input{hidenonreadable} && (! -r _ || ($isdir && ! -x _)));
my $attic = '';
if ($file =~ s|^Attic/||) {
$attic = ' (in the Attic) ' .
$hideAtticToggleLink . '';
}
if ($file eq updir() || $isdir) {
next if ($file eq updir() && $where eq '/');
my ($rev, $date, $log, $author, $filename, $keywordsubst) =
@{$fileinfo{$file}} if (defined($fileinfo{$file}));
printf "', ($byfile ? ' class="sorted"' : ''));
if ($byfile) {
print 'File';
} else {
print &link('File',
sprintf('./%s#dirlist', toggleQuery('sortby', 'file')));
}
print " \n";
# Do not display the other column headers if we do not have any files
# with revision information.
if (scalar(%fileinfo)) {
$infocols++;
printf('', ($byrev ? ' class="sorted"' : ''));
if ($byrev) {
print 'Rev.';
} else {
print &link('Rev.',
sprintf('./%s#dirlist', toggleQuery('sortby', 'rev')));
}
print " \n";
$infocols++;
printf('', ($bydate ? ' class="sorted"' : ''));
if ($bydate) {
print 'Age';
} else {
print &link('Age',
sprintf('./%s#dirlist', toggleQuery('sortby', 'date')));
}
print " \n";
if ($show_author) {
$infocols++;
printf('', ($byauthor ? ' class="sorted"' : ''));
if ($byauthor) {
print 'Author';
} else {
print
&link('Author',
sprintf('./%s#dirlist', toggleQuery('sortby', 'author')));
}
print " \n";
}
$infocols++;
printf('', ($bylog ? ' class="sorted"' : ''));
if ($bylog) {
print 'Last log entry';
} else {
print &link('Last log entry',
sprintf('./%s#dirlist', toggleQuery('sortby', 'log')));
}
print " \n";
} elsif ($use_descriptions) {
print "Description \n";
$infocols++;
}
print "\n \n";
$dirrow++;
} elsif ($file =~ s/,v$//) {
my $fileurl = ($attic ? 'Attic/' : '') . uri_escape_path($file);
my $url = './' . $fileurl . $query;
$filesexists++;
next if (!defined($fileinfo{$file}));
my ($rev, $date, $log, $author, $filename, $keywordsubst) =
@{$fileinfo{$file}};
my $isbinary = $keywordsubst eq 'b' ? 1 : 0;
$filesfound++;
printf "",
($dirrow % 2) ? 'even' : 'odd';
if ($file eq updir()) {
my $url = "../$query";
print $nofilelinks ? $backicon : &link($backicon, $url);
print ' ', &link("Parent Directory", $url);
} else {
my $url = './' . uri_escape_path($file) . "/$query";
print '';
print $nofilelinks ? $diricon : &link($diricon, $url);
print ' ', &link(htmlquote("$file/"), $url), $attic;
if ($file eq "Attic") {
print ' ',
&link('[show]',
sprintf('./%s#dirlist', &toggleQuery('hideattic'))),
'';
}
}
# Show last change in dir
if ($filename) {
my $ageclass = 'age';
my $age = '';
if ($date) {
$age = readableTime(time() - $date, 0);
$ageclass .= " $1" if ($age =~ /^\d+ ([a-z]+)/);
}
print " \n \n$age";
print " \n", htmlquote($author)
if $show_author;
print " \n";
$filename =~ s%^[^/]+/%%;
print &link(htmlquote("$filename/$rev"),
sprintf('%s/%s%s#rev%s',
uri_escape($file), uri_escape($filename),
$query, $rev)), '
';
if ($log) {
print htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra);
print '...' if (length($log) > 80);
}
} else {
my $dwhere = ($where ne '/' ? $where : '') . $file;
if ($use_descriptions && defined $descriptions{$dwhere}) {
print '';
print $descriptions{$dwhere};
} elsif ($infocols > 1) {
# close the row with the appropriate number of
# columns, so that the vertical seperators are visible
my ($cols) = $infocols;
while ($cols > 1) {
print " \n ";
$cols--;
}
}
}
print " \n\n", ($dirrow % 2) ? 'even' : 'odd';
printf ' ";
$dirrow++;
}
print "\n";
}
print "\n";
if ((my $num = scalar(@unreadable)) && ! $input{hidenonreadable}) {
printf(<';
my $icon = $isbinary ? $binfileicon : $fileicon;
print $nofilelinks ? $icon : &link($icon, $url);
print ' ', &link(htmlquote($file), $url), $attic;
print " \n", display_link($fileurl, $rev);
my $ageclass = 'age';
my $age = '';
if ($date) {
$age = readableTime(time() - $date, 0);
$ageclass .= " $1" if ($age =~ /^\d+ ([a-z]+)/);
}
print " \n$age";
print " \n", htmlquote($author) if $show_author;
print " \n";
if ($log) {
print htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra);
print '...' if (length $log > 80);
}
print " \n
%s
This document has moved ", &link('here', $url), ".
\n"; html_footer(); exit(1); } sub safeglob($) { my ($filename) = @_; (my $dirname = $filename) =~ s|/[^/]+$||; $filename =~ s|.*/||; my @results; my $dh = do { local (*DH); }; if (opendir($dh, $dirname)) { my $glob = $filename; my $t; # 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$/; foreach (readdir($dh)) { if ($_ =~ $glob && $_ =~ VALID_PATH) { push(@results, catfile($dirname, $1)); # untaint } } closedir($dh); } return @results; } # # Gets the MIME type for the given file name. # sub getMimeType($;$) { my ($fullname, $binary) = @_; $binary = ($keywordsubstitution && $keywordsubstitution =~ /b/) unless defined($binary); (my $suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/; my $mimetype = $MTYPES{$suffix}; $mimetype ||= $MimeTypes->mimeTypeOf($fullname) if defined($MimeTypes); 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, $linecount) = @_; $linecount ||= 10; 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; for (@_) { $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/; } ('tabstop' => $ts); } sub openOutputFilter() { return unless $output_filter; open(STDOUT, "|-") and return; # child of child open(STDERR, '>', devnull()) unless $DEBUG; exec($output_filter) or exit -1; } ############################### # show Annotation ############################### sub doAnnotate($$) { my ($rev, $tag) = @_; $rev = $tag || 'HEAD' if ($rev eq '.'); (my $pathname = $where) =~ s|((?<=/)Attic/)?[^/]*$||; (my $filename = $where) =~ s|^.*/||; # 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). local (*CVS_IN, *CVS_OUT); my $annotate_err; my ($h, $err) = startproc([ $CMD{cvs}, @annotate_options, 'server' ], '%s', $? >> 8 || -1, $err) unless $h; # 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. print CVS_IN "Root $cvsroot\n"; print CVS_IN "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n"; # 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"; # 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)) { if ($path eq "") { # In our example, $dir is "dir". $path = $dir; } else { print CVS_IN "Directory $path\n"; print CVS_IN "$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 .= "/$dir"; } } undef $path; # And the last "Directory" before "annotate" is the top level. print CVS_IN "Directory .\n"; print CVS_IN "$cvsroot\n"; print CVS_IN "annotate\n"; # 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); } navigateHeader($scriptwhere, $pathname, $filename, $rev, 'annotate'); my $revtype = ($rev =~ /\./) ? 'revision' : 'tag'; # TODO: tag -> branch/tag? print '
"; } # prefetch several lines my @buf = head(*CVS_OUT); my %d = scan_directives(@buf); while (@buf || !eof(*CVS_OUT)) { $_ = @buf ? shift @buf :"; } html_footer(); } ############################### # make Checkout ############################### sub doCheckout($$$) { my ($fullname, $rev, $tag) = @_; $rev = $tag || undef if (!$rev || $rev eq '.'); # Start resolving whether we will do a markup view or not. my $do_markup = undef; my $want_type = $input{'content-type'}; # No markup if markup disallowed. $do_markup = 0 unless $allow_markup; # No markup if checkout magic cookie in URL. $do_markup = 0 if (!defined($do_markup) && $doCheckout); # 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; } } # 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; 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}}; } } 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:; my @words = split; # 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); # 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 = ''; } $usrprint = ($lusr eq $oldLusr) ? '' : $lusr; $oldLrev = $lrev; $oldLusr = $lusr; print $is_textbased ? '' : '' if $isCurrentRev; $usrprint = sprintf('%-8s', $usrprint); printf '%s%s %s %4d:', $revprint, $isCurrentRev ? '!' : ' ', htmlquote($usrprint), $lineNr; print spacedHtmlText($line, $d{tabstop}); print $is_textbased ? '' : '' if $isCurrentRev; } 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. } elsif ($words[0] eq "error") { fatal("500 Internal Error", 'Error occured during annotate: %s', $_); } } $h->finish(); if ($annTable) { print ""; } else { 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);
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 (eof(CVS_ERR)) { $h->finish(); fatal("404 Not Found", '%s is not (any longer) pertinent', $where); } #=================================================================== #Checking out squid/src/ftp.c #RCS: /usr/src/CVS/squid/src/ftp.c,v #VERS: 1.1.1.28.6.2 #*************** # Parse CVS header my ($revision, $filename, $cvsheader); $filename = ""; while (
%s' . '(expected "
%s
" but got "%s
")',
$cvsheader, $where, $filename);
}
# Last checks whether we'll do markup or not.
my $isbin = $keywordsubstitution && $keywordsubstitution =~ /b/;
my $mimetype = getMimeType($fullname, $isbin);
# 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 ($do_markup) {
# 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();
}
# 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 \n"; my $linenumbers = $input{ln} || 0; my $ln = 0; my @buf = (); my $ts = undef; if ($preformat_in_markup) { # prefetch several lines @buf = head($filehandle); my %d = scan_directives(@buf); $ts = $d{tabstop}; } while (@buf || !eof($filehandle)) { $_ = @buf ? shift @buf : <$filehandle>; if ($linenumbers) { $ln++; printf '%5d: ', ($ln) x 2; } print $preformat_in_markup ? spacedHtmlText($_, $ts) : htmlquote($_); } print "\n"; } html_footer(); } sub viewable($) { return shift =~ m{^((text|image)/|application/pdf)}i; } ############################### # Show Colored Diff ############################### sub doDiff($$$$$$) { my ($fullname, $r1, $tr1, $r2, $tr2, $f) = @_; if (forbidden($fullname)) { fatal('403 Forbidden', 'Access to %s forbidden.', $where); } my ($rev1, $sym1); if ($r1 =~ /([^:]+)(:(.+))?/) { $rev1 = $1; $sym1 = $3; } if ($r1 eq 'text') { $rev1 = $tr1; $sym1 = ""; } my ($rev2, $sym2); if ($r2 =~ /([^:]+)(:(.+))?/) { $rev2 = $1; $sym2 = $3; } if ($r2 eq 'text') { $rev2 = $tr2; $sym2 = ""; } # # rev1 and rev2 are now both numeric revisions. # Thus we do a DWIM here and swap them if rev1 is after rev2. # XXX should we warn about the fact that we do this? if (&revcmp($rev1, $rev2) > 0) { my ($tmp1, $tmp2) = ($rev1, $sym1); ($rev1, $sym1) = ($rev2, $sym2); ($rev2, $sym2) = ($tmp1, $tmp2); } my $mimetype = getMimeType($fullname); # # Check for per-MIME type diff commands. # my $diffcmd = undef; if (my $diffcmds = $DIFF_COMMANDS{lc($mimetype)}) { if ($f =~ /^ext(\d*)$/) { my $n = $1 || 0; $diffcmd = $diffcmds->[$n]; } } if ($diffcmd && $diffcmd->{cmd} && $diffcmd->{name}) { if ($diffcmd->{args} && ref($diffcmd->{args}) ne 'ARRAY') { fatal('500 Internal Error', 'Configuration error: arguments to external diff tools must ' . 'be given as array refs. See "
%s
" in ' .
'%%DIFF_COMMANDS
.',
$diffcmd->{name});
}
(my $cvsname = $where) =~ s/\.diff$//;
# Create two temporary files with the two revisions
my $temp_fn1 = checkout_to_temp($cvsroot, $cvsname, $rev1);
my $temp_fn2 = checkout_to_temp($cvsroot, $cvsname, $rev2);
# Execute chosen diff binary.
local (*DIFF_OUT);
my @cmd = ($diffcmd->{cmd});
push(@cmd, @{$diffcmd->{args}}) if $diffcmd->{args};
push(@cmd, $temp_fn1, $temp_fn2);
my ($h, $err) = startproc(\@cmd, \"", '>pipe', \*DIFF_OUT);
if (!$h) {
unlink($temp_fn1);
unlink($temp_fn2);
fatal('500 Internal Error',
'Diff failure (exit status %s), output: %s', $? >> 8 || -1, $err); } http_header($diffcmd->{type} || 'text/plain'); local $/ = undef; print
%s
" is not defined.',
$input{only_with_tag});
}
}
undef @revisions;
foreach (@allrevisions) {
($br = $_) =~ s/\.\d+$//;
($brp = $br) =~ s/\.\d+$//;
next if ($onlyonbranch
&& $br ne $onlyonbranch
&& $_ ne $onlybranchpoint);
unshift(@revisions, $_);
}
if ($logsort eq "date") {
# Sort the revisions in commit order an secondary sort on revision
# (secondary sort needed for imported sources, or the first main
# revision gets before the same revision on the 1.1.1 branch)
@revdisplayorder =
sort { $date{$b} <=> $date{$a} || -revcmp($a, $b) } @revisions;
} elsif ($logsort eq "rev") {
# Sort the revisions in revision order, highest first
@revdisplayorder = reverse sort { revcmp($a, $b) } @revisions;
} else {
# No sorting. Present in the same order as rlog / cvs log
@revdisplayorder = @revisions;
}
return $curbranch;
}
sub getDiffLinks($$$)
{
my ($url, $mimetype, $isbin) = @_;
my @links = ();
if (!$isbin) { # Offer ordinary diff only for non-binary files.
push(@links, &link('preferred', $url));
for my $difftype ($DIFFTYPES{$defaultDiffType}{colored} ? qw(u) : qw(h)) {
my $f = $difftype eq $defaultDiffType ? '' : $difftype;
push(@links,
&link(htmlquote(lc($DIFFTYPES{$difftype}{descr})), "$url;f=$f"));
}
}
if (my $extdiffs = $DIFF_COMMANDS{lc($mimetype)}) {
for my $i (0 .. scalar(@$extdiffs)-1) {
my $extdiff = $extdiffs->[$i];
push(@links, &link(htmlquote($extdiff->{name}), "$url;f=ext$i"))
if ($extdiff->{cmd} && $extdiff->{name});
}
}
return @links;
}
sub printLog($$$;$$)
{
# inlogview: 1 if in log view, otherwise in markup view.
($_, my $mimetype, my $isbin, my $inlogview, my $isSelected) = @_;
(my $br = $_) =~ s/\.\d+$//;
(my $brp = $br) =~ s/\.?\d+$//;
print "";
if (defined($revsym{$_})) {
foreach my $sym (split(", ", $revsym{$_})) {
print '';
}
}
if ($revsym{$br} && !defined($nameprinted{$br})) {
foreach my $sym (split(", ", $revsym{$br})) {
print '';
}
$nameprinted{$br} = 1;
}
print "\n Revision $_";
if (/^1\.1\.1\.\d+$/) {
print " (vendor branch)";
}
(my $filename = $where) =~ s|^.*/||;
my $fileurl = uri_escape($filename);
undef $filename;
my $isDead = ($state{$_} eq 'dead');
if (!$isDead) {
print ': ', download_link($fileurl, $_, 'download', $mimetype);
my @vlinks = ();
push(@vlinks, display_link($fileurl, $_, 'text', 'text/plain'))
unless $isbin;
push(@vlinks, display_link($fileurl, $_, 'markup', 'text/x-cvsweb-markup'))
if ($allow_markup && $inlogview && (!$isbin || viewable($mimetype)));
if (!$isbin && $allow_annotate) {
push(@vlinks,
&link('annotated',
sprintf('%s?annotate=%s%s', $fileurl, $_, $barequery)));
}
print ' - view: ', join(', ', @vlinks) if @vlinks;
undef @vlinks;
if (!$isbin && $allow_version_select) {
print ' - ';
if ($isSelected) {
print '[selected for diffs]';
} else {
print &link('select for diffs',
sprintf('%s?r1=%s%s#rev%s',
$fileurl, $_, $barequery, $_));
}
}
}
print "\n"; print &htmlify($log{$_}, $allow_log_extra); print "\n"; } sub doLog($) { my ($fullname) = @_; my $curbranch = readLog($fullname); html_header("CVS log for $where"); my $upwhere = $where; (my $filename = $where) =~ s|^.*/||; my $backurl = "./$query#" . uri_escape($filename); if ($where =~ m|^(.*?)((?<=/)Attic/)?[^/]+$|) { $upwhere = $1; $backurl = ".$backurl" if $2; # skip over Attic } my $isbin = $keywordsubstitution =~ /b/; my $mimetype = getMimeType($filename, $isbin); print "
\n "; print &link($backicon, $backurl), " Up to ", &clickablePath($upwhere, 1), "\n
\n"; print "\n "; print &link('Request diff between arbitrary revisions', '#diff'); print "\n
\n\n";
my $explain = $isbin ? ' (i.e.: CVS considers this a binary file)' : '';
print "Keyword substitution: $keywordsubstitution$explain
\n";
if ($curbranch) {
print "Default branch: ", ($revsym{$curbranch} || $curbranch);
} else {
print "No default branch";
}
print "
\n";
print 'Current tag: ', htmlquote($input{only_with_tag}), "
\n"
if $input{only_with_tag};
print "
version $rev1$date1 | version $rev2$date2 | Line $oldline$funname | Line $newline$funname | EOF $state = "dump"; $leftRow = 0; $rightRow = 0; } else { my ($diffcode, $rest) = $difftxt =~ /^([-+ ])(.*)/; $diffcode = '' unless defined($diffcode); $_ = $rest; ######### # little state machine to parse unified-diff output (Hen, zeller@think.de) # in order to get some nice 'ediff'-mode output # states: # "dump" - just dump the value # "PreChangeRemove" - we began with '-' .. so this could be the start of a 'change' area or just remove # "PreChange" - okey, we got several '-' lines and moved to '+' lines -> this is a change block ########## if ($diffcode eq '+') { if ($state eq "dump") { # 'change' never begins with '+': just dump out value $_ = spacedHtmlText($rest, $d{tabstop}); printf(<%s | EOF } else { # we got minus before $state = "PreChange"; $rightCol[$rightRow++] = $_; } } elsif ($diffcode eq '-') { $state = "PreChangeRemove"; $leftCol[$leftRow++] = $_; } else { # empty diffcode flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow; $_ = spacedHtmlText($rest, $d{tabstop}); printf(<%s | %s | EOF $state = "dump"; $leftRow = 0; $rightRow = 0; } } } close($fh); flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow; # state is empty if we didn't have any change if (!$state) { print <
---|---|
- No viewable change - |
EOF my $frag = ''; if ($rev) { $frag = '#'; $frag .= 'rev' if ($rev =~ /\./); # Normal revision: prefix with "rev". $frag .= $rev; # Append revision/branch/tag. } my $backurl = "$swhere$query$frag"; print &link($backicon, $backurl); printf 'Return to %s CVS log', &link($qfile, $backurl); print " $fileicon | "; printf(<
%s', $? >> 8 || -1, $err); } return $temp_fn; } # # Close the GZIP handle, and remove the tie. # sub gzipclose { if ($gzip_open) { select(STDOUT); close(GZIP); untie *GZIP; $gzip_open = 0; } } # implement a gzipped file handle via the Compress:Zlib compression # library. sub MAGIC1() { 0x1f } sub MAGIC2() { 0x8b } sub OSCODE() { 3 } sub TIEHANDLE { my ($class, $out) = @_; my ($d) = Compress::Zlib::deflateInit( -Level => Compress::Zlib::Z_BEST_COMPRESSION(), -WindowBits => -Compress::Zlib::MAX_WBITS() ) or return undef; my ($o) = { handle => $out, dh => $d, crc => 0, len => 0, }; my ($header) = pack("C10", MAGIC1, MAGIC2, Compress::Zlib::Z_DEFLATED(), 0, 0, 0, 0, 0, 0, OSCODE); print {$o->{handle}} $header; return bless($o, $class); } sub PRINT { my ($o) = shift; my ($buf) = join (defined($,) ? $, : "", @_); my ($len) = length($buf); my ($compressed, $status) = $o->{dh}->deflate($buf); print {$o->{handle}} $compressed if defined($compressed); $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc}); $o->{len} += $len; return $len; } sub PRINTF { my ($o) = shift; my ($fmt) = shift; my ($buf) = sprintf($fmt, @_); my ($len) = length($buf); my ($compressed, $status) = $o->{dh}->deflate($buf); print {$o->{handle}} $compressed if defined($compressed); $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc}); $o->{len} += $len; return $len; } sub WRITE { my ($o, $buf, $len, $off) = @_; my ($compressed, $status) = $o->{dh}->deflate(substr($buf, 0, $len)); print {$o->{handle}} $compressed if defined($compressed); $o->{crc} = Compress::Zlib::crc32(substr($buf, 0, $len), $o->{crc}); $o->{len} += $len; return $len; } sub CLOSE { my ($o) = @_; return if !defined($o->{dh}); my ($buf) = $o->{dh}->flush(); $buf .= pack("V V", $o->{crc}, $o->{len}); print {$o->{handle}} $buf; undef $o->{dh}; } sub DESTROY { my ($o) = @_; CLOSE($o); } # Local variables: # indent-tabs-mode: nil # cperl-indent-level: 2 # End: