=================================================================== RCS file: /cvs/cvsweb/cvsweb.cgi,v retrieving revision 1.10 retrieving revision 4.16 diff -u -p -r1.10 -r4.16 --- cvsweb/cvsweb.cgi 1997/11/14 17:36:47 1.10 +++ cvsweb/cvsweb.cgi 2019/11/11 13:15:09 4.16 @@ -1,739 +1,4277 @@ -#!/usr/bin/perl -s +#!/usr/bin/perl +# $Id: cvsweb.cgi,v 4.16 2019/11/11 13:15:09 schwarze Exp $ +# $knu: cvsweb.cgi,v 1.299 2010/11/13 16:37:18 simon # -# cvsweb - a CGI interface to the CVS tree. +# cvsweb - a CGI interface to CVS trees. # -# Written by Bill Fenner on his own time. -# Insert BSD copyright here. +# 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 # -#HTTP_USER_AGENT: Mozilla/1.1N (X11; I; SunOS 4.1.3_U1 sun4m) via proxy gateway CERN-HTTPD/3.0 libwww/2.17 -#SERVER_NAME: www.freebsd.org -#QUERY_STRING: baz -#SCRIPT_FILENAME: /usr/local/www/cgi-bin/env.pl -#SERVER_PORT: 80 -#HTTP_ACCEPT: */*, image/gif, image/x-xbitmap, image/jpeg -#SERVER_PROTOCOL: HTTP/1.0 -#HTTP_COOKIE: s=beta26429821397802167 -#PATH_INFO: /foo/bar -#REMOTE_ADDR: 13.1.64.94 -#DOCUMENT_ROOT: /usr/local/www/data/ -#PATH: /sbin:/bin:/usr/sbin:/usr/bin -#PATH_TRANSLATED: /usr/local/www/data//foo/bar -#GATEWAY_INTERFACE: CGI/1.1 -#REQUEST_METHOD: GET -#SCRIPT_NAME: /cgi-bin/env.pl -#SERVER_SOFTWARE: Apache/1.0.0 -#REMOTE_HOST: beta.xerox.com -#SERVER_ADMIN: webmaster@freebsd.org +# Based on: +# * Bill Fenners cvsweb.cgi revision 1.28 available from: +# http://www.FreeBSD.org/cgi/cvsweb.cgi/www/en/cgi/cvsweb.cgi # -require 'timelocal.pl'; -require 'ctime.pl'; +# Copyright (c) 1996-1998 Bill Fenner +# (c) 1998-1999 Henner Zeller +# (c) 1999 Henrik Nordstrom +# (c) 2000-2002 Akinori MUSHA +# (c) 2002-2005 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. -$hsty_base = ""; -require 'cgi-style.pl'; +require 5.006; -%CVSROOT = ( - 'freebsd', '/home/ncvs', - 'openbsd', '/home/OpenBSD/cvs', - 'learn', '/c/learncvs', - ); +use strict; +use warnings; +use filetest qw(access); -$cvstreedefault = 'freebsd'; -$cvstree = $cvstreedefault; -$cvsroot = $CVSROOT{"$cvstree"} || "/home/ncvs"; +use vars qw ( + $VERSION $CheckoutMagic $MimeTypes $DEBUG + $config $allow_version_select + @CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr + %MIRRORS %DEFAULTVALUE %ICONS %MTYPES + %DIFF_COMMANDS @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 + $doCheckout $scriptname $scriptwhere + $where $Browser $nofilelinks $maycompress @stickyvars + $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 $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_mailtos + $allow_log_extra $allow_dir_extra $allow_source_extra + $allow_cvsgraph $cvsgraph_config $use_java_script $edit_option_form + $show_subdir_lastmod $show_log_in_markup $preformat_in_markup + $tabstop $state $annTable $sel @ForbiddenFiles + $use_descriptions %descriptions @mytz $dwhere + $use_moddate $gzip_open $file_list_len + $allow_tar @tar_options @gzip_options @zip_options @cvs_options + @annotate_options @rcsdiff_options + $HTML_DOCTYPE $HTML_META $cssurl $CSS $cvshistory_url + $allow_enscript @enscript_options %enscript_types +); +require Compress::Zlib; +use Cwd qw(abs_path); +use File::Path qw(rmtree); +use File::Spec::Functions qw(canonpath catdir catfile curdir devnull rootdir + tmpdir updir); +use File::Temp qw(tempdir tempfile); +use IPC::Run qw(); +use Time::Local qw(timegm); +use URI::Escape qw(uri_escape uri_unescape); -$intro = " -This is a WWW interface to the FreeBSD CVS tree. -You can browse the file hierarchy by picking directories -(which have slashes after them, e.g. src/). -If you pick a file, you will see the revision history -for that file. -Selecting a revision number will download that revision of -the file. There is a link at each revision to display -diffs between that revision and the previous one, and -a form at the bottom of the page that allows you to -display diffs between arbitrary revisions. +use constant VALID_PATH => qr/^([[:^cntrl:]]+)$/o; +use constant VALID_TAG1 => qr/^([a-zA-Z][[:graph:]]*)$/o; +use constant VALID_TAG2 => qr/^([^\$,.:;@]+)$/o; +use constant CVSWEBMARKUP => qr{^text/(x-cvsweb|vnd\.viewcvs)-markup$}io; +use constant LOG_FILESEPR => qr/^={77}$/o; +use constant LOG_REVSEPR => qr/^-{28}$/o; + +# ----------------------------------------------------------------------------- + +# 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.1'; + + $HTML_DOCTYPE = + ''; + + $HTML_META = < + + + +EOM + + # Use MIME::Types for MIME type lookups if it's available. + eval { + require MIME::Types; + $MimeTypes = MIME::Types->new(only_complete => 1); + }; + $MimeTypes = undef if $@; + + $CheckoutMagic = '~checkout~'; +} + +# ----------------------------------------------------------------------------- + +sub printDiffSelect($); +sub printDiffSelectStickyVars(); +sub getDiffLinks($$$); +sub printLogSortSelect($); +sub findLastModifiedSubdirs(@); +sub htmlify_sub(&$); +sub htmlify($;$); +sub spacedHtmlText($;$); +sub link($$); +sub revcmp($$); +sub fatal($$@); +sub config_error($$); +sub redirect($;$); +sub safeglob($); +sub search_path($); +sub getEnscriptHL($); +sub getMimeType($;$); +sub head($;$); +sub scan_directives(@); +sub openOutputFilter(); +sub doAnnotate($$); +sub doCheckout($$$); +sub doEnscript($$$;$); +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 display_url($$;$); +sub display_link($$;$$); +sub graph_link($;$); +sub history_link($$;$); +sub toggleQuery($;$); +sub htmlquote($); +sub htmlunquote($); +sub uri_escape_path($); +sub http_header(;$$); +sub html_header($;$); +sub html_footer(); +sub link_tags($); +sub forbidden($); +sub startproc(@); +sub runproc(@); +sub checkout_to_temp($$$); + +# Get rid of unsafe environment vars. Don't do this in the BEGIN block +# (think mod_perl)... +delete(@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}); + +# Location of the configuration file inside the web server chroot: +$config = '/conf/cvsweb/cvsweb.conf'; + +######## Configuration parameters ######### + +@CVSrepositories = @CVSROOT = %CVSROOT = %MIRRORS = %DEFAULTVALUE = %ICONS = + %MTYPES = %tags = %alltags = %fileinfo = %DIFF_COMMANDS = (); + +$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 = $allow_compress = $use_java_script = $edit_option_form = + $show_subdir_lastmod = $show_log_in_markup = $preformat_in_markup = + $tabstop = $use_moddate = $gzip_open = $DEBUG = $allow_cvsgraph = + $cvsgraph_config = $cvshistory_url = $allow_tar = undef; + +$allow_version_select = $allow_mailtos = $allow_log_extra = 1; + +@DIFFTYPES = qw(h H u c); +@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, + }, +); + +@LOGSORTKEYS = qw(cvs date rev); +@LOGSORTKEYS{@LOGSORTKEYS} = ( + { descr => 'Not sorted', }, + { descr => 'Commit date', }, + { descr => 'Revision', }, +); + +##### End of configuration parameters ##### + +my $pathinfo = ''; +if (defined($ENV{PATH_INFO}) && $ENV{PATH_INFO} ne '') { + ($pathinfo) = ($ENV{PATH_INFO} =~ VALID_PATH) + or fatal('500 Internal Error', + 'Illegal PATH_INFO in environment: %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 : 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. +# +if (-f $config) { + do "$config" or config_error($config, $@); +} else { + 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); + $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(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); + +# --- 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; + $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; + +# +# 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) && $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{$_}))); + } +} + +if ($allow_enscript) { + push(@DIFFTYPES, qw(uc cc)); + @DIFFTYPES{qw(uc cc)} = ( + { + 'descr' => 'unified, colored', + 'opts' => ['-u'], + 'colored' => 0, + }, + { + 'descr' => 'context, colored', + 'opts' => ['-c'], + '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"; +} 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('%s', + 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; + +$re_prcategories = '(?:' . join ('|', @prcategories) . ')' if @prcategories; +$re_prkeyword = quotemeta($prkeyword) if defined($prkeyword); +$prcgi .= '%s' if defined($prcgi) && $prcgi !~ /%s/; + +$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!

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|\.zip)$/); + my ($basedir) = ($module =~ m,([^/]+)$,); + + if ($basedir eq '' || $module eq '') { + fatal('500 Internal Error', + 'You cannot download the top level directory.'); + } + + 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 $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: 

