\n";
+
+ # Do not display the other column headers if we do not have any files
+ # with revision information.
+ if (scalar(%fileinfo)) {
+ $infocols++;
+ printf('
';
+ 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 "
";
+ $dirrow++;
+ }
+ print "\n";
+ }
+
+ print "\n";
+
+ if ((my $num = scalar(@unreadable)) && ! $input{hidenonreadable}) {
+ printf(<
+ NOTE: The following %d unreadable files were ignored:
+ %s
+
+EOF
+ }
+
+ if ($filesexists && !$filesfound) {
+ my $currtag = defined($input{only_with_tag}) ?
+ sprintf(' (%s)', htmlquote($input{only_with_tag})) : '';
+ printf(<
+ NOTE: There are %d files, but none matches the current tag%s.
+
+EOF
+ }
+
+ if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}})) {
+ %tags = %alltags;
+ }
+
+ if (scalar %tags
+ || $input{only_with_tag}
+ || $edit_option_form
+ || defined($input{options}))
+ {
+ print "\n";
+ }
+
+ if (scalar %tags || $input{only_with_tag}) {
+ print "
+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 <
+
+
+EOF
+ }
+ html_footer();
}
###############################
# View Files
###############################
elsif (-f $fullname . ',v') {
- if (forbidden_file($fullname)) {
- fatal('403 Forbidden',
- 'Access forbidden. This file is mentioned in @ForbiddenFiles');
- return;
- }
-
- if (defined($input{'rev'}) || $doCheckout) {
- &doCheckout($fullname, $input{'rev'});
- gzipclose();
- exit;
- }
-
- if (defined($input{'annotate'}) && $allow_annotate) {
- &doAnnotate($input{'annotate'});
- gzipclose();
- exit;
- }
-
- if (defined($input{'r1'}) && defined($input{'r2'})) {
- &doDiff(
- $fullname, $input{'r1'},
- $input{'tr1'}, $input{'r2'},
- $input{'tr2'}, $input{'f'}
- );
- gzipclose();
- exit;
- }
- print("going to dolog($fullname)\n") if ($verbose);
- &doLog($fullname);
-
- ##############################
- # View Diff
- ##############################
-} elsif ($fullname =~ s/\.diff$// && -f $fullname . ",v" && $input{'r1'}
- && $input{'r2'})
-{
-
- # $where-diff-removal if 'cvs rdiff' is used
- # .. but 'cvs rdiff'doesn't support some options
- # rcsdiff does (-w and -p), so it is disabled
- # $where =~ s/\.diff$//;
-
- # Allow diffs using the ".diff" extension
- # so that browsers that default to the URL
- # for a save filename don't save diff's as
- # e.g. foo.c
- &doDiff(
- $fullname, $input{'r1'}, $input{'tr1'}, $input{'r2'},
- $input{'tr2'}, $input{'f'}
- );
- gzipclose();
- exit;
-} elsif (($newname = $fullname) =~ s|/([^/]+)$|/Attic/$1| && -f $newname . ",v")
-{
-
- # The file has been removed and is in the Attic.
- # Send a redirect pointing to the file in the Attic.
- (my $newplace = $scriptwhere) =~ s|/([^/]+)$|/Attic/$1|;
- if ($ENV{QUERY_STRING} ne "") {
- redirect("${newplace}?$ENV{QUERY_STRING}");
- } else {
- redirect($newplace);
- }
- exit;
-} elsif (0 && (my @files = &safeglob($fullname . ",v"))) {
- http_header("text/plain");
- print "You matched the following files:\n";
- print join ("\n", @files);
-
- # Find the tags from each file
- # Display a form offering diffs between said tags
-} else {
- my $fh = do { local (*FH); };
- my ($xtra, $module);
-
- # Assume it's a module name with a potential path following it.
- $xtra = (($module = $where) =~ s|/.*||) ? $& : '';
-
- # Is there an indexed version of modules?
- if (open($fh, "< $cvsroot/CVSROOT/modules")) {
- while (<$fh>) {
- if (/^(\S+)\s+(\S+)/o && $module eq $1
- && -d "$cvsroot/$2" && $module ne $2)
- {
- redirect("$scriptname/$2$xtra$query");
- }
- }
- }
- fatal("404 Not Found",
- '%s: no such file or directory',
- $where);
+ if (defined($input{rev}) || $doCheckout) {
+ &doCheckout($fullname, $input{rev}, $input{only_with_tag});
+ gzipclose();
+ exit;
+ }
+
+ 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);
+}
+
+##############################
+# 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;
+
+}
+
+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 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, $section, uri_escape($name)))
+ : $text;
+ }egx;
+ } $_;
+ }
+ }
+
+ return $_;
}
-sub printLogSortSelect($) {
- my ($use_java_script) = @_;
- print '\n";
+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/&/;
- local $_;
- for (@LOGSORTKEYS) {
- printf("\n", $_,
- $logsort eq $_ ? ' selected' : '',
- "\u$LOGSORTKEYS{$_}{'descr'}");
- }
-
- print "";
-}
-
-sub findLastModifiedSubdirs(@) {
- my (@dirs) = @_;
- my ($dirname, @files);
-
- foreach $dirname (@dirs) {
- next if ($dirname eq ".");
- next if ($dirname eq "..");
- my ($dir) = "$fullname/$dirname";
- next if (!-d $dir);
-
- my ($lastmod) = undef;
- my ($lastmodtime) = undef;
- my $dh = do { local (*DH); };
-
- opendir($dh, $dir) or next;
- my (@filenames) = readdir($dh);
- closedir($dh);
-
- foreach my $filename (@filenames) {
- $filename = "$dirname/$filename";
- my ($file) = "$fullname/$filename";
- next if ($filename !~ /,v$/ || !-f $file);
-
- # Skip forbidden files.
- (my $f = $file) =~ s/,v$//;
- next if forbidden_file($f);
-
- $filename =~ s/,v$//;
- my $modtime = -M $file;
-
- if (!defined($lastmod) || $modtime < $lastmodtime) {
- $lastmod = $filename;
- $lastmodtime = $modtime;
- }
- }
- push (@files, $lastmod) if (defined($lastmod));
- }
- return @files;
-}
-
-sub htmlify_sub(&$) {
- (my $proc, local $_) = @_;
- my @a = split (m`(]+>[^<]*)`i);
- my $linked;
- my $result = '';
-
- while (($_, $linked) = splice(@a, 0, 2)) {
- &$proc();
- $result .= $_ if defined($_);
- $result .= $linked if defined($linked);
- }
-
- $result;
-}
-
-sub htmlify($;$) {
- (local $_, my $extra) = @_;
-
- $_ = htmlquote($_);
-
- # get URL's as link
- s{
- (http|ftp|https)://\S+
- }{
- &link($&, htmlunquote($&))
- }egx;
-
- # get e-mails as link
- $_ = htmlify_sub {
- s<
- [\w+=\-.!]+@[\w\-]+(\.[\w\-]+)+
- ><
- &link($&, "mailto:$&")
- >egix;
- }
- $_;
-
- if ($extra) {
-
- # get PR #'s as link: "PR#nnnn" "PR: nnnn, ..." "PR nnnn, ..." "bin/nnnn"
- if (defined($prcgi) && defined($re_prkeyword))
- {
- my $prev;
-
- do {
- $prev = $_;
-
- $_ = htmlify_sub {
- s{
- (\b$re_prkeyword[:\#]?\s*
- (?:
- \#?
- \d+[,\s]\s*
- )*
- \#?)
- (\d+)\b
- }{
- $1 . &link($2, sprintf($prcgi, $2))
- }egix;
- }
- $_;
- } while ($_ ne $prev);
-
- if (defined($re_prcategories)) {
- $_ = htmlify_sub {
- s{
- (\b$re_prcategories/(\d+)\b)
- }{
- &link($1, sprintf($prcgi, $2))
- }egox;
- }
- $_;
- }
- }
-
- # get manpage specs as link: "foo.1" "foo(1)"
- if (defined($mancgi)) {
- $_ = htmlify_sub {
- s{
- (\b([a-zA-Z][\w.]+)
- (?:
- \( ([0-9n]) \)\B
- |
- \.([0-9n])\b
- )
- )
- }{
- &link($1, sprintf($mancgi, defined($3) ? $3 : $4, $2))
- }egx;
- }
- $_;
- }
- }
-
- $_;
-}
-
-sub spacedHtmlText($;$) {
- local $_ = $_[0];
- my $ts = $_[1] || $tabstop;
-
- # Cut trailing spaces and tabs
- s/[ \t]+$//;
-
- if (defined($ts)) {
-
- # Expand tabs
- 1 while s/\t+/' ' x (length($&) * $ts - length($`) % $ts)/e
- }
-
- # replace and (\001 is to protect us from htmlify)
- # gzip can make excellent use of this repeating pattern :-)
- if ($hr_breakable) {
-
- # make every other space 'breakable'
- s/ / \001nbsp;/g; # 2 *
- # leave single space as it is
- } else {
- s/ /\001nbsp;/g;
- }
-
- $_ = htmlify($_, $allow_source_extra);
-
- # unescape
- y/\001/&/;
-
- return $_;
+ return $_;
}
+
# Note that this doesn't htmlquote the first argument...
-sub link($$) {
- my ($name, $url) = @_;
-
- $url =~ s/:/sprintf("%%%02x", ord($&))/eg
- if $url =~ /^[^a-z]/; # relative
-
- sprintf '%s', hrefquote($url), $name;
-}
-
-sub revcmp($$) {
- my ($rev1, $rev2) = @_;
-
- # make no comparison for a tag or a branch
- return 0 if $rev1 =~ /[^\d.]/ || $rev2 =~ /[^\d.]/;
-
- my (@r1) = split (/\./, $rev1);
- my (@r2) = split (/\./, $rev2);
- my ($a, $b);
-
- while (($a = shift (@r1)) && ($b = shift (@r2))) {
- if ($a != $b) {
- return $a <=> $b;
- }
- }
- if (@r1) { return 1; }
- if (@r2) { return -1; }
- return 0;
-}
-
-sub fatal($$@) {
- my ($errcode, $format, @args) = @_;
- if ($is_mod_perl) {
- Apache->request->status((split (/ /, $errcode))[0]);
- } else {
- print "Status: $errcode\r\n";
- }
- html_header("Error");
- print "
This document has moved ", &link('here', $url), ".
\n";
+ html_footer();
+ exit(1);
+}
+
+
+sub safeglob($)
+{
+ my ($filename) = @_;
+
+ (my $dirname = $filename) =~ s|/[^/]+$||;
+ $filename =~ s|.*/||;
+
+ my @results;
+ my $dh = do { local (*DH); };
+ if (opendir($dh, $dirname)) {
+ my $glob = $filename;
+ my $t;
+
+ # transform filename from glob to regex. Deal with:
+ # [, {, ?, * as glob chars
+ # make sure to escape all other regex chars
+ $glob =~ s/([\.\(\)\|\+])/\\$1/g;
+ $glob =~ s/\*/.*/g;
+ $glob =~ s/\?/./g;
+ $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg;
+ $glob = qr/^$glob$/;
+
+ foreach (readdir($dh)) {
+ if ($_ =~ $glob && $_ =~ VALID_PATH) {
+ push(@results, catfile($dirname, $1)); # untaint
+ }
+ }
+ closedir($dh);
+ }
+
+ return @results;
+}
+
+
+#
+# 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 '';
+}
- if ($linecount > 0) {
- my $i;
- for ($i = 0 ; !eof($fh) && $i < $linecount ; $i++) {
- push @buf, scalar <$fh>;
- }
- } else {
- @buf = <$fh>;
- }
- @buf;
+#
+# Gets the enscript(1) highlight mode corresponding to the given filename,
+# or undef if unsupported.
+#
+sub getEnscriptHL($)
+{
+ return undef unless $allow_enscript;
+ my ($filename) = @_;
+ while (my ($hl, $regex) = each %enscript_types) {
+ return $hl if ($filename =~ $regex);
+ }
+ return undef;
}
+
+#
+# Gets the MIME type for the given file name.
+#
+sub getMimeType($;$)
+{
+ my ($fullname, $binary) = @_;
+ $binary = ($keywordsubstitution && $keywordsubstitution =~ /b/)
+ unless defined($binary);
+
+ (my $suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/;
+
+ my $mimetype = $MTYPES{$suffix};
+ $mimetype ||= $MimeTypes->mimeTypeOf($fullname) if defined($MimeTypes);
+
+ if (!$mimetype && $suffix ne '*' && -f $mime_types && -r _) {
+ my $fh = do { local (*FH); };
+ if (open($fh, $mime_types)) {
+ my $re = sprintf('^\s*(\S+\/\S+)\s.+\b%s\b', quotemeta($suffix));
+ $re = qr/$re/;
+ while (my $line = <$fh>) {
+ if ($line =~ $re) {
+ $mimetype = $1;
+ $MTYPES{$suffix} = $mimetype;
+ last;
+ }
+ }
+ close($fh);
+ } else {
+ warn("Can't open MIME types file $mime_types for reading: $!");
+ }
+ }
+
+ $mimetype ||= $MTYPES{'*'};
+ $mimetype ||= $binary ? 'application/octet-stream' : 'text/plain';
+ return $mimetype;
+}
+
+
+###############################
+# read first lines like head(1)
+###############################
+sub head($;$)
+{
+ my ($fh, $linecount) = @_;
+ $linecount ||= 10;
+
+ my @buf;
+ if ($linecount > 0) {
+ for (my $i = 0; !eof($fh) && $i < $linecount; $i++) {
+ push @buf, scalar <$fh>;
+ }
+ } else {
+ @buf = <$fh>;
+ }
+ return @buf;
+}
+
+
###############################
# scan vim and Emacs directives
###############################
-sub scan_directives(@) {
- my $ts = undef;
+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;
+
+ open(STDOUT, "|-") and return;
- # child of child
- open(STDERR, '>/dev/null');
- exec($output_filter) or exit -1;
+ # 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); };
-
- # make sure the revisions are wellformed, for security
- # reasons ..
- if ($rev =~ /[^\w.]/) {
- fatal("404 Not Found",
- 'Malformed query "%s"',
- $ENV{QUERY_STRING});
- }
-
- ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;
- ($filename = $where) =~ s/^.*\///;
-
- # this seems to be necessary
- $| = 1;
- $| = 0; # Flush
-
- # Work around a mod_perl bug (?) in order to make open2() work.
- # Search for "untie STDIN" in mod_perl mailing list archives.
- my $old_stdin;
- if ($is_mod_perl && ($old_stdin = tied *STDIN)) {
- local $^W = undef;
- untie *STDIN;
- }
-
- # this annotate version is based on the
- # cvs annotate-demo Perl script by Cyclic Software
- # It was written by Cyclic Software, http://www.cyclic.com/, and is in
- # the public domain.
- # we could abandon the use of rlog, rcsdiff and co using
- # the cvsserver in a similiar way one day (..after rewrite)
- $pid = open2($reader, $writer, $CMD{cvs}, @annotate_options, 'server')
- or fatal("500 Internal Error",
- 'Fatal Error - unable to open cvs for annotation');
-
- # Re-tie STDIN if we fiddled around with it earlier, just to be sure.
- tie(*STDIN, ref($old_stdin), $old_stdin) if ($old_stdin && !tied(*STDIN));
-
- # OK, first send the request to the server. A simplified example is:
- # Root /home/kingdon/zwork/cvsroot
- # Argument foo/xx
- # Directory foo
- # /home/kingdon/zwork/cvsroot/foo
- # Directory .
- # /home/kingdon/zwork/cvsroot
- # annotate
- # although as you can see there are a few more details.
-
- print $writer "Root $cvsroot\n";
- print $writer
- "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n";
-
- # Don't worry about sending valid-requests, the server just needs to
- # support "annotate" and if it doesn't, there isn't anything to be done.
- print $writer "UseUnchanged\n";
- print $writer "Argument -r\n";
- print $writer "Argument $rev\n";
- print $writer "Argument $where\n";
-
- # The protocol requires us to fully fake a working directory (at
- # least to the point of including the directories down to the one
- # containing the file in question).
- # So if $where is "dir/sdir/file", then @dirs will be ("dir","sdir","file")
- my @dirs = split ('/', $where);
- my $path = "";
- foreach (@dirs) {
-
- if ($path eq "") {
-
- # In our example, $_ is "dir".
- $path = $_;
- } else {
- print $writer "Directory $path\n";
- print $writer "$cvsroot/$path\n";
-
- # In our example, $_ is "sdir" and $path becomes "dir/sdir"
- # And the next time, "file" and "dir/sdir/file" (which then gets
- # ignored, because we don't need to send Directory for the file).
- $path .= "/$_";
- }
- }
-
- # And the last "Directory" before "annotate" is the top level.
- print $writer "Directory .\n";
- print $writer "$cvsroot\n";
-
- print $writer "annotate\n";
-
- # OK, we've sent our command to the server. Thing to do is to
- # close the writer side and get all the responses. If "cvs server"
- # were nicer about buffering, then we could just leave it open, I think.
- close($writer) or die "cannot close: $!";
-
- http_header();
-
- navigateHeader($scriptwhere, $pathname, $filename, $rev, "annotate");
- print
- "
Annotation of $pathname$filename, Revision $rev
\n";
-
- # Ready to get the responses from the server.
- # For example:
- # E Annotations for foo/xx
- # E ***************
- # M 1.3 (kingdon 06-Sep-97): hello
- # ok
- my ($lineNr) = 0;
- my ($oldLrev, $oldLusr) = ("", "");
- my ($revprint, $usrprint);
-
- if ($annTable) {
- print "
\n";
- } else {
- print "
";
- }
-
- # prefetch several lines
- my @buf = head($reader);
-
- my %d = scan_directives(@buf);
-
- while (@buf || !eof($reader)) {
- $_ = @buf ? shift @buf : <$reader>;
-
- my @words = split;
-
- # Adding one is for the (single) space which follows $words[0].
- my $rest = substr($_, length($words[0]) + 1);
- if ($words[0] eq "E") {
- next;
- } elsif ($words[0] eq "M") {
- $lineNr++;
- (my $lrev = substr($_, 2, 13)) =~ y/ //d;
- (my $lusr = substr($_, 16, 9)) =~ y/ //d;
- my $line = substr($_, 36);
- my $isCurrentRev = ($rev eq $lrev);
-
- # we should parse the date here ..
- if ($lrev eq $oldLrev) {
- $revprint = sprintf('%-8s', '');
- } else {
- $revprint = sprintf('%-8s', $lrev);
- $revprint =~
- s`\S+`&link($&, "$scriptwhere$query#rev$&")`e
- ; # `
- $oldLusr = '';
- }
-
- if ($lusr eq $oldLusr) {
- $usrprint = '';
- } else {
- $usrprint = $lusr;
- }
- $oldLrev = $lrev;
- $oldLusr = $lusr;
-
- # Set bold for text-based browsers only - graphical
- # browsers show bold fonts a bit wider than regular fonts,
- # so it looks irregular.
- print "" if ($isCurrentRev && $is_textbased);
-
- printf "%s%s %-8s %4d:", $revprint,
- $isCurrentRev ? '!' : ' ', $usrprint, $lineNr;
- print spacedHtmlText($line, $d{'tabstop'});
-
- print "" if ($isCurrentRev && $is_textbased);
- } elsif ($words[0] eq "ok") {
-
- # We could complain about any text received after this, like the
- # CVS command line client. But for simplicity, we don't.
- } elsif ($words[0] eq "error") {
- fatal("500 Internal Error",
- 'Error occured during annotate: %s',
- $_);
- }
- }
-
- if ($annTable) {
- print "
";
- } else {
- print "";
- }
- html_footer();
-
- close($reader) or warn "cannot close: $!";
- wait;
+sub doAnnotate($$)
+{
+ my ($rev, $tag) = @_;
+ $rev = $tag || 'HEAD' if ($rev eq '.');
+ (my $pathname = $where) =~ s|((?<=/)Attic/)?[^/]*$||;
+ (my $filename = $where) =~ s|^.*/||;
+
+ # This annotate version is based on the cvs annotate-demo Perl script by
+ # Cyclic Software. It was written by Cyclic Software,
+ # http://www.cyclic.com/, and is in the public domain.
+ # We could abandon the use of rlog, rcsdiff and co using
+ # the cvs server in a similiar way one day (..after rewrite).
+
+ local (*CVS_IN, *CVS_OUT);
+ my $annotate_err;
+ my ($h, $err) =
+ startproc([ $CMD{cvs}, @annotate_options, 'server' ],
+ 'pipe', \*CVS_OUT,
+ '2>', \$annotate_err);
+ fatal('500 Internal Error',
+ 'Annotate failure (exit status %s), output:
%s
',
+ $? >> 8 || -1, $err)
+ unless $h;
+
+ # OK, first send the request to the server. A simplified example is:
+ # Root /home/kingdon/zwork/cvsroot
+ # Argument foo/xx
+ # Directory foo
+ # /home/kingdon/zwork/cvsroot/foo
+ # Directory .
+ # /home/kingdon/zwork/cvsroot
+ # annotate
+ # although as you can see there are a few more details.
+
+ print CVS_IN "Root $cvsroot\n";
+ print CVS_IN
+ "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n";
+
+ # Don't worry about sending valid-requests, the server just needs to
+ # support "annotate" and if it doesn't, there isn't anything to be done.
+ print CVS_IN "UseUnchanged\n";
+ print CVS_IN "Argument -r\n";
+ print CVS_IN "Argument $rev\n";
+ print CVS_IN "Argument $where\n";
+
+ # The protocol requires us to fully fake a working directory (at
+ # least to the point of including the directories down to the one
+ # containing the file in question).
+ # So if $where is "dir/sdir/file", then dirs will be ("dir","sdir","file")
+ my $path = '';
+ foreach my $dir (split('/', $where)) {
+
+ if ($path eq "") {
+ # In our example, $dir is "dir".
+ $path = $dir;
+ } else {
+ print CVS_IN "Directory $path\n";
+ print CVS_IN "$cvsroot/$path\n";
+
+ # In our example, $_ is "sdir" and $path becomes "dir/sdir"
+ # And the next time, "file" and "dir/sdir/file" (which then gets
+ # ignored, because we don't need to send Directory for the file).
+ $path .= "/$dir";
+ }
+ }
+ undef $path;
+
+ # And the last "Directory" before "annotate" is the top level.
+ print CVS_IN "Directory .\n";
+ print CVS_IN "$cvsroot\n";
+
+ print CVS_IN "annotate\n";
+
+ # OK, we've sent our command to the server. Thing to do is to
+ # close the writer side and get all the responses.
+ if (!close(CVS_IN)) {
+ $h->finish();
+ fatal('500 Internal Error',
+ 'Annotate failure (exit status %s): %s, output: ' .
+ '
Annotation of ',
+ htmlquote("$pathname$filename"), ", $revtype $rev
\n";
+
+ # Ready to get the responses from the server.
+ # For example:
+ # E Annotations for foo/xx
+ # E ***************
+ # M 1.3 (kingdon 06-Sep-97): hello
+ # ok
+ my ($lineNr) = 0;
+ my ($oldLrev, $oldLusr) = ("", "");
+ my ($revprint, $usrprint);
+
+ if ($annTable) {
+ print <
+EOF
+ } else {
+ print "
";
+ }
+
+ # prefetch several lines
+ my @buf = head(*CVS_OUT);
+
+ my %d = scan_directives(@buf);
+
+ while (@buf || !eof(*CVS_OUT)) {
+
+ $_ = @buf ? shift @buf : ;
+ my @words = split;
+
+ # Adding one is for the (single) space which follows $words[0].
+ my $rest = substr($_, length($words[0]) + 1);
+ if ($words[0] eq "E") {
+ next;
+ } elsif ($words[0] eq "M") {
+ $lineNr++;
+ (my $lrev = substr($_, 2, 13)) =~ y/ //d;
+ (my $lusr = substr($_, 16, 9)) =~ y/ //d;
+ my $line = substr($_, 36);
+ # TODO: this does not work for branch/tag revisions.
+ my $isCurrentRev = ($rev eq $lrev);
+
+ # we should parse the date here ..
+ if ($lrev eq $oldLrev) {
+ $revprint = sprintf('%-8s', '');
+ } else {
+ $revprint = sprintf('%-8s', $lrev);
+ $revprint =~ s|(\S+)|&link($1, uri_escape($filename)."$query#rev$1")|e;
+ $oldLusr = '';
+ }
+
+ $usrprint = ($lusr eq $oldLusr) ? '' : $lusr;
+ $oldLrev = $lrev;
+ $oldLusr = $lusr;
+
+ print $is_textbased ? '' : ''
+ if $isCurrentRev;
+
+ $usrprint = sprintf('%-8s', $usrprint);
+ printf '%s%s %s %4d:', $revprint, $isCurrentRev ? '!' : ' ',
+ htmlquote($usrprint), $lineNr;
+ print spacedHtmlText($line, $d{tabstop});
+
+ print $is_textbased ? '' : '' if $isCurrentRev;
+
+ } elsif ($words[0] eq "ok") {
+ # We could complain about any text received after this, like the
+ # CVS command line client. But for simplicity, we don't.
+
+ } elsif ($words[0] eq "error") {
+ fatal("500 Internal Error",
+ 'Error occured during annotate: %s', $_);
+ }
+ }
+ $h->finish();
+
+ if ($annTable) {
+ print "";
+ } else {
+ print "
";
+ }
+ html_footer();
}
###############################
# make Checkout
###############################
-sub doCheckout($$) {
- my ($fullname, $rev) = @_;
- my ($mimetype, $revopt);
- my $fh = do { local (*FH); };
-
- if ($rev eq 'HEAD' || $rev eq '.') {
- $rev = undef;
- }
-
- # make sure the revisions a wellformed, for security
- # reasons ..
- if (defined($rev) && $rev =~ /[^\w.]/) {
- fatal("404 Not Found",
- 'Malformed query "%s"',
- $ENV{QUERY_STRING});
- }
-
- # get mimetype
- if (defined($input{"content-type"})
- && ($input{"content-type"} =~ /\S\/\S/))
- {
- $mimetype = $input{"content-type"}
- } else {
- $mimetype = &getMimeTypeFromSuffix($fullname);
- }
-
- if (defined($rev)) {
- $revopt = "-r$rev";
- if ($use_moddate) {
- readLog($fullname, $rev);
- $moddate = $date{$rev};
- }
- } else {
- $revopt = "-rHEAD";
-
- if ($use_moddate) {
- readLog($fullname);
- $moddate = $date{$symrev{HEAD}};
- }
- }
-
- ### just for the record:
- ### 'cvs co' seems to have a bug regarding single checkout of
- ### directories/files having spaces in it;
- ### this is an issue that should be resolved on cvs's side
- #
- # Safely for a child process to read from.
- if (!open($fh, "-|")) { # child
- # chdir to $tmpdir before to avoid non-readable cgi-bin directories
- chdir($tmpdir);
- open(STDERR, ">&STDOUT"); # Redirect stderr to stdout
-
- # work around a bug of cvs -p; expand symlinks
- use Cwd 'abs_path';
- exec($CMD{cvs}, @cvs_options,
- '-d', abs_path($cvsroot),
- 'co', '-p',
- $revopt, $where) or exit -1;
- }
-
- if (eof($fh)) {
- fatal("404 Not Found",
- '%s is not (any longer) pertinent',
- $where);
- }
-
- #===================================================================
- #Checking out squid/src/ftp.c
- #RCS: /usr/src/CVS/squid/src/ftp.c,v
- #VERS: 1.1.1.28.6.2
- #***************
-
- # Parse CVS header
- my ($revision, $filename, $cvsheader);
- $filename = "";
- while (<$fh>) {
- last if (/^\*\*\*\*/);
- $revision = $1 if (/^VERS: (.*)$/);
-
- if (/^Checking out (.*)$/) {
- $filename = $1;
- $filename =~ s/^\.\/*//;
- }
- $cvsheader .= $_;
- }
-
- if ($filename ne $where) {
- fatal("500 Internal Error",
- 'Unexpected output from cvs co: %s',
- $cvsheader);
- }
- $| = 1;
-
- if ($mimetype eq "text/x-cvsweb-markup") {
- &cvswebMarkup($fh, $fullname, $revision);
- } else {
- http_header($mimetype);
- print <$fh>;
- }
- close($fh);
-}
-
-sub cvswebMarkup($$$) {
- my ($filehandle, $fullname, $revision) = @_;
- my ($pathname, $filename);
-
- ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;
- ($filename = $where) =~ s/^.*\///;
- my ($fileurl) = urlencode($filename);
-
- http_header();
-
- navigateHeader($scriptwhere, $pathname, $filename, $revision, "view");
- print "";
- print "