===================================================================
RCS file: /cvs/cvsweb/cvsweb.cgi,v
retrieving revision 1.1.1.33
retrieving revision 4.25
diff -u -p -r1.1.1.33 -r4.25
--- cvsweb/cvsweb.cgi 2002/07/23 16:15:22 1.1.1.33
+++ cvsweb/cvsweb.cgi 2019/11/26 11:53:01 4.25
@@ -1,4 +1,6 @@
-#!/usr/bin/perl -wT
+#!/usr/bin/perl
+# $Id: cvsweb.cgi,v 4.25 2019/11/26 11:53:01 schwarze Exp $
+# $knu: cvsweb.cgi,v 1.299 2010/11/13 16:37:18 simon
#
# cvsweb - a CGI interface to CVS trees.
#
@@ -21,7 +23,7 @@
# (c) 1998-1999 Henner Zeller
# (c) 1999 Henrik Nordstrom
# (c) 2000-2002 Akinori MUSHA
-# (c) 2002 Ville Skyttä
+# (c) 2002-2005 Ville Skyttä
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
@@ -44,62 +46,97 @@
# 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: projects/cvsweb/cvsweb.cgi,v 1.119 2002/07/23 13:58:32 scop Exp $
-# $zId: cvsweb.cgi,v 1.112 2001/07/24 13:03:16 hzeller Exp $
-# $Idaemons: /home/cvs/cvsweb/cvsweb.cgi,v 1.84 2001/10/07 20:50:10 knu Exp $
-#
-###
-require 5.000;
+require 5.006;
use strict;
+use warnings;
+use filetest qw(access);
use vars qw (
- $cvsweb_revision
- $mydir $uname $config $allow_version_select $verbose
- @CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr
- %MIRRORS %DEFAULTVALUE %ICONS %MTYPES
- @DIFFTYPES %DIFFTYPES @LOGSORTKEYS %LOGSORTKEYS
- %alltags @tabcolors %fileinfo %tags @branchnames %nameprinted
- %symrev %revsym @allrevisions %date %author @revdisplayorder
- @revisions %state %difflines %log %branchpoint @revorder
- $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
- $mimetype $charset $output_filter $defaultTextPlain $defaultViewable
- $command_path %CMD $allow_compress
- $backicon $diricon $fileicon
- $fullname $newname $cvstreedefault
- $body_tag $body_tag_for_src $logo $defaulttitle $address
- $long_intro $short_instruction $shortLogLen
- $show_author $dirtable $tablepadding $columnHeaderColorDefault
- $columnHeaderColorSorted $hr_breakable $showfunc $hr_ignwhite
- $hr_ignkeysubst $diffcolorHeading $diffcolorEmpty $diffcolorRemove
- $diffcolorChange $diffcolorAdd $diffcolorDarkChange $difffontface
- $difffontsize $inputTextSize $mime_types
- $allow_annotate $allow_markup
- $allow_log_extra $allow_dir_extra $allow_source_extra
- $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 $v
- $navigationHeaderColor $tableBorderColor $markupLogColor
- $tabstop $state $annTable $sel $curbranch @HideModules @ForbiddenFiles
- $module $use_descriptions %descriptions @mytz $dwhere $moddate
- $use_moddate $has_zlib $gzip_open
- $allow_tar @tar_options @gzip_options @zip_options @cvs_options
- $LOG_FILESEPARATOR $LOG_REVSEPARATOR
- $tmpdir $HTML_DOCTYPE $HTML_META
+ $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
+ $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
+ $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
+ $edit_option_form
+ $show_subdir_lastmod $show_log_in_markup $preformat_in_markup
+ $tabstop $state $annTable $sel @ForbiddenFiles
+ $use_descriptions %descriptions $dwhere
+ $use_moddate $gzip_open $file_list_len
+ $allow_tar @tar_options @gzip_options @cvs_options
+ @annotate_options @rcsdiff_options
+ $HTML_DOCTYPE $HTML_META $cssurl $CSS
);
-sub printDiffSelect($);
-sub printDiffLinks($$);
-sub printLogSortSelect($);
+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);
+
+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($;$);
@@ -107,25 +144,25 @@ sub spacedHtmlText($;$);
sub link($$);
sub revcmp($$);
sub fatal($$@);
-sub redirect($);
+sub redirect($;$);
sub safeglob($);
sub search_path($);
-sub getMimeTypeFromSuffix($);
+sub getMimeType($;$);
sub head($;$);
sub scan_directives(@);
sub openOutputFilter();
sub doAnnotate($$);
-sub doCheckout($$);
-sub cvswebMarkup($$$);
+sub doCheckout($$$);
+sub cvswebMarkup($$$$$$;$);
sub viewable($);
sub doDiff($$$$$$);
sub getDirLogs($$@);
sub readLog($;$);
-sub printLog($;$);
+sub printLog($$$;$$);
sub doLog($);
sub flush_diff_rows($$$$);
-sub human_readable_diff($);
-sub navigateHeader($$$$$);
+sub human_readable_diff($$);
+sub navigateHeader($$$$$;$);
sub plural_write($$);
sub readableTime($$);
sub clickablePath($$);
@@ -134,155 +171,118 @@ sub chooseMirror();
sub fileSortCmp();
sub download_url($$;$);
sub download_link($$$;$);
-sub toggleQuery($$);
-sub urlencode($);
+sub display_url($$;$);
+sub display_link($$;$$);
+sub toggleQuery($;$);
sub htmlquote($);
sub htmlunquote($);
-sub hrefquote($);
-sub http_header(;$);
-sub html_header($);
+sub uri_escape_path($);
+sub http_header(;$$);
+sub html_header($;$);
sub html_footer();
sub link_tags($);
-sub forbidden_file($);
-sub forbidden_module($);
+sub forbidden($);
+sub startproc(@);
+sub runproc(@);
+sub checkout_to_temp($$$);
-##### Start of Configuration Area ########
-delete $ENV{PATH};
+# 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)});
-$cvsweb_revision = '2.0.5';
+# Location of the configuration file inside the web server chroot:
+$config = '/conf/cvsweb/cvsweb.conf';
-use File::Basename ();
+######## Configuration parameters #########
-($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;
- }
-}
-
-# == 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 = @tabcolors = %fileinfo = ();
-$cvstreedefault = $body_tag = $body_tag_for_src = $logo = $defaulttitle =
- $address = $long_intro = $short_instruction = $shortLogLen = $show_author =
- $dirtable = $tablepadding = $columnHeaderColorDefault =
- $columnHeaderColorSorted = $hr_breakable = $showfunc = $hr_ignwhite =
- $hr_ignkeysubst = $diffcolorHeading = $diffcolorEmpty = $diffcolorRemove =
- $diffcolorChange = $diffcolorAdd = $diffcolorDarkChange = $difffontface =
- $difffontsize = $inputTextSize = $mime_types = $allow_annotate =
- $allow_markup = $use_java_script = $open_extern_window =
- $extern_window_width = $extern_window_height = $edit_option_form =
- $show_subdir_lastmod = $show_log_in_markup = $v = $navigationHeaderColor =
- $tableBorderColor = $markupLogColor = $tabstop = $use_moddate = $moddate =
- $gzip_open = $HTML_DOCTYPE = $HTML_META = undef;
-$tmpdir = defined($ENV{TMPDIR}) ? $ENV{TMPDIR} : "/var/tmp";
+ %MTYPES = %tags = %alltags = %fileinfo = %DIFF_COMMANDS = ();
-$LOG_FILESEPARATOR = q/^={77}$/;
-$LOG_REVSEPARATOR = q/^-{28}$/;
+$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 = $edit_option_form =
+ $show_subdir_lastmod = $show_log_in_markup = $preformat_in_markup =
+ $tabstop = $use_moddate = $gzip_open = $DEBUG =
+ $allow_tar = undef;
-@DIFFTYPES = qw(h H u c s);
+$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,
- },
- {
- 'descr' => 'side by side',
- 'opts' => ['--side-by-side', '--width=164'],
- 'colored' => 0,
- },
+ {
+ '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',
- },
+ { descr => 'Not sorted', },
+ { descr => 'Commit date', },
+ { descr => 'Revision', },
);
-$HTML_DOCTYPE =
- '';
+##### End of configuration parameters #####
-$HTML_META = <
-
-
-
-EOM
+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});
+}
-##### End of configuration variables #####
+$scriptname = '' unless defined($scriptname);
-use Time::Local ();
-use IPC::Open2 qw(open2);
+$where = $pathinfo;
+$doCheckout = $where =~ s|^/$CheckoutMagic/|/|o;
+$where =~ s|^/||;
+$scriptname =~ s|^/+||;
-# Check if the zlib C library interface is installed, and if yes
-# we can avoid using the extra gzip process.
-eval { require Compress::Zlib; };
-$has_zlib = !$@;
-
-$verbose = $v;
-$checkoutMagic = "~checkout~";
-$pathinfo = defined($ENV{PATH_INFO}) ? $ENV{PATH_INFO} : '';
-$where = $pathinfo;
-$doCheckout = ($where =~ m|^/$checkoutMagic/|);
-$where =~ s|^/$checkoutMagic/|/|;
-$where =~ s|^/||;
-$scriptname = defined($ENV{SCRIPT_NAME}) ? $ENV{SCRIPT_NAME} : '';
-$scriptname =~ s|^/*|/|;
-
# Let's workaround thttpd's stupidity..
if ($scriptname =~ m|/$|) {
- $pathinfo .= '/';
- my $re = quotemeta $pathinfo;
- $scriptname =~ s/$re$//;
+ $pathinfo .= '/';
+ my $re = quotemeta $pathinfo;
+ $scriptname =~ s/$re$//;
}
+$scriptname = "/$scriptname" if $scriptname;
-$scriptwhere = $scriptname;
-$scriptwhere .= '/' . urlencode($where);
-$where = '/' if ($where eq '');
+# $scriptname : the URI escaped path to this script
+# $where : the path in the CVS repository (without leading /, or only /)
+# $scriptwhere: the URI escaped $scriptname + '/' + $where
+$scriptname = uri_escape_path($scriptname);
+$scriptwhere = join('/', $scriptname, uri_escape_path($where));
+$where = '/' if ($where eq '');
-$is_mod_perl = defined($ENV{MOD_PERL});
+# In text-based browsers, it's very annoying to have two links per file;
+# skip linking the image for them.
-# in lynx, it it very annoying to have two links
-# per file, so disable the link at the icon
-# in this case:
-$Browser = $ENV{HTTP_USER_AGENT} || '';
-$is_links = ($Browser =~ m`^Links `);
+$Browser = $ENV{HTTP_USER_AGENT} || '';
+$is_links = ($Browser =~ m`^E?Links `);
$is_lynx = ($Browser =~ m`^Lynx/`i);
$is_w3m = ($Browser =~ m`^w3m/`i);
$is_msie = ($Browser =~ m`MSIE`);
@@ -301,811 +301,918 @@ $nofilelinks = $is_textbased;
# display garbage then :-/
# Turn off gzip if running under mod_perl and no zlib is available,
# piping does not work as expected inside the server.
-$maycompress =
- (((defined($ENV{HTTP_ACCEPT_ENCODING})
- && $ENV{HTTP_ACCEPT_ENCODING} =~ m`gzip`) || $is_mozilla3) && !$is_msie
- && !($is_mod_perl && !$has_zlib));
+$maycompress = (
+ ((defined($ENV{HTTP_ACCEPT_ENCODING})
+ && $ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/)
+ || $is_mozilla3)
+ && !$is_msie
+ && !(defined($ENV{MOD_PERL}))
+);
-# put here the variables we need in order
-# to hold our state - they will be added (with
-# their current value) to any link/query string
-# you construct
-@stickyvars = qw(cvsroot hideattic sortby logsort f only_with_tag);
-@unsafevars = qw(logsort only_with_tag r1 r2 rev sortby tr1 tr2);
+# Parameters that will be sticky in all constructed links/query strings.
+@stickyvars =
+ qw(cvsroot hideattic ignorecase sortby logsort f only_with_tag ln
+ hidecvsroot hidenonreadable);
-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.'
- );
+# 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;
-$query = $ENV{QUERY_STRING};
-if (defined($query) && $query ne '') {
- foreach (split (/&/, $query)) {
- y/+/ /;
- s/%(..)/sprintf("%c", hex($1))/ge; # unquote %-quoted
- if (/(\S+)=(.*)/) {
- $input{$1} = $2 if ($2 ne "");
- } else {
- $input{$_}++;
- }
- }
+my $t;
+for my $p (qw(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);
-# For backwards compability, set only_with_tag to only_on_branch if set.
-$input{only_with_tag} = $input{only_on_branch}
- if (defined($input{only_on_branch}));
+# --- end input parameters
-# Prevent cross-site scripting
-foreach (@unsafevars) {
- # Colons are needed in diffs between tags.
- if (defined($input{$_}) && $input{$_} =~ /[^\w\-.:]/) {
- fatal("500 Internal Error",
- 'Malformed query (%s=%s)',
- $_, $input{$_});
- }
+#
+# CVS roots
+#
+my $rootfound = 0;
+for (my $i = 0; $i < scalar(@CVSrepositories); $i += 2) {
+ my $key = $CVSrepositories[$i];
+ my ($descr, $root) = @{$CVSrepositories[$i+1]};
+ $root = canonpath($root);
+ unless (-d $root) {
+ warn("Root '$root' defined in \@CVSrepositories is not a directory, " .
+ 'entry ignored');
+ next;
+ }
+ $rootfound ||= 1;
+ $cvstreedefault = $key unless defined($cvstreedefault);
+ $CVSROOTdescr{$key} = $descr;
+ $CVSROOT{$key} = $root;
+ push(@CVSROOT, $key);
}
+unless ($rootfound) {
+ fatal('500 Internal Error',
+ 'No valid CVS roots found! See @CVSrepositories in ' .
+ 'the configuration file (%s).',
+ $config);
+}
+undef $rootfound;
-if (defined($input{"content-type"})) {
- fatal("500 Internal Error", "Unsupported content-type")
- if ($input{"content-type"} !~ /^[-0-9A-Za-z]+\/[-0-9A-Za-z]+$/);
+#
+# Default CVS root
+#
+if (!defined($CVSROOT{$cvstreedefault})) {
+ fatal("500 Internal Error",
+ '$cvstreedefault points to a repository (%s) not ' .
+ 'defined in @CVSrepositories in your configuration ' .
+ 'file (%s).',
+ $cvstreedefault,
+ $config);
}
-$DEFAULTVALUE{'cvsroot'} = $cvstreedefault;
+$DEFAULTVALUE{cvsroot} = $cvstreedefault;
-foreach (keys %DEFAULTVALUE) {
+while (my ($key, $defval) = each %DEFAULTVALUE) {
- # replace not given parameters with the default parameters
- if (!defined($input{$_}) || $input{$_} eq "") {
+ # Replace not given parameters with defaults.
+ next unless (defined($defval) && $defval =~ /\S/ && !defined($input{$key}));
- # Empty Checkboxes in forms return -- nothing. So we define a helper
- # variable in these forms (copt) which indicates that we just set
- # parameters with a checkbox
- if (!defined($input{"copt"})) {
+ # Empty checkboxes in forms return nothing, so we define a helper parameter
+ # in these forms (copt) which indicates that we just set parameters with a
+ # checkbox.
+ if ($input{copt}) {
- # 'copt' isn't defined --> empty input is not the result
- # of empty input checkbox --> set default
- $input{$_} = $DEFAULTVALUE{$_}
- if (defined($DEFAULTVALUE{$_}));
- } else {
+ # 'copt' is set -> the result of empty input checkbox
+ # -> set to zero (disable) if default is a boolean (0|1).
+ $input{$key} = 0 if ($defval eq '0' || $defval eq '1');
- # 'copt' is defined -> the result of empty input checkbox
- # -> set to zero (disable) if default is a boolean (0|1).
- $input{$_} = 0
- if (defined($DEFAULTVALUE{$_})
- && ($DEFAULTVALUE{$_} eq "0"
- || $DEFAULTVALUE{$_} eq "1"));
- }
- }
+ } else {
+
+ # 'copt' isn't set --> empty input is not the result
+ # of empty input checkbox --> set default.
+ $input{$key} = $defval;
+ }
}
$barequery = "";
my @barequery;
foreach (@stickyvars) {
- # construct a query string with the sticky non default parameters set
- if (defined($input{$_}) && $input{$_} ne ''
- && !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_}))
- {
- push @barequery,
- join ('=', urlencode($_), urlencode($input{$_}));
- }
+ # construct a query string with the sticky non default parameters set
+ if (defined($input{$_})
+ && !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_}))
+ {
+ push(@barequery, join('=', uri_escape($_), uri_escape($input{$_})));
+ }
}
# is there any query ?
if (@barequery) {
- $barequery = join ('&', @barequery);
- $query = "?$barequery";
- $barequery = "&$barequery";
+ $barequery = join (';', @barequery);
+ $query = "?$barequery";
+ $barequery = ";$barequery";
} else {
- $query = "";
+ $query = "";
}
undef @barequery;
if (defined($input{path})) {
- redirect("$scriptname/$input{path}$query");
+ redirect("$scriptname/$input{path}$query");
}
# get actual parameters
-$sortby = $input{"sortby"};
-$bydate = 0;
-$byrev = 0;
-$byauthor = 0;
-$bylog = 0;
-$byfile = 0;
-if ($sortby eq "date") {
- $bydate = 1;
-} elsif ($sortby eq "rev") {
- $byrev = 1;
-} elsif ($sortby eq "author") {
- $byauthor = 1;
-} elsif ($sortby eq "log") {
- $bylog = 1;
-} else {
- $byfile = 1;
-}
-
-$defaultDiffType = $input{'f'};
-
-$logsort = $input{'logsort'};
-
{
- my @tmp = @CVSrepositories;
- my @pair;
-
- while (@pair = splice(@tmp, 0, 2)) {
- my ($key, $val) = @pair;
- my ($descr, $cvsroot) = @$val;
-
- next if !-d $cvsroot;
-
- $CVSROOTdescr{$key} = $descr;
- $CVSROOT{$key} = $cvsroot;
- push @CVSROOT, $key;
- }
+ my $sortby = $input{sortby} || 'file';
+ $bydate = 0;
+ $byrev = 0;
+ $byauthor = 0;
+ $bylog = 0;
+ $byfile = 0;
+ if ($sortby eq 'date') {
+ $bydate = 1;
+ } elsif ($sortby eq 'rev') {
+ $byrev = 1;
+ } elsif ($sortby eq 'author') {
+ $byauthor = 1;
+ } elsif ($sortby eq 'log') {
+ $bylog = 1;
+ } else {
+ $byfile = 1;
+ }
}
-## Default CVS-Tree
-if (!defined($CVSROOT{$cvstreedefault})) {
- fatal("500 Internal Error",
- '$cvstreedefault points to a repository (%s) not defined in %%CVSROOT (edit your configuration file %s)',
- $cvstreedefault, $config);
-}
+$defaultDiffType = $input{f};
+$logsort = $input{logsort};
+
# alternate CVS-Tree, configured in cvsweb.conf
-if ($input{'cvsroot'} && $CVSROOT{$input{'cvsroot'}}) {
- $cvstree = $input{'cvsroot'};
+if ($input{cvsroot} && $CVSROOT{$input{cvsroot}}) {
+ $cvstree = $input{cvsroot};
} else {
- $cvstree = $cvstreedefault;
+ $cvstree = $cvstreedefault;
}
$cvsroot = $CVSROOT{$cvstree};
# create icons out of description
-my $k;
-foreach $k (keys %ICONS) {
- no strict 'refs';
- my ($itxt, $ipath, $iwidth, $iheight) = @{$ICONS{$k}};
- if ($ipath) {
- ${"${k}icon"} =
- sprintf(
- '',
- hrefquote($ipath), htmlquote($itxt), $iwidth, $iheight)
- } else {
- ${"${k}icon"} = $itxt;
- }
+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;
+ }
}
-undef $k;
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, $@);
+ do "$config_cvstree"
+ or fatal("500 Internal Error",
+ 'Error in loading configuration file: %s
Download this directory in ";
+ if (scalar %tags || $input{only_with_tag}) {
+ print "
+EOF
+ }
- # 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 ($allow_tar && $filesfound) {
+ my ($basefile) = ($where =~ m,(?:.*/)?([^/]+),);
+ my $havetar = $CMD{tar} && $CMD{gzip};
+ if (defined($basefile) && $basefile ne '' && $havetar) {
+ my $q = ($query ? "$query;" : '?') . 'tarball=1';
+ print "\n",
+ '
Download this directory in ';
+ # Mangle the filename so browsers show a reasonable filename to download.
+ $basefile = uri_escape($basefile);
+ print &link('tarball', "$basefile.tar.gz$q");
+ print "
\n";
+ }
+ }
- if ($edit_option_form || defined($input{"options"})) {
+ if ($edit_option_form || defined($input{options})) {
- my $formwhere = $scriptwhere;
- $formwhere =~ s|Attic/?$|| if ($input{'hideattic'});
-
- print "\n";
- }
- html_footer();
+ print <
+
+
+EOF
+ }
+ html_footer();
}
###############################
@@ -1113,2577 +1220,2667 @@ if (-d $fullname) {
###############################
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}, $input{only_with_tag});
+ gzipclose();
+ exit;
+ }
- if (defined($input{'rev'}) || $doCheckout) {
- &doCheckout($fullname, $input{'rev'});
- gzipclose();
- exit;
- }
+ if (defined($input{annotate}) && $allow_annotate) {
+ &doAnnotate($input{annotate}, $input{only_with_tag});
+ 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{'r1'}) && defined($input{'r2'})) {
- &doDiff(
- $fullname, $input{'r1'},
- $input{'tr1'}, $input{'r2'},
- $input{'tr2'}, $input{'f'}
- );
- gzipclose();
- exit;
- }
- print("going to dolog($fullname)\n") if ($verbose);
- &doLog($fullname);
+ &doLog($fullname);
+}
- ##############################
- # View Diff
- ##############################
-} elsif ($fullname =~ s/\.diff$// && -f $fullname . ",v" && $input{'r1'}
- && $input{'r2'})
+##############################
+# 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$//;
+ # $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")
-{
+ # 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;
- # 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);
+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;
- # 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);
+elsif (0 && (my @files = &safeglob($fullname . ",v"))) {
+ http_header("text/plain");
+ print "You matched the following files:\n";
+ print join ("\n", @files);
+
+ # 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) = @_;
- my $f = $input{'f'};
- print '";
}
-sub printLogSortSelect($) {
- my ($use_java_script) = @_;
- print '\n";
-
- local $_;
- for (@LOGSORTKEYS) {
- printf("\n", $_,
- $logsort eq $_ ? ' selected' : '',
- "\u$LOGSORTKEYS{$_}{'descr'}");
- }
-
- 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 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);
+sub printLogSortSelect()
+{
+ print '\n";
- my ($lastmod) = undef;
- my ($lastmodtime) = undef;
- my $dh = do { local (*DH); };
+ for my $sortkey (@LOGSORTKEYS) {
+ printf("\n",
+ $sortkey, $logsort eq $sortkey ? ' selected="selected"' : '',
+ "\u$LOGSORTKEYS{$sortkey}{descr}");
+ }
- opendir($dh, $dir) or next;
- my (@filenames) = readdir($dh);
- closedir($dh);
+ print "";
+}
- 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);
+#
+# 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.
+#
+sub findLastModifiedSubdirs(@)
+{
+ my (@dirs) = @_;
- $filename =~ s/,v$//;
- my $modtime = -M $file;
+ my @files;
+ foreach my $dirname (@dirs) {
+ next if ($dirname eq curdir() || $dirname eq updir());
+ my $dir = catdir($fullname, $dirname);
+ next if (!-d $dir);
- if (!defined($lastmod) || $modtime < $lastmodtime) {
- $lastmod = $filename;
- $lastmodtime = $modtime;
- }
- }
- push (@files, $lastmod) if (defined($lastmod));
- }
- return @files;
-}
+ my $dh = do { local (*DH); };
+ opendir($dh, $dir) or next;
+ my (@filenames) = grep(!forbidden(catfile($dir, $_)), readdir($dh));
+ closedir($dh);
-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;
+ 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($;$) {
- (local $_, my $extra) = @_;
- $_ = htmlquote($_);
+sub htmlify_sub(&$)
+{
+ (my $proc, local $_) = @_;
+ my @a = split(m|(]+>[^<]*)|i);
+ my $linked;
+ my $result = '';
- # get URL's as link
- s{
- (http|ftp|https)://\S+
- }{
- &link($&, htmlunquote($&))
- }egx;
+ while (($_, $linked) = splice(@a, 0, 2)) {
+ &$proc();
+ $result .= $_ if defined($_);
+ $result .= $linked if defined($linked);
+ }
- # get e-mails as link
- $_ = htmlify_sub {
- s<
- [\w+=\-.!]+@[\w\-]+(\.[\w\-]+)+
- ><
- &link($&, "mailto:$&")
- >egix;
- }
- $_;
+ return $result;
+}
- if ($extra) {
- # get PR #'s as link: "PR#nnnn" "PR: nnnn, ..." "PR nnnn, ..." "bin/nnnn"
- if (defined($prcgi) && defined($re_prkeyword))
- {
- my $prev;
+sub htmlify($;$)
+{
+ (local $_, my $extra) = @_;
- do {
- $prev = $_;
+ $_ = htmlquote($_);
- $_ = htmlify_sub {
- s{
- (\b$re_prkeyword[:\#]?\s*
- (?:
- \#?
- \d+[,\s]\s*
- )*
- \#?)
- (\d+)\b
- }{
- $1 . &link($2, sprintf($prcgi, $2))
- }egix;
- }
- $_;
- } while ($_ ne $prev);
+ # get URL's as link
+ s{
+ ((https?|ftp)://.+?)([\s\']|&(quot|[lg]t);)
+ }{
+ &link($1, htmlunquote($1)) . $3
+ }egx;
- if (defined($re_prcategories)) {
- $_ = htmlify_sub {
- s{
- (\b$re_prcategories/(\d+)\b)
- }{
- &link($1, sprintf($prcgi, $2))
- }egox;
- }
- $_;
- }
- }
+ if ($allow_mailtos) {
+ # Make mailto: links from email addresses.
+ $_ = htmlify_sub {
+ s<
+ ([\w+=\-.!]+@[\w\-]+(?:\.[\w\-]+)+)
+ ><
+ &link($1, "mailto:$1")
+ >egix;
+ } $_;
+ }
- # get manpage specs as link: "foo.1" "foo(1)"
- if (defined($mancgi)) {
- $_ = htmlify_sub {
- s{
- (\b([a-zA-Z][\w.]+)
- (?:
- \( ([0-9n]) \)\B
- |
- \.([0-9n])\b
- )
- )
- }{
- &link($1, sprintf($mancgi, defined($3) ? $3 : $4, $2))
- }egx;
- }
- $_;
- }
- }
+ if ($extra) {
+ # 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 $_ = $_[0];
- my $ts = $_[1] || $tabstop;
- # Cut trailing spaces and tabs
- s/[ \t]+$//;
+sub spacedHtmlText($;$)
+{
+ (local $_, my $ts) = @_;
+ return '' unless defined($_);
+ $ts ||= $tabstop || 8;
- if (defined($ts)) {
+ # Expand tabs
+ 1 while s/(.*?)(\t+)/$1 . ' ' x (length($2) * $ts - length($1) % $ts)/e;
- # Expand tabs
- 1 while s/\t+/' ' x (length($&) * $ts - length($`) % $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;
+ }
- # replace and (\001 is to protect us from htmlify)
- # gzip can make excellent use of this repeating pattern :-)
- if ($hr_breakable) {
+ $_ = htmlify($_, $allow_source_extra);
- # make every other space 'breakable'
- s/ / \001nbsp;/g; # 2 *
- # leave single space as it is
- } else {
- s/ /\001nbsp;/g;
- }
+ # unescape
+ y/\001/&/;
- $_ = htmlify($_, $allow_source_extra);
+ return $_;
+}
- # 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 link($$) {
- my ($name, $url) = @_;
- $url =~ s/:/sprintf("%%%02x", ord($&))/eg
- if $url =~ /^[^a-z]/; # relative
+sub revcmp($$)
+{
+ my ($rev1, $rev2) = @_;
- sprintf '%s', hrefquote($url), $name;
-}
+ # make no comparison for a tag or a branch
+ return 0 if $rev1 =~ /[^\d.]/ || $rev2 =~ /[^\d.]/;
-sub revcmp($$) {
- my ($rev1, $rev2) = @_;
+ my (@r1) = split(/\./, $rev1);
+ my (@r2) = split(/\./, $rev2);
+ my ($a, $b);
- # make no comparison for a tag or a branch
- return 0 if $rev1 =~ /[^\d.]/ || $rev2 =~ /[^\d.]/;
+ while (($a = shift(@r1)) && ($b = shift(@r2))) {
+ return $a <=> $b unless ($a == $b);
+ }
+ if (@r1) { return 1; }
+ if (@r2) { return -1; }
+ return 0;
+}
- 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;
+#
+# Signal a fatal error.
+#
+sub fatal($$@)
+{
+ my ($errcode, $format, @args) = @_;
+ print "Status: $errcode\r\n";
+ html_header('Error');
+ print '
This document is located ", &link('here', $url), "
\n";
- html_footer();
- exit(1);
+#
+# Sends a redirect to the given URL.
+#
+sub redirect($;$)
+{
+ my ($url, $permanent) = @_;
+ my ($status, $text);
+ if ($permanent) {
+ $status = '301';
+ $text = 'Moved Permanently';
+ } else {
+ $status = '302';
+ $text = 'Found';
+ }
+ print "Status: $status $text\r\n", "Location: $url\r\n";
+ html_header($text);
+ print "
This document has moved ", &link('here', $url), ".
\n";
+ html_footer();
+ exit(1);
}
-sub safeglob($) {
- my ($filename) = @_;
- my ($dirname);
- my (@results);
- my $dh = do { local (*DH); };
- ($dirname = $filename) =~ s|/[^/]+$||;
- $filename =~ s|.*/||;
+sub safeglob($)
+{
+ my ($filename) = @_;
- if (opendir($dh, $dirname)) {
- my $glob = $filename;
- my $t;
+ (my $dirname = $filename) =~ s|/[^/]+$||;
+ $filename =~ s|.*/||;
- # transform filename from glob to regex. Deal with:
- # [, {, ?, * as glob chars
- # make sure to escape all other regex chars
- $glob =~ s/([\.\(\)\|\+])/\\$1/g;
- $glob =~ s/\*/.*/g;
- $glob =~ s/\?/./g;
- $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg;
- foreach (readdir($dh)) {
+ my @results;
+ my $dh = do { local (*DH); };
+ if (opendir($dh, $dirname)) {
+ my $glob = $filename;
+ my $t;
- if (/^${glob}$/) {
- push (@results, "$dirname/" . $_);
- }
- }
- closedir($dh);
- }
+ # transform filename from glob to regex. Deal with:
+ # [, {, ?, * as glob chars
+ # make sure to escape all other regex chars
+ $glob =~ s/([\.\(\)\|\+])/\\$1/g;
+ $glob =~ s/\*/.*/g;
+ $glob =~ s/\?/./g;
+ $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg;
+ $glob = qr/^$glob$/;
- @results;
+ foreach (readdir($dh)) {
+ if ($_ =~ $glob && $_ =~ VALID_PATH) {
+ push(@results, catfile($dirname, $1)); # untaint
+ }
+ }
+ closedir($dh);
+ }
+
+ return @results;
}
-sub search_path($) {
- my ($command) = @_;
- my $d;
- for $d (split (/:/, $command_path)) {
- return "$d/$command" if -x "$d/$command";
- }
-
- '';
+#
+# Searches @command_path for the given executable file.
+#
+sub search_path($)
+{
+ my ($command) = @_;
+ for my $d (@command_path) {
+ my $cmd = catfile($d, $command);
+ return $cmd if (-x $cmd && !-d _);
+ }
+ return '';
}
-sub getMimeTypeFromSuffix($) {
- my ($fullname) = @_;
- my ($mimetype, $suffix);
- my $fh = do { local (*FH); };
- ($suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/;
- $mimetype = $MTYPES{$suffix};
- $mimetype = $MTYPES{'*'} if (!$mimetype);
+#
+# Gets the MIME type for the given file name.
+#
+sub getMimeType($;$)
+{
+ my ($fullname, $binary) = @_;
+ $binary = ($keywordsubstitution && $keywordsubstitution =~ /b/)
+ unless defined($binary);
- if (!$mimetype && -f $mime_types) {
+ (my $suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/;
- # okey, this is something special - search the
- # mime.types database
- open($fh, "<$mime_types");
- while (<$fh>) {
- if ($_ =~ /^\s*(\S+\/\S+).*\b$suffix\b/) {
- $mimetype = $1;
- last;
- }
- }
- close($fh);
- }
+ my $mimetype = $MTYPES{$suffix};
+ $mimetype ||= $MimeTypes->mimeTypeOf($fullname) if defined($MimeTypes);
- # okey, didn't find anything useful ..
- if (!($mimetype =~ /\S\/\S/)) {
- $mimetype = "text/plain";
- }
- return $mimetype;
+ if (!$mimetype && $suffix ne '*' && -f $mime_types && -r _) {
+ my $fh = do { local (*FH); };
+ if (open($fh, $mime_types)) {
+ my $re = sprintf('^\s*(\S+\/\S+)\s.+\b%s\b', quotemeta($suffix));
+ $re = qr/$re/;
+ while (my $line = <$fh>) {
+ if ($line =~ $re) {
+ $mimetype = $1;
+ $MTYPES{$suffix} = $mimetype;
+ last;
+ }
+ }
+ close($fh);
+ } else {
+ warn("Can't open MIME types file $mime_types for reading: $!");
+ }
+ }
+
+ $mimetype ||= $MTYPES{'*'};
+ $mimetype ||= $binary ? 'application/octet-stream' : 'text/plain';
+ return $mimetype;
}
+
###############################
# read first lines like head(1)
###############################
-sub head($;$) {
- my $fh = $_[0];
- my $linecount = $_[1] || 10;
+sub head($;$)
+{
+ my ($fh, $linecount) = @_;
+ $linecount ||= 10;
- my @buf;
-
- if ($linecount > 0) {
- my $i;
- for ($i = 0 ; !eof($fh) && $i < $linecount ; $i++) {
- push @buf, scalar <$fh>;
- }
- } else {
- @buf = <$fh>;
- }
-
- @buf;
+ my @buf;
+ if ($linecount > 0) {
+ for (my $i = 0; !eof($fh) && $i < $linecount; $i++) {
+ push @buf, scalar <$fh>;
+ }
+ } else {
+ @buf = <$fh>;
+ }
+ return @buf;
}
+
###############################
# scan vim and Emacs directives
###############################
-sub scan_directives(@) {
- my $ts = undef;
+sub scan_directives(@)
+{
+ my $ts = undef;
- for (@_) {
- $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/;
- }
+ for (@_) {
+ $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/;
+ }
- ('tabstop' => $ts);
+ ('tabstop' => $ts);
}
-sub openOutputFilter() {
- return if !defined($output_filter) || $output_filter eq '';
- open(STDOUT, "|-") and return;
+sub openOutputFilter()
+{
+ return unless $output_filter;
- # child of child
- open(STDERR, '>/dev/null');
- exec($output_filter) or exit -1;
+ open(STDOUT, "|-") and return;
+
+ # child of child
+ open(STDERR, '>', devnull()) unless $DEBUG;
+ exec($output_filter) or exit -1;
}
+
###############################
# show Annotation
###############################
-sub doAnnotate($$) {
- my ($rev) = @_;
- my ($pid);
- my ($pathname, $filename);
- my $reader = do { local (*FH); };
- my $writer = do { local (*FH); };
+sub doAnnotate($$)
+{
+ my ($rev, $tag) = @_;
+ $rev = $tag || 'HEAD' if ($rev eq '.');
+ (my $pathname = $where) =~ s|((?<=/)Attic/)?[^/]*$||;
+ (my $filename = $where) =~ s|^.*/||;
- # make sure the revisions are wellformed, for security
- # reasons ..
- if ($rev =~ /[^\w.]/) {
- fatal("404 Not Found",
- 'Malformed query "%s"',
- $ENV{QUERY_STRING});
- }
+ # This annotate version is based on the cvs annotate-demo Perl script by
+ # Cyclic Software. It was written by Cyclic Software,
+ # http://www.cyclic.com/, and is in the public domain.
+ # We could abandon the use of rlog, rcsdiff and co using
+ # the cvs server in a similiar way one day (..after rewrite).
- ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;
- ($filename = $where) =~ s/^.*\///;
+ local (*CVS_IN, *CVS_OUT);
+ my $annotate_err;
+ my ($h, $err) =
+ startproc([ $CMD{cvs}, @annotate_options, 'server' ],
+ 'pipe', \*CVS_OUT,
+ '2>', \$annotate_err);
+ fatal('500 Internal Error',
+ 'Annotate failure (exit status %s), output:
%s
',
+ $? >> 8 || -1, $err)
+ unless $h;
- # this seems to be necessary
- $| = 1;
- $| = 0; # Flush
+ # OK, first send the request to the server. A simplified example is:
+ # Root /home/kingdon/zwork/cvsroot
+ # Argument foo/xx
+ # Directory foo
+ # /home/kingdon/zwork/cvsroot/foo
+ # Directory .
+ # /home/kingdon/zwork/cvsroot
+ # annotate
+ # although as you can see there are a few more details.
- # 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}, @cvs_options, "server")
- or fatal("500 Internal Error",
- 'Fatal Error - unable to open cvs for annotation');
+ print CVS_IN "Root $cvsroot\n";
+ print CVS_IN
+ "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n";
- # 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.
+ # 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";
- print $writer "Root $cvsroot\n";
- print $writer
- "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\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)) {
- # 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";
+ if ($path eq "") {
+ # In our example, $dir is "dir".
+ $path = $dir;
+ } else {
+ print CVS_IN "Directory $path\n";
+ print CVS_IN "$cvsroot/$path\n";
- # The protocol requires us to fully fake a working directory (at
- # least to the point of including the directories down to the one
- # containing the file in question).
- # So if $where is "dir/sdir/file", then @dirs will be ("dir","sdir","file")
- my @dirs = split ('/', $where);
- my $path = "";
- foreach (@dirs) {
+ # 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;
- if ($path eq "") {
+ # And the last "Directory" before "annotate" is the top level.
+ print CVS_IN "Directory .\n";
+ print CVS_IN "$cvsroot\n";
- # In our example, $_ is "dir".
- $path = $_;
- } else {
- print $writer "Directory $path\n";
- print $writer "$cvsroot/$path\n";
+ print CVS_IN "annotate\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 .= "/$_";
- }
- }
+ # 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);
+ }
- # And the last "Directory" before "annotate" is the top level.
- print $writer "Directory .\n";
- print $writer "$cvsroot\n";
+ navigateHeader($scriptwhere, $pathname, $filename, $rev, 'annotate');
- print $writer "annotate\n";
+ my $revtype = ($rev =~ /\./) ? 'revision' : 'tag'; # TODO: tag -> branch/tag?
+ print '
Annotation of ',
+ htmlquote("$pathname$filename"), ", $revtype $rev
\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: $!";
+ # 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);
- http_header();
+ if ($annTable) {
+ print <
+EOF
+ } else {
+ print "
\n";
+ # prefetch several lines
+ my @buf = head(*CVS_OUT);
- # Ready to get the responses from the server.
- # For example:
- # E Annotations for foo/xx
- # E ***************
- # M 1.3 (kingdon 06-Sep-97): hello
- # ok
- my ($lineNr) = 0;
- my ($oldLrev, $oldLusr) = ("", "");
- my ($revprint, $usrprint);
+ my %d = scan_directives(@buf);
- if ($annTable) {
- print "
\n";
- } else {
- print "
";
- }
+ while (@buf || !eof(*CVS_OUT)) {
- # prefetch several lines
- my @buf = head($reader);
+ $_ = @buf ? shift @buf : ;
+ my @words = split;
- my %d = scan_directives(@buf);
+ # 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);
- while (@buf || !eof($reader)) {
- $_ = @buf ? shift @buf : <$reader>;
+ # we should parse the date here ..
+ if ($lrev eq $oldLrev) {
+ $revprint = sprintf('%-8s', '');
+ } else {
+ $revprint = sprintf('%-8s', $lrev);
+ $revprint =~ s|(\S+)|&link($1, uri_escape($filename)."$query#rev$1")|e;
+ $oldLusr = '';
+ }
- my @words = split;
+ $usrprint = ($lusr eq $oldLusr) ? '' : $lusr;
+ $oldLrev = $lrev;
+ $oldLusr = $lusr;
- # Adding one is for the (single) space which follows $words[0].
- my $rest = substr($_, length($words[0]) + 1);
- if ($words[0] eq "E") {
- next;
- } elsif ($words[0] eq "M") {
- $lineNr++;
- (my $lrev = substr($_, 2, 13)) =~ y/ //d;
- (my $lusr = substr($_, 16, 9)) =~ y/ //d;
- my $line = substr($_, 36);
- my $isCurrentRev = ($rev eq $lrev);
+ print $is_textbased ? '' : ''
+ if $isCurrentRev;
- # we should parse the date here ..
- if ($lrev eq $oldLrev) {
- $revprint = sprintf('%-8s', '');
- } else {
- $revprint = sprintf('%-8s', $lrev);
- $revprint =~
- s`\S+`&link($&, "$scriptwhere$query#rev$&")`e
- ; # `
- $oldLusr = '';
- }
+ $usrprint = sprintf('%-8s', $usrprint);
+ printf '%s%s %s %4d:', $revprint, $isCurrentRev ? '!' : ' ',
+ htmlquote($usrprint), $lineNr;
+ print spacedHtmlText($line, $d{tabstop});
- if ($lusr eq $oldLusr) {
- $usrprint = '';
- } else {
- $usrprint = $lusr;
- }
- $oldLrev = $lrev;
- $oldLusr = $lusr;
+ print $is_textbased ? '' : '' if $isCurrentRev;
- # 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);
+ } 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.
- printf "%s%s %-8s %4d:", $revprint,
- $isCurrentRev ? '!' : ' ', $usrprint, $lineNr;
- print spacedHtmlText($line, $d{'tabstop'});
+ } elsif ($words[0] eq "error") {
+ fatal("500 Internal Error",
+ 'Error occured during annotate: %s', $_);
+ }
+ }
+ $h->finish();
- 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 "";
- }
- close($reader) or warn "cannot close: $!";
- wait;
+ if ($annTable) {
+ print "";
+ } else {
+ print "";
+ }
+ html_footer();
}
###############################
# make Checkout
###############################
-sub doCheckout($$) {
- my ($fullname, $rev) = @_;
- my ($mimetype, $revopt);
- my $fh = do { local (*FH); };
+sub doCheckout($$$)
+{
+ my ($fullname, $rev, $tag) = @_;
+ $rev = $tag || undef if (!$rev || $rev eq '.');
- if ($rev eq 'HEAD' || $rev eq '.') {
- $rev = undef;
- }
+ # Start resolving whether we will do a markup view or not.
+ my $do_markup = undef;
+ my $want_type = $input{'content-type'};
- # make sure the revisions a wellformed, for security
- # reasons ..
- if (defined($rev) && $rev =~ /[^\w.]/) {
- fatal("404 Not Found",
- 'Malformed query "%s"',
- $ENV{QUERY_STRING});
- }
+ # No markup if markup disallowed.
+ $do_markup = 0 unless $allow_markup;
- # get mimetype
- if (defined($input{"content-type"})
- && ($input{"content-type"} =~ /\S\/\S/))
- {
- $mimetype = $input{"content-type"}
- } else {
- $mimetype = &getMimeTypeFromSuffix($fullname);
- }
+ # No markup if checkout magic cookie in URL.
+ $do_markup = 0 if (!defined($do_markup) && $doCheckout);
- if (defined($rev)) {
- $revopt = "-r$rev";
- if ($use_moddate) {
- readLog($fullname, $rev);
- $moddate = $date{$rev};
- }
- } else {
- $revopt = "-rHEAD";
+ # 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;
+ }
+ }
- if ($use_moddate) {
- readLog($fullname);
- $moddate = $date{$symrev{HEAD}};
- }
- }
+ # 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;
- ### 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
+ 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}};
+ }
+ }
- # work around a bug of cvs -p; expand symlinks
- use Cwd 'abs_path';
- exec($CMD{cvs}, @cvs_options,
- '-d', abs_path($cvsroot),
- 'co', '-p',
- $revopt, $where) or exit -1;
- }
+ 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: %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);
- if (eof($fh)) {
- fatal("404 Not Found",
- '%s is not (any longer) pertinent',
- $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;
- #===================================================================
- #Checking out squid/src/ftp.c
- #RCS: /usr/src/CVS/squid/src/ftp.c,v
- #VERS: 1.1.1.28.6.2
- #***************
+ if (eof(CVS_ERR)) {
+ $h->finish();
+ fatal("404 Not Found", '%s is not (any longer) pertinent', $where);
+ }
- # Parse CVS header
- my ($revision, $filename, $cvsheader);
- $filename = "";
- while (<$fh>) {
- last if (/^\*\*\*\*/);
- $revision = $1 if (/^VERS: (.*)$/);
+ #===================================================================
+ #Checking out squid/src/ftp.c
+ #RCS: /usr/src/CVS/squid/src/ftp.c,v
+ #VERS: 1.1.1.28.6.2
+ #***************
- if (/^Checking out (.*)$/) {
- $filename = $1;
- $filename =~ s/^\.\/*//;
- }
- $cvsheader .= $_;
- }
+ # Parse CVS header
+ my ($revision, $filename, $cvsheader);
+ $filename = "";
+ while () {
+ last if (/^\*\*\*\*/);
+ $revision = $1 if (/^VERS: (.*)$/);
- if ($filename ne $where) {
- fatal("500 Internal Error",
- 'Unexpected output from cvs co: %s',
- $cvsheader);
- }
- $| = 1;
+ if (/^Checking out (.*)$/) {
+ ($filename = $1) =~ s|^\./+||;
+ }
+ $cvsheader .= $_;
+ }
+ close(CVS_ERR);
- if ($mimetype eq "text/x-cvsweb-markup") {
- &cvswebMarkup($fh, $fullname, $revision);
- } else {
- http_header($mimetype);
- print <$fh>;
- }
- close($fh);
-}
+ if ($filename ne $where) {
+ $h->finish();
+ fatal("500 Internal Error",
+ 'Unexpected output from cvs co:
%s
' .
+ '(expected "%s" but got "%s")',
+ $cvsheader, $where, $filename);
+ }
-sub cvswebMarkup($$$) {
- my ($filehandle, $fullname, $revision) = @_;
- my ($pathname, $filename);
+ # Last checks whether we'll do markup or not.
+ my $isbin = $keywordsubstitution && $keywordsubstitution =~ /b/;
+ my $mimetype = getMimeType($fullname, $isbin);
- ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;
- ($filename = $where) =~ s/^.*\///;
- my ($fileurl) = urlencode($filename);
+ # 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);
- http_header();
+ if ($do_markup) {
- navigateHeader($scriptwhere, $pathname, $filename, $revision, "view");
- print "";
- print "
\n
\n
";
- print "File: ", &clickablePath($where, 1);
- print " (";
- &download_link($fileurl, $revision, "download");
- print ")";
+ # If this is something we'll be linking to in the markup view, we are
+ # done with this particular output from "cvs co" and must discard it.
+ my $linked = $mimetype =~ m{^image/|application/pdf$}i;
+ if ($linked) {
+ close(CVS_OUT);
+ $h->finish();
+ }
- if (!$defaultTextPlain) {
- print " (";
- &download_link($fileurl, $revision, "as text", "text/plain");
- print ")";
- }
- print " \n";
+ # 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);
- if ($show_log_in_markup) {
- readLog($fullname); #,$revision);
- printLog($revision, 0);
- } else {
- print "Version: $revision \n";
- print "Tag: ", $input{only_with_tag}, " \n"
- if $input{only_with_tag};
- }
- print "