%s
', + $errcode, $err || $export_err); + + } else { + + $| = 1; # Essential to get the buffering right. + local (*TAR_OUT); + + 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); + + my ($h, $err) = startproc(@cmd); + if ($h) { + print "Content-Type: $ctype\r\n\r\n"; + local $/ = undef; + print ; + $h->finish(); + } else { + @fatal = ('500 Internal Error', + '%s failure (exit status %s), output: 
%s
', + $istar ? 'Tar' : 'Zip', $? >> 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 ; + } else { + print "

\n"; + while () { + chomp; + print htmlquote($_), '
'; + } + print "

"; + } + $h->finish(); + } + print $short_instruction; + } + + if ($use_descriptions && + open(DESC, catfile($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), ''; + 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"; + + my $infocols = 1; + + printf(< + +EOF + 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"; + + 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 "\n", + ($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++; + + } 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 "\n", ($dirrow % 2) ? 'even' : 'odd'; + printf '', $allow_cvsgraph ? '' : ' colspan="2"'; + + my $icon = $isbinary ? $binfileicon : $fileicon; + print $nofilelinks ? $icon : &link($icon, $url); + print ' ', &link(htmlquote($file), $url), $attic; + print '', graph_link($fileurl) if $allow_cvsgraph; + 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"; + $dirrow++; + } + print "\n"; + } + + print "\n"; + + if ((my $num = scalar(@unreadable)) && ! $input{hidenonreadable}) { + printf(< -If you would like to use this CGI script on your own web server and -CVS tree, see -the CVSWeb distribution site. + 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(< -Please send any suggestions, comments, etc. to -Bill Fenner <fenner\@freebsd.org> -"; -$shortinstr = " -Click on a directory to enter that directory. Click on a file to display -its revision history and to get a -chance to display diffs between revisions. -"; + NOTE: There are %d files, but none matches the current tag%s. +

+EOF + } -$verbose = $v; -($where = $ENV{'PATH_INFO'}) =~ s|^/||; -$where =~ s|/$||; -($scriptname = $ENV{'SCRIPT_NAME'}) =~ s|^/?|/|; -$scriptname =~ s|/$||; -$scriptwhere = $scriptname . '/' . $where; -$scriptwhere =~ s|/$||; + 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 ($query = $ENV{'QUERY_STRING'}) { - foreach (split(/&/, $query)) { - s/%(..)/sprintf("%c", hex($1))/ge; # unquote %-quoted - if (/(\S+)=(.*)/) { - $input{$1} = $2; - } else { - $input{$_}++; - } + if (scalar %tags || $input{only_with_tag}) { + print "
\n

\n"; + foreach my $var (@stickyvars) { + printf("\n", + $var, htmlquote($input{$var})) + if (defined($input{$var}) + && (!defined($DEFAULTVALUE{$var}) + || $input{$var} ne $DEFAULTVALUE{$var}) + && $var ne 'only_with_tag'); } - $query = "?" . $query; + printf(< + + + +

+
+EOF + } + + 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", + '
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"; + } + } + + if ($edit_option_form || defined($input{options})) { + + print < +
+General options + +EOF + for my $v (qw(hidecvsroot hidenonreadable)) { + printf(qq{\n}, + $v, $input{$v} || 0); + } + if ($cvstree ne $cvstreedefault) { + print "\n"; + } + print < + + + + + +\n"; + print < + + + + +EOF + print ''; + print < + + + + + + +EOF + printLogSortSelect(0); + print < + + + + +EOF + print '\n"; + print < + + + + + + +EOF + printDiffSelect(0); + print < + + + + + +
+ +EOF + } + html_footer(); } +############################### +# View Files +############################### +elsif (-f $fullname . ',v') { + if (defined($input{rev}) || $doCheckout) { + &doCheckout($fullname, $input{rev}, $input{only_with_tag}); + gzipclose(); + exit; + } -if ($input{'cvsroot'}) { - if ($CVSROOT{$input{'cvsroot'}}) { - $cvstree = $input{'cvsroot'}; - $cvsroot = $CVSROOT{"$cvstree"}; + if (defined($input{annotate}) && $allow_annotate) { + &doAnnotate($input{annotate}, $input{only_with_tag}); + gzipclose(); + exit; + } + + if (defined($input{r1}) && defined($input{r2})) { + &doDiff($fullname, $input{r1}, $input{tr1}, + $input{r2}, $input{tr2}, $input{f}); + gzipclose(); + exit; + } + + if ($allow_cvsgraph && $input{graph}) { + if ($input{makeimage}) { + doGraph(); + } else { + doGraphView(); } + gzipclose(); + exit; + } + + &doLog($fullname); } -$fullname = $cvsroot . '/' . $where; -if (!-d $cvsroot) { - &fatal("500 Internal Error",'$CVSROOT not found!'); +############################## +# 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 filename in the URL when saving don't save diffs as eg. foo.c. + &doDiff($fullname, $input{r1}, $input{tr1}, + $input{r2}, $input{tr2}, $input{f}); + gzipclose(); + exit; + } +elsif (do { (my $tmp = $fullname) =~ s|/([^/]+)$|/Attic/$1|; -f "$tmp,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; -if (-d $fullname) { - opendir(DIR, $fullname) || &fatal("404 Not Found","$where: $!"); - @dir = readdir(DIR); - closedir(DIR); - if ($where eq '') { - print &html_header("FreeBSD CVS Repository"); - print $intro; - } else { - print &html_header("/$where"); - print $shortinstr; - } - print "

Current directory: /$where\n"; - print "

\n"; - # Using in this manner violates the HTML2.0 spec but - # provides the results that I want in most browsers. Another - # case of layout spooging up HTML. - print "\n"; - lookingforattic: - for ($i = 0; $i <= $#dir; $i++) { - if ($dir[$i] eq "Attic") { - last lookingforattic; - } - } - if (!$input{"showattic"} && ($i <= $#dir) && - opendir(DIR, $fullname . "/Attic")) { - splice(@dir, $i, 1, - grep((s|^|Attic/|,!m|/\.|), readdir(DIR))); - closedir(DIR); - } - # Sort without the Attic/ pathname. - foreach (sort {($c=$a)=~s|.*/||;($d=$b)=~s|.*/||;($c cmp $d)} @dir) { - if ($_ eq '.') { - next; - } - if (s|^Attic/||) { - $attic = " (in the Attic)"; - } else { - $attic = ""; - } - if ($_ eq '..') { - next if ($where eq ''); - ($updir = $scriptwhere) =~ s|[^/]+$||; - print " ", - &link("Previous Directory",$updir . $query), "
"; -# print " ", -# &link("Directory-wide diffs", $scriptwhere . '/*'), "
"; - } elsif (-d $fullname . "/" . $_) { - print " ", - &link($_ . "/", $scriptwhere . '/' . $_ . '/' . $query), $attic, "
"; - } elsif (s/,v$//) { -# TODO: add date/time? How about sorting? - print " ", - &link($_, $scriptwhere . '/' . - ($attic ? "Attic/" : "") . $_ . $query), - $attic, "
"; - } - } - print "\n"; - if ($input{"only_on_branch"}) { - print "
\n"; - print "Currently showing only branch $input{'only_on_branch'}.\n"; - $input{"only_on_branch"}=""; - foreach $k (keys %input) { - print "\n" if $input{$k}; - } - print "\n"; - print "
\n"; - } - $formwhere = $scriptwhere; - $formwhere =~ s|Attic/?$|| if ($input{"showattic"}); - print "
\n"; - $input{"showattic"}=!$input{"showattic"}; - foreach $k (keys %input) { - print "\n" if $input{$k}; - } - print "\n"; - print "
\n"; - print &html_footer; - print "\n"; -} elsif (-f $fullname . ',v') { - if ($input{'rev'} =~ /^[\d\.]+$/) { - &checkout($fullname, $input{'rev'}); - exit; - } - if ($input{'r1'} && $input{'r2'}) { - &dodiff($fullname, $input{'r1'}, $input{'tr1'}, - $input{'r2'}, $input{'tr2'}, $input{'f'}); - exit; - } - open(RCS, "rlog '$fullname'|") || &fatal("500 Internal Error", - "Failed to spawn rlog"); - while () { - print if ($verbose); - if (/^branch:\s+([\d\.]+)/) { - $curbranch = $1; - } - if ($symnames) { - if (/^\s+([^:]+):\s+([\d\.]+)/) { - $symrev{$1} = $2; - if ($revsym{$2}) { - $revsym{$2} .= ", "; - } - $revsym{$2} .= $1; - } else { - $symnames = 0; - } - } elsif (/^symbolic names/) { - $symnames = 1; - } elsif (/^-----/) { - last; - } - } +} - if ($onlyonbranch = $input{'only_on_branch'}) { - ($onlyonbranch = $symrev{$onlyonbranch}) =~ s/\.0\././; - ($onlybranchpoint = $onlyonbranch) =~ s/\.\d+$//; - } +elsif (0 && (my @files = &safeglob($fullname . ",v"))) { + http_header("text/plain"); + print "You matched the following files:\n"; + print join ("\n", @files); -# each log entry is of the form: -# ---------------------------- -# revision 3.7.1.1 -# date: 1995/11/29 22:15:52; author: fenner; state: Exp; lines: +5 -3 -# log info -# ---------------------------- - logentry: - while (!/^=========/) { - $_ = ; - print "R:", $_ if ($verbose); - if (/^revision ([\d\.]+)/) { - $rev = $1; - } elsif (/^========/ || /^----------------------------$/) { - next logentry; - } else { - &fatal("500 Internal Error","Error parsing RCS output: $_"); - } - $_ = ; - print "D:", $_ if ($verbose); - if (m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);\s+author:\s+(\S+);\s+state:\s+(\S+);|) { - $yr = $1; - # damn 2-digit year routines - if ($yr > 100) { - $yr -= 1900; - } - $date{$rev} = &timelocal($6,$5,$4,$3,$2 - 1,$yr); - $author{$rev} = $7; - $state{$rev} = $8; - } else { - &fatal("500 Internal Error", "Error parsing RCS output: $_"); - } - line: - while () { - print "L:", $_ if ($verbose); - next line if (/^branches:\s/); - last line if (/^----------------------------$/ || /^=========/); - $log{$rev} .= $_; - } - print "E:", $_ if ($verbose); - } - close(RCS); - print "Done reading RCS file\n" if ($verbose); + # TODO: + # Find the tags from each file + # Display a form offering diffs between said tags +} + +else { + # Assume it's a module name with a potential path following it. + my $module; + my $xtra = (($module = $where) =~ s|(/.*)||) ? $1 : ''; + + # Is there an indexed version of modules? + my $fh = do { local (*FH); }; + if (open($fh, catfile($cvsroot, 'CVSROOT', 'modules'))) { + while (<$fh>) { + if (/^(\S+)\s+(\S+)/o + && $module eq $1 + && $module ne $2 + && -d "$cvsroot/$2") + { + close($fh); + redirect("$scriptname/$2$xtra$query"); + } + } + close($fh); + } + fatal("404 Not Found", '%s: no such file or directory', $where); +} + +gzipclose(); + +## End MAIN + + +sub printDiffSelect($) +{ + my ($use_java_script) = @_; + + print '"; +} + + +sub printDiffSelectStickyVars() +{ + while (my ($key, $val) = each %input) { + next if ($key eq 'f'); + next if (defined($DEFAULTVALUE{$key}) && $DEFAULTVALUE{$key} eq $val); + print "\n"; + } +} + + +sub printLogSortSelect($) +{ + my ($use_java_script) = @_; + + print '"; +} + + # -# Sort the revisions into commit-date order. - @revorder = sort {$date{$b} <=> $date{$a}} keys %date; - print "Done sorting revisions\n" if ($verbose); +# Find the last modified, version controlled files in the given directories. +# Compares solely based on modification timestamps. Files in the returned list +# are without the ,v suffix, and unreadable files have been filtered out. # -# HEAD is an artificial tag which is simply the highest tag number on the main -# branch, unless there is a branch tag in the RCS file in which case it's the -# highest revision on that branch. Find it by looking through @revorder; it -# is the first commit listed on the appropriate branch. - $headrev = $curbranch || "1"; - revision: - for ($i = 0; $i <= $#revorder; $i++) { - if ($revorder[$i] =~ /^(\S*)\.\d+$/ && $headrev eq $1) { - if ($revsym{$revorder[$i]}) { - $revsym{$revorder[$i]} .= ", "; - } - $revsym{$revorder[$i]} .= "HEAD"; - $symrev{"HEAD"} = $revorder[$i]; - last revision; - } - } - print "Done finding HEAD\n" if ($verbose); +sub findLastModifiedSubdirs(@) +{ + my (@dirs) = @_; + + my @files; + foreach my $dirname (@dirs) { + next if ($dirname eq curdir() || $dirname eq updir()); + my $dir = catdir($fullname, $dirname); + next if (!-d $dir); + + my $dh = do { local (*DH); }; + opendir($dh, $dir) or next; + my (@filenames) = grep(!forbidden(catfile($dir, $_)), readdir($dh)); + closedir($dh); + + my $lastmod = undef; + my $lastmodtime = undef; + foreach my $filename (@filenames) { + ($filename) = + (catfile($dirname, $filename) =~ VALID_PATH) or next; # untaint + my ($file) = catfile($fullname, $filename); + next if ($filename !~ /,v$/o || !-f $file || !-r _); + my $modtime = -M _; + if (!defined($lastmod) || $modtime < $lastmodtime) { + ($lastmod = $filename) =~ s/,v$//; + $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); + } + + return $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; + + if ($allow_mailtos) { + # Make mailto: links from email addresses. + $_ = htmlify_sub { + s< + ([\w+=\-.!]+@[\w\-]+(?:\.[\w\-]+)+) + >< + &link($1, "mailto:$1") + >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, uri_escape($name), $section)) + : $text; + }egx; + } $_; + } + } + + return $_; +} + + +sub spacedHtmlText($;$) +{ + (local $_, my $ts) = @_; + return '' unless defined($_); + $ts ||= $tabstop || 8; + + # Expand tabs + 1 while s/(.*?)(\t+)/$1 . ' ' x (length($2) * $ts - length($1) % $ts)/e; + + if ($hr_breakable) { + s/^ /\001nbsp;/; # protect leading and... + s/ $/\001nbsp;/; # ...trailing whitespace (mostly for String::Ediff), + s/ / \001nbsp;/g; # ...and leave every other space 'breakable' + } 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) = @_; + return sprintf('%s', htmlquote($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))) { + return $a <=> $b unless ($a == $b); + } + if (@r1) { return 1; } + if (@r2) { return -1; } + return 0; +} + + # -# Now that we know all of the revision numbers, we can associate -# absolute revision numbers with all of the symbolic names, and -# pass them to the form so that the same association doesn't have -# to be built then. +# Signal a fatal error. # -# should make this a case-insensitive sort - foreach (sort keys %symrev) { - $rev = $symrev{$_}; - if ($rev =~ /^(\d+(\.\d+)+)\.0\.(\d+)$/) { - push(@branchnames, $_); - # - # A revision number of A.B.0.D really translates into - # "the highest current revision on branch A.B.D". - # - # If there is no branch A.B.D, then it translates into - # the head A.B . - # - $head = $1; - $branch = $3; - $regex = $head . "." . $branch; - $regex =~ s/\./\./g; - # < - # \____/ - $rev = $head; +sub fatal($$@) +{ + my ($errcode, $format, @args) = @_; + print "Status: $errcode\r\n"; + html_header('Error'); + print '
Error: ', + sprintf($format, map(htmlquote($_), @args)), "
\n"; + html_footer(); + exit(1); +} - revision: - foreach $r (@revorder) { - if ($r =~ /^${regex}/) { - $rev = $head . "." . $branch; - last revision; - } - } - $revsym{$rev} .= ", " if ($revsym{$rev}); - $revsym{$rev} .= $_; - if ($rev ne $head) { - $branchpoint{$head} .= ", " if ($branchpoint{$head}); - $branchpoint{$head} .= $_; - } - } - $sel .= "