#!/usr/bin/perl -wT
#
# cvsweb - a CGI interface to CVS trees.
#
# Written in their spare time by
# Bill Fenner (original work)
# extended by Henner Zeller ,
# Henrik Nordstrom
# Ken Coar
# Dick Balaska
# Akinori MUSHA
# Jens-Uwe Mager
# Ville Skyttä
# Vassilii Khachaturov
#
# Based on:
# * Bill Fenners cvsweb.cgi revision 1.28 available from:
# http://www.FreeBSD.org/cgi/cvsweb.cgi/www/en/cgi/cvsweb.cgi
#
# Copyright (c) 1996-1998 Bill Fenner
# (c) 1998-1999 Henner Zeller
# (c) 1999 Henrik Nordstrom
# (c) 2000-2002 Akinori MUSHA
# (c) 2002-2003 Ville Skyttä
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
# $FreeBSD$
# $Id: cvsweb.cgi,v 3.162 2003/08/01 17:49:04 scop Exp $
# $Idaemons: /home/cvs/cvsweb/cvsweb.cgi,v 3.84 2001/10/07 20:50:10 knu Exp $
#
###
require 5.005_03;
use strict;
use vars qw (
$VERSION
$config $allow_version_select
@CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr
%MIRRORS %DEFAULTVALUE %ICONS %MTYPES
@DIFFTYPES %DIFFTYPES @LOGSORTKEYS %LOGSORTKEYS
%alltags %fileinfo %tags @branchnames %nameprinted
%symrev %revsym @allrevisions %date %author @revdisplayorder
@revisions %state %difflines %log %branchpoint @revorder $keywordsubstitution
$prcgi @prcategories $re_prcategories $prkeyword $re_prkeyword $mancgi
$checkoutMagic $doCheckout $scriptname $scriptwhere
$where $pathinfo $Browser $nofilelinks $maycompress
@stickyvars @unsafevars %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
$charset $output_filter
$command_path %CMD $allow_compress $backicon $diricon $fileicon $graphicon
$fullname $newname $cvstreedefault $logo $defaulttitle $address $binfileicon
$long_intro $short_instruction $shortLogLen $show_author
$tablepadding $hr_breakable $showfunc $hr_ignwhite $hr_ignkeysubst
$inputTextSize $mime_types $allow_annotate $allow_markup
$allow_log_extra $allow_dir_extra $allow_source_extra
$allow_cvsgraph $cvsgraph_config $use_java_script $open_extern_window
$extern_window_width $extern_window_height $edit_option_form
$show_subdir_lastmod $show_log_in_markup $preformat_in_markup
$tabstop $state $annTable $sel $curbranch @HideModules @ForbiddenFiles
$module $use_descriptions %descriptions @mytz $dwhere $moddate
$use_moddate $has_zlib $gzip_open $file_list_len
$allow_tar @tar_options @gzip_options @zip_options @cvs_options
@annotate_options $LOG_FILESEPARATOR $LOG_REVSEPARATOR
$tmpdir $HTML_DOCTYPE $HTML_META $cssurl $TempTemplate $CSS
$CvsWebMarkupRE $allow_enscript @enscript_options %enscript_types
$MimeTypes
);
# TODO:
# Maybe "use filetest 'access'" on perl >= 5.6 for better -X checks.
#($] >= 5.006) and eval "use filetest 'access'";
use Cwd qw(abs_path);
use File::Basename qw();
use File::Temp qw(tempdir);
use IO::Pipe qw();
use IPC::Open2 qw(open2);
use Time::Local qw();
# -----------------------------------------------------------------------------
# All global initialization that can be done in compile time should go to
# the BEGIN block. Persistent environments, such as mod_perl, will benefit
# from this.
BEGIN
{
$VERSION = '3.0-dev';
$HTML_DOCTYPE =
'';
$HTML_META = <
EOM
# 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 = !$@;
# Use MIME::Types for MIME type lookups if it's available.
eval {
require MIME::Types;
$MimeTypes = MIME::Types->new();
};
$MimeTypes = undef if $@;
$is_mod_perl = defined($ENV{MOD_PERL});
$tmpdir = $ENV{TMPDIR} || '/var/tmp';
$TempTemplate = '.cvsweb.XXXXXXXX';
$LOG_FILESEPARATOR = qr/^={77}$/o;
$LOG_REVSEPARATOR = qr/^-{28}$/o;
$CvsWebMarkupRE = qr/^text\/(x-cvsweb|vnd\.viewcvs)-markup$/io;
}
# -----------------------------------------------------------------------------
sub printDiffSelect($);
sub printDiffLinks($$);
sub printLogSortSelect($);
sub findLastModifiedSubdirs(@);
sub htmlify_sub(&$);
sub htmlify($;$);
sub spacedHtmlText($;$);
sub link($$);
sub revcmp($$);
sub fatal($$@);
sub redirect($);
sub safeglob($);
sub search_path($);
sub getMimeType($;$);
sub head($;$);
sub scan_directives(@);
sub openOutputFilter();
sub doAnnotate($);
sub doCheckout($$);
sub doGraph($);
sub doGraphView($);
sub cvswebMarkup($$$);
sub viewable($);
sub doDiff($$$$$$);
sub getDirLogs($$@);
sub readLog($;$);
sub printLog($;$);
sub doLog($);
sub flush_diff_rows($$$$);
sub human_readable_diff($$);
sub navigateHeader($$$$$);
sub plural_write($$);
sub readableTime($$);
sub clickablePath($$);
sub chooseCVSRoot();
sub chooseMirror();
sub fileSortCmp();
sub download_url($$;$);
sub download_link($$$;$);
sub graph_link($$;$);
sub toggleQuery($;$);
sub urlencode($);
sub htmlquote($);
sub htmlunquote($);
sub hrefquote($);
sub http_header(;$);
sub html_header($);
sub html_footer();
sub link_tags($);
sub forbidden_file($);
sub forbidden_module($);
##### Start of Configuration Area ########
# Get rid of unsafe environment vars. Don't do this in BEGIN...
delete(@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)});
my ($mydir) = (File::Basename::dirname($0) =~ /(.*)/); # untaint
# == EDIT this ==
# Locations to search for user configuration, in order:
for ("$mydir/cvsweb.conf", '/usr/local/etc/cvsweb/cvsweb.conf') {
if (defined($_) && -r $_) {
$config = $_;
last;
}
}
undef $mydir;
# == Configuration defaults ==
# Defaults for configuration variables that shouldn't need
# to be configured..
$allow_version_select = 1;
$allow_log_extra = 1;
##### End of Configuration Area ########
######## Configuration variables #########
# These are defined to allow checking with perl -cw
@CVSrepositories = @CVSROOT = %CVSROOT = %MIRRORS = %DEFAULTVALUE = %ICONS =
%MTYPES = %tags = %alltags = %fileinfo = ();
$cvstreedefault = $logo = $defaulttitle =
$address = $long_intro = $short_instruction = $shortLogLen = $show_author =
$tablepadding = $hr_breakable = $showfunc = $hr_ignwhite =
$hr_ignkeysubst = $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 =
$tabstop = $use_moddate = $moddate =
$gzip_open = undef;
@DIFFTYPES = qw(h H u c s);
@DIFFTYPES{@DIFFTYPES} = (
{
'descr' => 'colored',
'opts' => ['-u'],
'colored' => 1,
},
{
'descr' => 'long colored',
'opts' => ['--unified=15'],
'colored' => 1,
},
{
'descr' => 'unified',
'opts' => ['-u'],
'colored' => 0,
},
{
'descr' => 'context',
'opts' => ['-c'],
'colored' => 0,
},
{
'descr' => 'side by side',
'opts' => ['--side-by-side', '--width=164'],
'colored' => 0,
},
);
@LOGSORTKEYS = qw(cvs date rev);
@LOGSORTKEYS{@LOGSORTKEYS} = (
{'descr' => 'Not sorted',},
{'descr' => 'Commit date',},
{'descr' => 'Revision',},
);
##### End of configuration variables #####
$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$//;
}
$scriptwhere = $scriptname;
$scriptwhere .= '/' . urlencode($where);
$where = '/' if ($where eq '');
# 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 `);
$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
&& !($is_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 ignorecase sortby logsort f only_with_tag
ln);
@unsafevars = qw(logsort only_with_tag r1 r2 rev sortby tr1 tr2);
if (-f $config) {
do "$config"
or fatal("500 Internal Error",
'Error in loading configuration file: %s
%s ',
$config, $@);
} else {
fatal("500 Internal Error",
'Configuration not found. Set the variable $config in cvsweb.cgi to your cvsweb.conf configuration file first.');
}
$CSS = $cssurl ?
sprintf("\n",
htmlquote($cssurl)) : '';
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{$_}++;
}
}
}
# 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}));
# Prevent cross-site scripting, untaint.
foreach (@unsafevars) {
if (defined($input{$_})) {
# Colons are needed in diffs between tags.
if ($input{$_} =~ /^([\w\-.:]*)$/) {
$input{$_} = $1;
} else {
fatal("500 Internal Error", 'Malformed query (%s=%s)', $_, $input{$_});
}
}
}
if (defined($input{"content-type"})) {
fatal('500 Internal Error', 'Unsupported content-type')
if ($input{"content-type"} !~ /^[-0-9A-Za-z]+\/[-0-9A-Za-z\.]+$/);
}
#
# CVS roots
#
my $rootfound = 0;
for (my $i = 0; $i < scalar(@CVSrepositories); $i += 2) {
my $key = $CVSrepositories[$i];
my ($descr, $cvsroot) = @{$CVSrepositories[$i+1]};
unless (-d $cvsroot) {
warn("Root '$cvsroot' defined in \@CVSrepositories is not a directory, " .
'entry ignored');
next;
}
$rootfound ||= 1;
$cvstreedefault = $key unless defined($cvstreedefault);
$CVSROOTdescr{$key} = $descr;
$CVSROOT{$key} = $cvsroot;
push(@CVSROOT, $key);
}
unless ($rootfound) {
fatal('500 Internal Error',
'No valid CVS roots found! See @CVSrepositories in ' .
'your configuration file (%s).',
$config);
}
undef $rootfound;
#
# 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;
while (my ($key, $defval) = each %DEFAULTVALUE) {
# Replace not given parameters with defaults.
next unless (defined($defval)
&& (!defined($input{$key}) || $input{$key} eq ''));
# 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'})) {
# 'copt' is defined -> 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 defined --> 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{$_}));
}
}
# 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 = $cvstreedefault;
}
$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('',
hrefquote($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;
$re_prcategories = '(?:' . join ('|', @prcategories) . ')' if @prcategories;
$re_prkeyword = quotemeta($prkeyword) if defined($prkeyword);
$prcgi .= '%s' if defined($prcgi) && $prcgi !~ /%s/;
$fullname = "$cvsroot/$where";
my $rewrite = 0;
if ($pathinfo =~ m|//|) {
$pathinfo =~ y|/|/|s;
$rewrite = 1;
}
if (-d $fullname) {
if ($pathinfo !~ m|/$|) {
$pathinfo .= '/';
$rewrite = 1;
}
} else {
if ($pathinfo =~ m|/$|) {
chop $pathinfo;
$rewrite = 1;
}
}
if ($rewrite) {
redirect($scriptname . urlencode($pathinfo) . $query);
}
undef $rewrite;
if (!-d $cvsroot) {
fatal("500 Internal Error",
'$CVSROOT not found!
The server on which the CVS tree lives is probably down. Please try again in a few minutes.');
}
#
# See if the module is in our forbidden list.
#
$where =~ m:([^/]*):;
$module = $1;
if ($module && &forbidden_module($module)) {
fatal("403 Forbidden", 'Access to %s forbidden.', $where);
}
#
# 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,([^/]+)$,);
if ($basedir eq '' || $module eq '') {
fatal('500 Internal Error',
'You cannot download the top level directory.');
}
my $tmpexportdir;
eval {
local $SIG{__DIE__};
$tmpexportdir = tempdir($TempTemplate, DIR => $tmpdir, CLEANUP => 1);
};
if ($@) {
fatal('500 Internal Error', 'Unable to make temporary directory: %s', $@);
}
my @fatal;
my $tag =
(exists $input{only_with_tag} && length $input{only_with_tag})
? $input{only_with_tag}
: 'HEAD';
$tag = 'HEAD' if $tag eq 'MAIN';
if (system($CMD{cvs},
@cvs_options, '-Qd', $cvsroot, 'export', '-r', $tag, '-d',
"$tmpexportdir/$basedir", $module))
{
@fatal = ('500 Internal Error', 'cvs export failure: %s: %s', $!, $module);
} else {
$| = 1; # Essential to get the buffering right.
if ($ext eq '.tar.gz') {
print "Content-Type: application/x-gzip\r\n\r\n";
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";
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');
}
}
# File::Temp's CLEANUP will handle cleanup of the temp dir for us.
&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 = 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);
print $short_instruction;
}
if ($use_descriptions && open(DESC, "<$cvsroot/CVSROOT/descriptions")) {
while () {
chomp;
my ($dir, $description) = /(\S+)\s+(.*)/;
$descriptions{$dir} = $description;
}
close(DESC);
}
print "
\n";
# give direct access to dirs
if ($where eq '/') {
chooseMirror();
chooseCVSRoot();
} else {
print "
Current directory: ", &clickablePath($where, 0), "
\n";
print "
Current tag: ", htmlquote($input{only_with_tag}), "
\n"
if $input{only_with_tag};
}
print "\n";
my $infocols = 0;
print "
\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 $attic;
my $url;
my $fileurl;
my $filesexists;
my $filesfound;
foreach my $file (sort { &fileSortCmp } @dir) {
next if ($file eq '.');
# 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'} && $file eq 'CVSROOT');
# Check whether the module is in the restricted list
next if ($file && &forbidden_module($file));
# Is it a directory?
my $isdir = -d "$fullname/$file";
# Ignore non-readable files and directories?
next if ($input{'hidenonreadable'} && (! -r _ || ($isdir && ! -x _)));
if ($file =~ s|^Attic/||) {
$attic = ' (in the Attic) ' . $hideAtticToggleLink;
} else {
$attic = '';
}
if ($file eq '..' || $isdir) {
next if ($file eq '..' && $where eq '/');
my ($rev, $date, $log, $author, $filename, $keywordsubst) =
@{$fileinfo{$file}} if (defined($fileinfo{$file}));
printf "
\n
",
($dirrow % 2) ? 'even' : 'odd';
if ($file eq '..') {
$url = "../$query";
if ($nofilelinks) {
print $backicon;
} else {
print &link($backicon, $url);
}
print ' ', &link("Parent Directory", $url);
} else {
$url = './' . urlencode($file) . "/$query";
print '';
if ($nofilelinks) {
print $diricon;
} else {
print &link($diricon, $url);
}
print ' ', &link(htmlquote("$file/"), $url), $attic;
if ($file eq "Attic") {
print " ";
print &link('[Don\'t hide]',
sprintf('./%s#dirlist', &toggleQuery('hideattic')));
}
}
# Show last change in dir
if ($filename) {
print "
\n
\n
";
if ($date) {
print " ", readableTime(time() - $date, 0), "";
}
if ($show_author) {
print "
\n
", htmlquote($author);
}
print "
\n
";
$filename =~ s%^[^/]+/%%;
print htmlquote($filename), '/', $rev, ' ';
if ($log) {
print ' ',
&htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra);
print '...' if (length($log) > 80);
print '';
}
} 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++;
} elsif ($file =~ s/,v$//) {
# Skip forbidden files now so we'll give no hint
# about their existence. This should probably have
# been done earlier, but it's straightforward here.
next if forbidden_file("$fullname/$file");
$fileurl = ($attic ? 'Attic/' : '') . urlencode($file);
$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 "
\n";
if ((my $num = scalar(@unreadable)) && ! $input{hidenonreadable}) {
printf(<NOTE: The following %d unreadable files were ignored: %s
EOF
}
if ($filesexists && !$filesfound) {
my $currtag = defined($input{only_with_tag}) ?
sprintf(' (%s)', htmlquote($input{only_with_tag})) : '';
printf(<NOTE: There are %d files, but none matches the current tag%s.
EOF
}
if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}})) {
%tags = %alltags;
}
if (scalar %tags
|| $input{only_with_tag}
|| $edit_option_form
|| defined($input{"options"}))
{
print "\n";
}
if (scalar %tags || $input{only_with_tag}) {
print "\n";
}
if ($allow_tar) {
my ($basefile) = ($where =~ m,(?:.*/)?([^/]+),);
if (defined($basefile) && $basefile ne '') {
print "\n",
"
Download this directory in ";
# 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 "
\n";
}
}
if ($edit_option_form || defined($input{"options"})) {
my $formwhere = $scriptwhere;
$formwhere =~ s|Attic/?$|| if ($input{'hideattic'});
print <
EOF
if ($cvstree ne $cvstreedefault) {
print "\n";
}
print <
Preferences
,\n";
print '\n";
print "
\n
\n";
print "
\n
';
print '
\n
\n";
print "
\n
\n
\n";
print <
EOF
}
html_footer();
}
###############################
# View Files
###############################
elsif (-f $fullname . ',v') {
if (forbidden_file($fullname)) {
fatal('403 Forbidden',
'Access forbidden. This file is mentioned in @ForbiddenFiles');
return;
}
if (defined($input{'rev'}) || $doCheckout) {
&doCheckout($fullname, $input{'rev'});
gzipclose();
exit;
}
if (defined($input{'annotate'}) && $allow_annotate) {
&doAnnotate($input{'annotate'});
gzipclose();
exit;
}
if (defined($input{'r1'}) && defined($input{'r2'})) {
&doDiff($fullname, $input{'r1'}, $input{'tr1'},
$input{'r2'}, $input{'tr2'}, $input{'f'});
gzipclose();
exit;
}
if (defined($input{'graph'}) && $allow_cvsgraph) {
if (defined($input{'makeimage'})) {
&doGraph($input{'graph'});
} else {
&doGraphView($input{'graph'});
}
gzipclose();
exit;
}
&doLog($fullname);
##############################
# View Diff
##############################
} elsif ($fullname =~ s/\.diff$//
&& -f $fullname . ",v"
&& $input{'r1'}
&& $input{'r2'})
{
# $where-diff-removal if 'cvs rdiff' is used
# .. but 'cvs rdiff'doesn't support some options
# rcsdiff does (-w and -p), so it is disabled
# $where =~ s/\.diff$//;
# Allow diffs using the ".diff" extension
# so that browsers that default to the URL
# for a save filename don't save diff's as
# e.g. foo.c
&doDiff($fullname, $input{'r1'}, $input{'tr1'},
$input{'r2'}, $input{'tr2'}, $input{'f'});
gzipclose();
exit;
} elsif (($newname = $fullname) =~ s|/([^/]+)$|/Attic/$1|
&& -f $newname . ",v")
{
# The file has been removed and is in the Attic.
# Send a redirect pointing to the file in the Attic.
(my $newplace = $scriptwhere) =~ s|/([^/]+)$|/Attic/$1|;
if ($ENV{QUERY_STRING} ne "") {
redirect("${newplace}?$ENV{QUERY_STRING}");
} else {
redirect($newplace);
}
exit;
} elsif (0 && (my @files = &safeglob($fullname . ",v"))) {
http_header("text/plain");
print "You matched the following files:\n";
print join ("\n", @files);
# Find the tags from each file
# Display a form offering diffs between said tags
} else {
my $fh = do { local (*FH); };
my ($xtra, $module);
# Assume it's a module name with a potential path following it.
$xtra = (($module = $where) =~ s|/.*||) ? $& : '';
# Is there an indexed version of modules?
if (open($fh, "< $cvsroot/CVSROOT/modules")) {
while (<$fh>) {
if (/^(\S+)\s+(\S+)/o
&& $module eq $1
&& -d "$cvsroot/$2"
&& $module ne $2)
{
redirect("$scriptname/$2$xtra$query");
}
}
}
fatal("404 Not Found", '%s: no such file or directory', $where);
}
gzipclose();
## End MAIN
sub printDiffSelect($)
{
my ($use_java_script) = @_;
my $f = $input{'f'};
print '";
}
sub printLogSortSelect($)
{
my ($use_java_script) = @_;
print '";
}
sub findLastModifiedSubdirs(@)
{
my (@dirs) = @_;
my ($dirname, @files);
foreach $dirname (@dirs) {
next if ($dirname eq ".");
next if ($dirname eq "..");
my ($dir) = "$fullname/$dirname";
next if (!-d $dir);
my ($lastmod) = undef;
my ($lastmodtime) = undef;
my $dh = do { local (*DH); };
opendir($dh, $dir) or next;
my (@filenames) = readdir($dh);
closedir($dh);
foreach my $filename (@filenames) {
$filename = "$dirname/$filename";
my ($file) = "$fullname/$filename";
next if ($filename !~ /,v$/ || !-f $file);
# Skip forbidden files.
(my $f = $file) =~ s/,v$//;
next if forbidden_file($f);
$filename =~ s/,v$//;
my $modtime = -M $file;
if (!defined($lastmod) || $modtime < $lastmodtime) {
$lastmod = $filename;
$lastmodtime = $modtime;
}
}
push (@files, $lastmod) if (defined($lastmod));
}
return @files;
}
sub htmlify_sub(&$)
{
(my $proc, local $_) = @_;
my @a = split (m`(]+>[^<]*)`i);
my $linked;
my $result = '';
while (($_, $linked) = splice(@a, 0, 2)) {
&$proc();
$result .= $_ if defined($_);
$result .= $linked if defined($linked);
}
$result;
}
sub htmlify($;$)
{
(local $_, my $extra) = @_;
$_ = htmlquote($_);
# get URL's as link
s{
((https?|ftp)://.+?)([\s\']|&(quot|[lg]t);)
}{
&link($1, htmlunquote($1)) . $3
}egx;
# get e-mails as link
$_ = htmlify_sub {
s<
[\w+=\-.!]+@[\w\-]+(\.[\w\-]+)+
><
&link($&, "mailto:$&")
>egix;
} $_;
if ($extra) {
# get PR #'s as link: "PR#nnnn" "PR: nnnn, ..." "PR nnnn, ..." "bin/nnnn"
if (defined($prcgi) && defined($re_prkeyword)) {
my $prev;
do {
$prev = $_;
$_ = htmlify_sub {
s{
(\b$re_prkeyword[:\#]?\s*
(?:
\#?
\d+[,\s]\s*
)*
\#?)
(\d+)\b
}{
$1 . &link($2, sprintf($prcgi, $2))
}egix;
} $_;
} while ($_ ne $prev);
if (defined($re_prcategories)) {
$_ = htmlify_sub {
s{
(\b$re_prcategories/(\d+)\b)
}{
&link($1, sprintf($prcgi, $2))
}egox;
} $_;
}
}
# get manpage specs as link: "foo.1" "foo(1)"
if (defined($mancgi)) {
$_ = htmlify_sub {
s{
(
\b ( \w[\w+\-.]* (?: ::\w[\w+\-.]*)* )
(?:
\( ([0-9n]) \) \B
|
\. ([0-9n]) \b
)
)
}{
my($text, $name, $section) = ($1, $2, defined($3) ? $3 : $4);
($name =~ /[A-Za-z]/ && $name !~ /\.(:|$)/)
? &link($text, sprintf($mancgi, $section, $name))
: $text;
}egx;
} $_;
}
}
$_;
}
sub spacedHtmlText($;$)
{
local $_ = $_[0];
my $ts = $_[1] || $tabstop;
# Cut trailing spaces and tabs
s/[ \t]+$//;
if (defined($ts)) {
# Expand tabs
1 while s/\t+/' ' x (length($&) * $ts - length($`) % $ts)/e;
}
# replace and (\001 is to protect us from htmlify)
# gzip can make excellent use of this repeating pattern :-)
if ($hr_breakable) {
# make every other space 'breakable'
s/ / \001nbsp;/g; # 2 *
# leave single space as it is
} else {
s/ /\001nbsp;/g;
}
$_ = htmlify($_, $allow_source_extra);
# unescape
y/\001/&/;
return $_;
}
# Note that this doesn't htmlquote the first argument...
sub link($$)
{
my ($name, $url) = @_;
$url =~ s/:/sprintf("%%%02x", ord($&))/eg
if $url =~ /^[^a-z]/; # relative
sprintf '%s', hrefquote($url), $name;
}
sub revcmp($$)
{
my ($rev1, $rev2) = @_;
# make no comparison for a tag or a branch
return 0 if $rev1 =~ /[^\d.]/ || $rev2 =~ /[^\d.]/;
my (@r1) = split (/\./, $rev1);
my (@r2) = split (/\./, $rev2);
my ($a, $b);
while (($a = shift (@r1)) && ($b = shift (@r2))) {
if ($a != $b) {
return $a <=> $b;
}
}
if (@r1) { return 1; }
if (@r2) { return -1; }
return 0;
}
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 "
This document is located ", &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|.*/||;
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;
foreach (readdir($dh)) {
if (/^${glob}$/) {
push (@results, "$dirname/" . $_);
}
}
closedir($dh);
}
@results;
}
sub search_path($)
{
my ($command) = @_;
for my $d (split (/:/, $command_path)) {
return "$d/$command" if -x "$d/$command";
}
return '';
}
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));
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;
my @buf;
if ($linecount > 0) {
my $i;
for ($i = 0; !eof($fh) && $i < $linecount; $i++) {
push @buf, scalar <$fh>;
}
} else {
@buf = <$fh>;
}
@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 if !defined($output_filter) || $output_filter eq '';
open(STDOUT, "|-") and return;
# child of child
open(STDERR, '>/dev/null');
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); };
# make sure the revisions are wellformed, for security
# reasons ..
if ($rev =~ /[^\w.]/) {
fatal("404 Not Found", 'Malformed query "%s"', $ENV{QUERY_STRING});
}
($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;
($filename = $where) =~ s/^.*\///;
# this seems to be necessary
$| = 1;
$| = 0; # Flush
# Work around a mod_perl bug (?) in order to make open2() work.
# Search for "untie STDIN" in mod_perl mailing list archives for more info.
my $old_stdin;
if ($is_mod_perl && ($old_stdin = tied *STDIN)) {
local $^W = undef;
untie *STDIN;
}
# 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');
# 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));
# 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 $writer "Root $cvsroot\n";
print $writer
"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 $writer "UseUnchanged\n";
print $writer "Argument -r\n";
print $writer "Argument $rev\n";
print $writer "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 $writer "Directory $path\n";
print $writer "$cvsroot/$path\n";
# In our example, $_ is "sdir" and $path becomes "dir/sdir"
# And the next time, "file" and "dir/sdir/file" (which then gets
# ignored, because we don't need to send Directory for the file).
$path .= "/$dir";
}
}
undef $path;
# And the last "Directory" before "annotate" is the top level.
print $writer "Directory .\n";
print $writer "$cvsroot\n";
print $writer "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 "cvs server"
# were nicer about buffering, then we could just leave it open, I think.
close($writer) or die "cannot close: $!";
navigateHeader($scriptwhere, $pathname, $filename, $rev, 'annotate');
print '
Annotation of ',
htmlquote("$pathname$filename"), ", revision $rev
\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);
if ($annTable) {
print
"
\n";
} else {
print "
";
}
# prefetch several lines
my @buf = head($reader);
my %d = scan_directives(@buf);
while (@buf || !eof($reader)) {
$_ = @buf ? shift @buf : <$reader>;
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);
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($&, "$scriptwhere$query#rev$&")`e; # `
$oldLusr = '';
}
if ($lusr eq $oldLusr) {
$usrprint = '';
} else {
$usrprint = $lusr;
}
$oldLrev = $lrev;
$oldLusr = $lusr;
# 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);
$usrprint = sprintf('%-8s', $usrprint);
printf '%s%s %s %4d:', $revprint, $isCurrentRev ? '!' : ' ',
htmlquote($usrprint), $lineNr;
print spacedHtmlText($line, $d{'tabstop'});
print "" if ($isCurrentRev && $is_textbased);
} 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', $_);
}
}
if ($annTable) {
print "
";
} else {
print "";
}
html_footer();
close($reader) or warn "cannot close: $!";
wait;
}
###############################
# make Checkout
###############################
sub doCheckout($$)
{
my ($fullname, $rev) = @_;
my ($revopt);
my $fh = do { local (*FH); };
if ($rev eq 'HEAD' || $rev eq '.') {
$rev = undef;
}
# make sure the revisions a wellformed, for security
# reasons ..
if (defined($rev) && $rev =~ /[^\w.]/) {
fatal("404 Not Found", 'Malformed query "%s"', $ENV{QUERY_STRING});
}
# get mimetype
my $mimetype;
if (defined($input{"content-type"})
&& ($input{"content-type"} =~ /\S\/\S/))
{
$mimetype = $input{"content-type"};
} else {
$mimetype = getMimeType($fullname);
}
if (defined($rev)) {
$revopt = "-r$rev";
if ($use_moddate) {
readLog($fullname, $rev);
$moddate = $date{$rev};
}
} else {
$revopt = "-rHEAD";
if ($use_moddate) {
readLog($fullname);
$moddate = $date{$symrev{HEAD}};
}
}
### 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
# work around a bug of cvs -p; expand symlinks
exec($CMD{cvs}, @cvs_options, '-d', abs_path($cvsroot), 'co', '-p',
$revopt, $where)
or exit -1;
}
if (eof($fh)) {
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 (<$fh>) {
last if (/^\*\*\*\*/);
$revision = $1 if (/^VERS: (.*)$/);
if (/^Checking out (.*)$/) {
$filename = $1;
$filename =~ s/^\.\/*//;
}
$cvsheader .= $_;
}
if ($filename ne $where) {
fatal("500 Internal Error",
'Unexpected output from cvs co: %s', $cvsheader);
}
$| = 1;
if ($mimetype =~ $CvsWebMarkupRE) {
&cvswebMarkup($fh, $fullname, $revision);
} else {
http_header($mimetype);
print <$fh>;
}
close($fh);
}
sub cvswebMarkup($$$)
{
my ($filehandle, $fullname, $revision) = @_;
my ($pathname, $filename);
($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;
($filename = $where) =~ s/^.*\///;
my $fileurl = urlencode($filename);
my $mimetype = getMimeType($filename);
navigateHeader($scriptwhere, $pathname, $filename, $revision, 'view');
print <