pserver/cvsweb.cgi

   1 #!/usr/local/bin/perl
   2 #
   3 # cvsweb - a CGI interface to CVS trees.
   4 #
   5 # Written in their spare time by
   6 #             Bill Fenner      <fenner@FreeBSD.org>   (original work)
   7 # extended by Henner Zeller    <zeller@think.de>,
   8 #             Henrik Nordström <hno@hem.passagen.se>
   9 #             Ken Coar         <coar@Apache.Org>
  10 #             Dick Balaska     <dick@buckosoft.com>
  11 #             Jens-Uwe Mager   <jum@helios.de>
  12 #
  13 # Based on:
  14 # * Bill Fenners cvsweb.cgi revision 1.28 available from:
  15 #   http://www.FreeBSD.org/cgi/cvsweb.cgi/www/en/cgi/cvsweb.cgi
  16 #
  17 # Copyright (c) 1996-1998 Bill Fenner
  18 #           (c) 1998-1999 Henner Zeller
  19 #           (c) 1999      Henrik Nordström
  20 # All rights reserved.
  21 #
  22 # Redistribution and use in source and binary forms, with or without
  23 # modification, are permitted provided that the following conditions
  24 # are met:
  25 # 1. Redistributions of source code must retain the above copyright
  26 #    notice, this list of conditions and the following disclaimer.
  27 # 2. Redistributions in binary form must reproduce the above copyright
  28 #    notice, this list of conditions and the following disclaimer in the
  29 #    documentation and/or other materials provided with the distribution.
  30 #
  31 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
  32 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  33 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  34 # ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
  35 # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  36 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  37 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  38 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  39 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  40 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  41 # SUCH DAMAGE.
  42 #
  43 # $Id: cvsweb.cgi,v 1.112 2001/07/24 13:03:16 hzeller Exp $
  44 #
  45 ###
  46 require './pserver-lib.pl';
  47 $access{'cvsweb'} || &error($text{'cvsweb_ecannot'});
  48
  49 use vars qw (
  50     $config $allow_version_select $verbose
  51     %CVSROOT %CVSROOTdescr %MIRRORS %DEFAULTVALUE %ICONS %MTYPES
  52     %alltags @tabcolors %fileinfo %tags @branchnames %nameprinted
  53     %symrev %revsym @allrevisions %date %author @revdisplayorder
  54     @revisions %state %difflines %log %branchpoint @revorder
  55     $checkoutMagic $doCheckout $scriptname $scriptwhere
  56     $where $Browser $nofilelinks $maycompress @stickyvars
  57     %input $query $barequery $sortby $bydate $byrev $byauthor
  58     $bylog $byfile $hr_default $logsort $cvstree $cvsroot
  59     $mimetype $defaultTextPlain $defaultViewable $allow_compress
  60     $GZIPBIN $backicon $diricon $fileicon $fullname $newname
  61     $cvstreedefault $body_tag $logo $defaulttitle $address
  62     $backcolor $long_intro $short_instruction $shortLogLen
  63     $show_author $dirtable $tablepadding $columnHeaderColorDefault
  64     $columnHeaderColorSorted $hr_breakable $hr_funout $hr_ignwhite
  65     $hr_ignkeysubst $diffcolorHeading $diffcolorEmpty $diffcolorRemove
  66     $diffcolorChange $diffcolorAdd $diffcolorDarkChange $difffontface
  67     $difffontsize $inputTextSize $mime_types $allow_annotate
  68     $allow_markup $use_java_script $open_extern_window
  69     $extern_window_width $extern_window_height $edit_option_form
  70     $checkout_magic $show_subdir_lastmod $show_log_in_markup $v
  71     $navigationHeaderColor $tableBorderColor $markupLogColor
  72     $tabstop $state $annTable $sel $curbranch @HideModules @DissallowRead
  73     $module $use_descriptions %descriptions @mytz $dwhere $moddate
  74     $use_moddate $has_zlib $gzip_open
  75 );
  76
  77 ##### prototype declarations ########
  78 sub printDiffSelect($);
  79 sub findLastModifiedSubdirs(@);
  80 sub htmlify($);
  81 sub spacedHtmlText($);
  82 sub link($$);
  83 sub revcmp($$);
  84 sub fatal($$);
  85 sub credirect($);
  86 sub safeglob($);
  87 sub getMimeTypeFromSuffix($);
  88 sub doAnnotate ($$);
  89 sub doCheckout($$);
  90 sub cvswebMarkup($$$);
  91 sub viewable($);
  92 sub doDiff($$$$$$);
  93 sub getDirLogs($$@);
  94 sub readLog($;$);
  95 sub printLog($;$);
  96 sub doLog($);
  97 sub flush_diff_rows ($$$$);
  98 sub human_readable_diff($);
  99 sub navigateHeader ($$$$$);
 100 sub plural_write ($$);
 101 sub readableTime ($$);
 102 sub clickablePath($$);
 103 sub chooseCVSRoot();
 104 sub chooseMirror();
 105 sub fileSortCmp();
 106 sub download_url($$$);
 107 sub download_link($$$$);
 108 sub toggleQuery($$);
 109 sub urlencode($);
 110 sub http_header(;$);
 111 sub html_header($);
 112 sub html_footer();
 113 sub link_tags($);
 114 sub forbidden_module($);
 115 sub forbidden_file($);
 116 sub checkForbidden($@);
 117 sub gzipclose();
 118 sub MAGIC1();
 119 sub MAGIC2();
 120 sub OSCODE();
 121
 122 ##### Start of Configuration Area ########
 123 # == EDIT this ==
 124 # User configuration is stored in
 125 $config = "./cvsweb.conf";
 126
 127 # == Configuration defaults ==
 128 # Defaults for configuration variables that shouldn't need
 129 # to be configured..
 130 $allow_version_select = 1;
 131
 132 ##### End of Configuration Area   ########
 133
 134 ######## Configuration variables #########
 135 # These are defined to allow checking with perl -cw
 136 %CVSROOT = %MIRRORS = %DEFAULTVALUE = %ICONS = %MTYPES =
 137 %tags = %alltags = @tabcolors = %fileinfo = ();
 138 $cvstreedefault = $body_tag = $logo = $defaulttitle = $address =
 139 $backcolor = $long_intro = $short_instruction = $shortLogLen =
 140 $show_author = $dirtable = $tablepadding = $columnHeaderColorDefault =
 141 $columnHeaderColorSorted = $hr_breakable = $hr_funout = $hr_ignwhite =
 142 $hr_ignkeysubst = $diffcolorHeading = $diffcolorEmpty = $diffcolorRemove =
 143 $diffcolorChange = $diffcolorAdd = $diffcolorDarkChange = $difffontface =
 144 $difffontsize = $inputTextSize = $mime_types = $allow_annotate =
 145 $allow_markup = $use_java_script = $open_extern_window =
 146 $extern_window_width = $extern_window_height = $edit_option_form =
 147 $checkout_magic = $show_subdir_lastmod = $show_log_in_markup = $v =
 148 $navigationHeaderColor = $tableBorderColor = $markupLogColor =
 149 $tabstop = $use_moddate = $moddate = $gzip_open = undef;
 150
 151 ##### End of configuration variables #####
 152
 153 use Time::Local;
 154 use IPC::Open2;
 155
 156 # Check if the zlib C library interface is installed, and if yes
 157 # we can avoid using the extra gzip process.
 158 eval {
 159         require Compress::Zlib;
 160 };
 161 $has_zlib = !$@;
 162
 163 $verbose = $v;
 164 $checkoutMagic = "~checkout~";
 165 $where = defined($ENV{'PATH_INFO'}) ? $ENV{'PATH_INFO'} : "";
 166 $doCheckout = ($where =~ /^\/$checkoutMagic/);
 167 $where =~ s|^/($checkoutMagic)?||;
 168 $where =~ s|/+$||;
 169 $where =~ s|^/+||;
 170 ($scriptname = $ENV{'SCRIPT_NAME'}) =~ s|^/?|/|;
 171 $scriptname =~ s|/+$||;
 172 if ($where) {
 173     $scriptwhere = $scriptname . '/' . urlencode($where);
 174 }
 175 else {
 176     $scriptwhere = $scriptname;
 177 }
 178 $scriptwhere =~ s|/+$||;
 179
 180 # in lynx, it it very annoying to have two links
 181 # per file, so disable the link at the icon
 182 # in this case:
 183 $Browser = $ENV{'HTTP_USER_AGENT'};
 184 $nofilelinks = ($Browser =~ m'^Lynx/');
 185
 186 # newer browsers accept gzip content encoding
 187 # and state this in a header
 188 # (netscape did always but didn't state it)
 189 # It has been reported that these
 190 #  braindamaged MS-Internet Exploders claim that they
 191 # accept gzip .. but don't in fact and
 192 # display garbage then :-/
 193 # Turn off gzip if running under mod_perl and no zlib is available,
 194 # piping does not work as expected inside the server.
 195 $maycompress = (((defined($ENV{'HTTP_ACCEPT_ENCODING'})
 196                  && $ENV{'HTTP_ACCEPT_ENCODING'} =~ m|gzip|)
 197                 || $Browser =~ m%^Mozilla/3%)
 198                && ($Browser !~ m/MSIE/)
 199                && !(defined($ENV{'MOD_PERL'}) && !$has_zlib));
 200 $maycompress = 0;
 201
 202 # put here the variables we need in order
 203 # to hold our state - they will be added (with
 204 # their current value) to any link/query string
 205 # you construct
 206 @stickyvars = qw(cvsroot hideattic sortby logsort f only_with_tag);
 207
 208 if (-f $config) {
 209     do "$config";
 210 }
 211 else {
 212    &fatal("500 Internal Error",
 213           'Configuration not found.  Set the variable <code>$config</code> '
 214           . 'in cvsweb.cgi, or the environment variable '
 215           . '<code>CVSWEB_CONFIG</code>, to your <b>cvsweb.conf</b> '
 216           . 'configuration file first.');
 217 }
 218
 219 undef %input;
 220 if ($query = $ENV{'QUERY_STRING'}) {
 221     foreach (split(/&/, $query)) {
 222         y/+/ /;
 223         s/%(..)/sprintf("%c", hex($1))/ge;      # unquote %-quoted
 224         if (/(\S+)=(.*)/) {
 225             $input{$1} = $2 if ($2 ne "");
 226         }
 227         else {
 228             $input{$_}++;
 229         }
 230     }
 231 }
 232
 233 # For backwards compability, set only_with_tag to only_on_branch if set.
 234 $input{only_with_tag} = $input{only_on_branch}
 235     if (defined($input{only_on_branch}));
 236
 237 foreach (keys %DEFAULTVALUE)
 238 {
 239     # replace not given parameters with the default parameters
 240     if (!defined($input{$_}) || $input{$_} eq "") {
 241         # Empty Checkboxes in forms return -- nothing. So we define a helper
 242         # variable in these forms (copt) which indicates that we just set
 243         # parameters with a checkbox
 244         if (!defined($input{"copt"})) {
 245             # 'copt' isn't defined --> empty input is not the result
 246             # of empty input checkbox --> set default
 247             $input{$_} = $DEFAULTVALUE{$_} if (defined($DEFAULTVALUE{$_}));
 248         }
 249         else {
 250             # 'copt' is defined -> the result of empty input checkbox
 251             # -> set to zero (disable) if default is a boolean (0|1).
 252             $input{$_} = 0
 253                 if (defined($DEFAULTVALUE{$_})
 254                     && ($DEFAULTVALUE{$_} eq "0" || $DEFAULTVALUE{$_} eq "1"));
 255         }
 256     }
 257 }
 258
 259 $barequery = "";
 260 foreach (@stickyvars) {
 261     # construct a query string with the sticky non default parameters set
 262         if (defined($input{$_}) && ($input{$_} ne "") &&
 263             (!defined($DEFAULTVALUE{$_}) || $input{$_} ne $DEFAULTVALUE{$_})) {
 264         if ($barequery) {
 265             $barequery = $barequery . "&amp;";
 266         }
 267         my $thisval = urlencode($_) . "=" . urlencode($input{$_});
 268         $barequery .= $thisval;
 269     }
 270 }
 271 # is there any query ?
 272 if ($barequery) {
 273     $query = "?$barequery";
 274     $barequery = "&amp;" . $barequery;
 275 }
 276 else {
 277     $query = "";
 278 }
 279
 280 # get actual parameters
 281 $sortby = $input{"sortby"};
 282 $bydate = 0;
 283 $byrev = 0;
 284 $byauthor = 0;
 285 $bylog = 0;
 286 $byfile = 0;
 287 if ($sortby eq "date") {
 288     $bydate = 1;
 289 }
 290 elsif ($sortby eq "rev") {
 291     $byrev = 1;
 292 }
 293 elsif ($sortby eq "author") {
 294     $byauthor = 1;
 295 }
 296 elsif ($sortby eq "log") {
 297     $bylog = 1;
 298 }
 299 else {
 300     $byfile = 1;
 301 }
 302
 303 $hr_default = $input{'f'} eq 'h';
 304
 305 $logsort = $input{"logsort"};
 306
 307
 308 ## Default CVS-Tree
 309 if (!defined($CVSROOT{$cvstreedefault})) {
 310    &fatal("500 Internal Error",
 311           "<code>\$cvstreedefault</code> points to a repository ($cvstreedefault)"
 312           . "not defined in <code>%CVSROOT</code> "
 313           . "(edit your configuration file $config)");
 314 }
 315 $cvstree = $cvstreedefault;
 316 $cvsroot = $CVSROOT{"$cvstree"};
 317
 318 # alternate CVS-Tree, configured in cvsweb.conf
 319 if ($input{'cvsroot'}) {
 320     if ($CVSROOT{$input{'cvsroot'}}) {
 321         $cvstree = $input{'cvsroot'};
 322         $cvsroot = $CVSROOT{"$cvstree"};
 323     }
 324 }
 325
 326 # create icons out of description
 327 foreach my $k (keys %ICONS) {
 328     no strict 'refs';
 329     my ($itxt,$ipath,$iwidth,$iheight) = @{$ICONS{$k}};
 330     if ($ipath) {
 331         $ {"${k}icon"} = "<IMG SRC=\"$ipath\" ALT=\"$itxt\" BORDER=\"0\" WIDTH=\"$iwidth\" HEIGHT=\"$iheight\">";
 332     }
 333     else {
 334         $ {"${k}icon"} = $itxt;
 335     }
 336 }
 337
 338 # Do some special configuration for cvstrees
 339 do "$config-$cvstree" if (-f "$config-$cvstree");
 340
 341 $fullname = $cvsroot . '/' . $where;
 342 $mimetype = &getMimeTypeFromSuffix ($fullname);
 343 $defaultTextPlain = ($mimetype eq "text/plain");
 344 $defaultViewable = $allow_markup && viewable($mimetype);
 345
 346 # search for GZIP if compression allowed
 347 # We've to find out if the GZIP-binary exists .. otherwise
 348 # ge get an Internal Server Error if we try to pipe the
 349 # output through the nonexistent gzip ..
 350 # any more elegant ways to prevent this are welcome!
 351 if ($allow_compress && $maycompress && !$has_zlib) {
 352     foreach (split(/:/, $ENV{PATH})) {
 353         if (-x "$_/gzip") {
 354             $GZIPBIN = "$_/gzip";
 355             last;
 356         }
 357     }
 358 }
 359
 360 if (-d $fullname) {
 361     #
 362     # ensure, that directories always end with (exactly) one '/'
 363     # to allow relative URL's. If they're not, make a credirect.
 364     ##
 365     my $pathinfo = defined($ENV{'PATH_INFO'}) ? $ENV{'PATH_INFO'} : "";
 366     if (!($pathinfo =~ m|/$|) || ($pathinfo =~ m |/{2,}$|)) {
 367         credirect ($scriptwhere . '/' . $query);
 368     }
 369     else {
 370         $where .= '/';
 371         $scriptwhere .= '/';
 372     }
 373 }
 374
 375 if (!-d $cvsroot) {
 376     &fatal("500 Internal Error",'$CVSROOT not found!<P>The server on which the CVS tree lives is probably down.  Please try again in a few minutes.');
 377 }
 378
 379 #
 380 # See if the module is in our forbidden list.
 381 #
 382 $where =~ m:([^/]*):;
 383 $module = $1;
 384 if ($module && &forbidden_module($module)) {
 385     &fatal("403 Forbidden", "Access to $where forbidden.");
 386 }
 387 ##############################
 388 # View a directory
 389 ###############################
 390 elsif (-d $fullname) {
 391         my $dh = do {local(*DH);};
 392         opendir($dh, $fullname) || &fatal("404 Not Found","$where: $!");
 393         my @dir = readdir($dh);
 394         closedir($dh);
 395         my @subLevelFiles = findLastModifiedSubdirs(@dir)
 396             if ($show_subdir_lastmod);
 397         getDirLogs($cvsroot,$where,@subLevelFiles);
 398
 399         if ($where eq '/') {
 400             html_header("$defaulttitle");
 401             print $long_intro;
 402         }
 403         else {
 404             html_header("$where");
 405             print $short_instruction;
 406         }
 407
 408         my $descriptions;
 409         if (($use_descriptions) && open (DESC, "<$cvsroot/CVSROOT/descriptions")) {
 410             while (<DESC>) {
 411                 chomp;
 412                 my ($dir,$description) = /(\S+)\s+(.*)/;
 413                 $descriptions{$dir} = $description;
 414             }
 415         }
 416
 417         print "<P><a name=\"dirlist\"></a>\n";
 418         # give direct access to dirs
 419         if ($where eq '/') {
 420             chooseMirror();
 421             chooseCVSRoot();
 422         }
 423         else {
 424             print "<p>Current directory: <b>", &clickablePath($where,0), "</b>\n";
 425
 426             print "<P>Current tag: <B>", $input{only_with_tag}, "</b>\n" if
 427                 $input{only_with_tag};
 428
 429         }
 430
 431
 432         print "<HR NOSHADE>\n";
 433         # Using <MENU> in this manner violates the HTML2.0 spec but
 434         # provides the results that I want in most browsers.  Another
 435         # case of layout spooging up HTML.
 436
 437         my $infocols = 0;
 438         if ($dirtable) {
 439             if (defined($tableBorderColor)) {
 440                 # Can't this be done by defining the border for the inner table?
 441                 print "<table border=0 cellpadding=0 width=\"100%\"><tr><td bgcolor=\"$tableBorderColor\">";
 442             }
 443             print "<table  width=\"100%\" border=0 cellspacing=1 cellpadding=$tablepadding>\n";
 444             $infocols++;
 445             print "<tr><th align=left bgcolor=\"" . (($byfile) ?
 446                                                    $columnHeaderColorSorted :
 447                                                    $columnHeaderColorDefault) . "\">";
 448             print "<a href=\"./" . &toggleQuery("sortby","file") .
 449                 "#dirlist\">" if (!$byfile);
 450             print "File";
 451             print "</a>" if (!$byfile);
 452             print "</th>";
 453             # do not display the other column-headers, if we do not have any files
 454             # with revision information:
 455             if (scalar(%fileinfo)) {
 456                 $infocols++;
 457                 print "<th align=left bgcolor=\"" . (($byrev) ?
 458                                                    $columnHeaderColorSorted :
 459                                                    $columnHeaderColorDefault) . "\">";
 460                 print "<a href=\"./" . &toggleQuery ("sortby","rev") .
 461                     "#dirlist\">" if (!$byrev);
 462                 print "Rev.";
 463                 print "</a>" if (!$byrev);
 464                 print "</th>";
 465                 $infocols++;
 466                 print "<th align=left bgcolor=\"" . (($bydate) ?
 467                                                    $columnHeaderColorSorted :
 468                                                    $columnHeaderColorDefault) . "\">";
 469                 print "<a href=\"./" . &toggleQuery ("sortby","date") .
 470                     "#dirlist\">" if (!$bydate);
 471                 print "Age";
 472                 print "</a>" if (!$bydate);
 473                 print "</th>";
 474                 if ($show_author) {
 475                     $infocols++;
 476                     print "<th align=left bgcolor=\"" . (($byauthor) ?
 477                                                    $columnHeaderColorSorted :
 478                                                    $columnHeaderColorDefault) . "\">";
 479                     print "<a href=\"./" . &toggleQuery ("sortby","author") .
 480                             "#dirlist\">" if (!$byauthor);
 481                     print "Author";
 482                     print "</a>" if (!$byauthor);
 483                     print "</th>";
 484                 }
 485                 $infocols++;
 486                 print "<th align=left bgcolor=\"" . (($bylog) ?
 487                                                $columnHeaderColorSorted :
 488                                                $columnHeaderColorDefault) . "\">";
 489                 print "<a href=\"./", toggleQuery("sortby","log"), "#dirlist\">" if (!$bylog);
 490                 print "Last log entry";
 491                 print "</a>" if (!$bylog);
 492                 print "</th>";
 493             }
 494             elsif ($use_descriptions) {
 495                 print "<th align=left bgcolor=\"". $columnHeaderColorDefault . "\">";
 496                 print "Description";
 497                 $infocols++;
 498             }
 499             print "</tr>\n";
 500         }
 501         else {
 502             print "<menu>\n";
 503         }
 504         my $dirrow = 0;
 505
 506         my $i;
 507         lookingforattic:
 508         for ($i = 0; $i <= $#dir; $i++) {
 509                 if ($dir[$i] eq "Attic") {
 510                     last lookingforattic;
 511                 }
 512         }
 513         if (!$input{'hideattic'} && ($i <= $#dir) &&
 514             opendir($dh, $fullname . "/Attic")) {
 515             splice(@dir, $i, 1,
 516                         grep((s|^|Attic/|,!m|/\.|), readdir($dh)));
 517             closedir($dh);
 518         }
 519
 520         my $hideAtticToggleLink = "<a href=\"./" .
 521                 &toggleQuery ("hideattic") .
 522                 "#dirlist\">[Hide]</a>" if (!$input{'hideattic'});
 523
 524         # Sort without the Attic/ pathname.
 525         # place directories first
 526
 527         my $attic;
 528         my $url;
 529         my $fileurl;
 530         my $filesexists;
 531         my $filesfound;
 532
 533         foreach (sort { &fileSortCmp } @dir) {
 534             if ($_ eq '.') {
 535                 next;
 536             }
 537             # ignore CVS lock and stale NFS files
 538             next if (/^#cvs\.|^,|^\.nfs/);
 539
 540             # Check whether to show the CVSROOT path
 541             next if ($input{'hidecvsroot'} && ($_ eq 'CVSROOT'));
 542
 543             # Check whether the module is in the restricted list
 544             next if ($_ && &forbidden_module($_));
 545
 546             # Ignore non-readable files
 547             next if ($input{'hidenonreadable'} && !(-r "$fullname/$_"));
 548
 549             if (s|^Attic/||) {
 550                 $attic  = " (in the Attic)&nbsp;" . $hideAtticToggleLink;
 551             }
 552             else {
 553                 $attic = "";
 554             }
 555
 556             if ($_ eq '..' || -d "$fullname/$_") {
 557                 next if ($_ eq '..' && $where eq '/');
 558                 my ($rev,$date,$log,$author,$filename);
 559                 ($rev,$date,$log,$author,$filename) = @{$fileinfo{$_}}
 560                     if (defined($fileinfo{$_}));
 561                 print "<tr bgcolor=\"" . @tabcolors[$dirrow%2] . "\"><td>" if ($dirtable);
 562                 if ($_ eq '..') {
 563                     $url = "../" . $query;
 564                     if ($nofilelinks) {
 565                         print $backicon;
 566                     }
 567                     else {
 568                         print &link($backicon,$url);
 569                     }
 570                     print " ", &link("Previous Directory",$url);
 571                 }
 572                 else {
 573                     $url = urlencode($_) . '/' . $query;
 574                     print "<A NAME=\"$_\"></A>";
 575                     if ($nofilelinks) {
 576                         print $diricon;
 577                     }
 578                     else {
 579                         print &link($diricon,$url);
 580                     }
 581                     print " ", &link($_ . "/", $url), $attic;
 582                     if ($_ eq "Attic") {
 583                         print "&nbsp; <a href=\"./" .
 584                             &toggleQuery ("hideattic") .
 585                                 "#dirlist\">[Don't hide]</a>";
 586                     }
 587                 }
 588                 # Show last change in dir
 589                 if ($filename) {
 590                     print "</td><td>&nbsp;</td><td>&nbsp;" if ($dirtable);
 591                     if ($date) {
 592                         print " <i>" . readableTime(time() - $date,0) . "</i>";
 593                     }
 594                     if ($show_author) {
 595                         print "</td><td>&nbsp;" if ($dirtable);
 596                         print $author;
 597                     }
 598                     print "</td><td>&nbsp;" if ($dirtable);
 599                     $filename =~ s%^[^/]+/%%;
 600                     print "$filename/$rev";
 601                     print "<BR>" if ($dirtable);
 602                     if ($log) {
 603                         print "&nbsp;<font size=-1>"
 604                             . &htmlify(substr($log,0,$shortLogLen));
 605                         if (length $log > 80) {
 606                             print "...";
 607                         }
 608                         print "</font>";
 609                     }
 610                 }
 611                 else {
 612                     my ($dwhere) = ($where ne "/" ? $where : "") . $_;
 613                     if ($use_descriptions && defined $descriptions{$dwhere}) {
 614                         print "<TD COLSPAN=" . ($infocols-1) . ">&nbsp;" if $dirtable;
 615                         print $descriptions{$dwhere};
 616                     } elsif ($dirtable && $infocols > 1) {
 617                         # close the row with the appropriate number of
 618                         # columns, so that the vertical seperators are visible
 619                         my($cols) = $infocols;
 620                         while ($cols > 1) {
 621                             print "</td><td>&nbsp;";
 622                             $cols--;
 623                         }
 624                     }
 625                 }
 626                 if ($dirtable) {
 627                     print "</td></tr>\n";
 628                 }
 629                 else {
 630                     print "<br>\n";
 631                 }
 632                 $dirrow++;
 633             }
 634             elsif (s/,v$//) {
 635                 $fileurl = ($attic ? "Attic/" : "") . urlencode($_);
 636                 $url = $fileurl . $query;
 637                 my $rev = '';
 638                 my $date = '';
 639                 my $log = '';
 640                 my $author = '';
 641                 $filesexists++;
 642                 next if (!defined($fileinfo{$_}));
 643                 ($rev,$date,$log,$author) = @{$fileinfo{$_}};
 644                 $filesfound++;
 645                 print "<tr bgcolor=\"" . @tabcolors[$dirrow%2] . "\"><td>" if ($dirtable);
 646                 print "<A NAME=\"$_\"></A>";
 647                 if ($nofilelinks) {
 648                     print $fileicon;
 649                 }
 650                 else {
 651                     print &link($fileicon,$url);
 652                 }
 653                 print " ", &link($_, $url), $attic;
 654                 print "</td><td>&nbsp;" if ($dirtable);
 655                 download_link($fileurl,
 656                         $rev, $rev,
 657                         $defaultViewable ? "text/x-cvsweb-markup" : undef);
 658                 print "</td><td>&nbsp;" if ($dirtable);
 659                 if ($date) {
 660                     print " <i>" . readableTime(time() - $date,0) . "</i>";
 661                 }
 662                 if ($show_author) {
 663                     print "</td><td>&nbsp;" if ($dirtable);
 664                     print $author;
 665                 }
 666                 print "</td><td>&nbsp;" if ($dirtable);
 667                 if ($log) {
 668                     print " <font size=-1>" . &htmlify(substr($log,0,$shortLogLen));
 669                     if (length $log > 80) {
 670                         print "...";
 671                     }
 672                     print "</font>";
 673                 }
 674                 print "</td>" if ($dirtable);
 675                 print (($dirtable) ? "</tr>" : "<br>");
 676                 $dirrow++;
 677             }
 678             print "\n";
 679         }
 680         if ($dirtable && defined($tableBorderColor)) {
 681             print "</td></tr></table>";
 682         }
 683         print "". ($dirtable == 1) ? "</table>" : "</menu>" . "\n";
 684
 685         if ($filesexists && !$filesfound) {
 686             print "<P><B>NOTE:</B> There are $filesexists files, but none matches the current tag ($input{only_with_tag})\n";
 687         }
 688         if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}})) {
 689             %tags = %alltags
 690         }
 691         if (scalar %tags
 692             || $input{only_with_tag}
 693             || $edit_option_form
 694             || defined($input{"options"})) {
 695             print "<hr size=1 NOSHADE>";
 696         }
 697
 698         if (scalar %tags || $input{only_with_tag}) {
 699             print "<FORM METHOD=\"GET\" ACTION=\"./\">\n";
 700             foreach my $var (@stickyvars) {
 701                 print "<INPUT TYPE=HIDDEN NAME=\"$var\" VALUE=\"$input{$var}\">\n"
 702                     if (defined($input{$var})
 703                         && (!defined($DEFAULTVALUE{$var})
 704                             || $input{$var} ne $DEFAULTVALUE{$var})
 705                         && $input{$var} ne ""
 706                         && $var ne "only_with_tag");
 707             }
 708             print "Show only files with tag:\n";
 709             print "<SELECT NAME=only_with_tag";
 710             print " onchange=\"submit()\"" if ($use_java_script);
 711             print ">";
 712             print "<OPTION VALUE=\"\">All tags / default branch\n";
 713             foreach my $tag (reverse sort { lc $a cmp lc $b } keys %tags) {
 714                 print "<OPTION",defined($input{only_with_tag}) &&
 715                        $input{only_with_tag} eq $tag ? " SELECTED":"",
 716                        ">$tag\n";
 717             }
 718             print "</SELECT>\n";
 719             print "<INPUT TYPE=SUBMIT VALUE=\"Go\">\n";
 720             print "</FORM>\n";
 721         }
 722         my $formwhere = $scriptwhere;
 723         $formwhere =~ s|Attic/?$|| if ($input{'hideattic'});
 724
 725         if ($edit_option_form || defined($input{"options"})) {
 726             print "<FORM METHOD=\"GET\" ACTION=\"${formwhere}\">\n";
 727             print "<INPUT TYPE=HIDDEN NAME=\"copt\" VALUE=\"1\">\n";
 728             if ($cvstree ne $cvstreedefault) {
 729                 print "<INPUT TYPE=HIDDEN NAME=\"cvsroot\" VALUE=\"$cvstree\">\n";
 730             }
 731             print "<center><table cellpadding=0 cellspacing=0>";
 732             print "<tr bgcolor=\"$columnHeaderColorDefault\"><th colspan=2>Preferences</th></tr>";
 733             print "<tr><td>Sort files by <SELECT name=\"sortby\">";
 734             print "<OPTION VALUE=\"\">File";
 735             print "<OPTION",$bydate ? " SELECTED" : ""," VALUE=date>Age";
 736             print "<OPTION",$byauthor ? " SELECTED" : ""," VALUE=author>Author"
 737                 if ($show_author);
 738             print "<OPTION",$byrev ? " SELECTED" : ""," VALUE=rev>Revision";
 739             print "<OPTION",$bylog ? " SELECTED" : ""," VALUE=log>Log message";
 740             print "</SELECT></td>";
 741             print "<td>revisions by: \n";
 742             print "<SELECT NAME=logsort>\n";
 743             print "<OPTION VALUE=cvs",$logsort eq "cvs" ? " SELECTED" : "", ">Not sorted";
 744             print "<OPTION VALUE=date",$logsort eq "date" ? " SELECTED" : "", ">Commit date";
 745             print "<OPTION VALUE=rev",$logsort eq "rev" ? " SELECTED" : "", ">Revision";
 746             print "</SELECT></td></tr>";
 747             print "<tr><td>Diff format: ";
 748             printDiffSelect(0);
 749             print "</td>";
 750             print "<td>Show Attic files: ";
 751             print "<INPUT NAME=hideattic TYPE=CHECKBOX", $input{'hideattic'}?" CHECKED":"",
 752             "></td></tr>\n";
 753             print "<tr><td align=center colspan=2><input type=submit value=\"Change Options\">";
 754             print "</td></tr></table></center></FORM>\n";
 755         }
 756         print &html_footer;
 757         print "</BODY></HTML>\n";
 758     }
 759
 760 ###############################
 761 # View Files
 762 ###############################
 763     elsif (-f $fullname . ',v') {
 764         if (defined($input{'rev'}) || $doCheckout) {
 765             &doCheckout($fullname, $input{'rev'});
 766             gzipclose();
 767             exit;
 768         }
 769         if (defined($input{'annotate'}) && $allow_annotate) {
 770             &doAnnotate($input{'annotate'});
 771             gzipclose();
 772             exit;
 773         }
 774         if (defined($input{'r1'}) && defined($input{'r2'})) {
 775             &doDiff($fullname, $input{'r1'}, $input{'tr1'},
 776                     $input{'r2'}, $input{'tr2'}, $input{'f'});
 777             gzipclose();
 778             exit;
 779         }
 780         print("going to dolog($fullname)\n") if ($verbose);
 781         &doLog($fullname);
 782 ##############################
 783 # View Diff
 784 ##############################
 785     }
 786     elsif ($fullname =~ s/\.diff$// && -f $fullname . ",v" &&
 787            $input{'r1'} && $input{'r2'}) {
 788
 789         # $where-diff-removal if 'cvs rdiff' is used
 790         # .. but 'cvs rdiff'doesn't support some options
 791         # rcsdiff does (-w and -p), so it is disabled
 792         # $where =~ s/\.diff$//;
 793
 794         # Allow diffs using the ".diff" extension
 795         # so that browsers that default to the URL
 796         # for a save filename don't save diff's as
 797         # e.g. foo.c
 798         &doDiff($fullname, $input{'r1'}, $input{'tr1'},
 799                 $input{'r2'}, $input{'tr2'}, $input{'f'});
 800         gzipclose();
 801         exit;
 802     }
 803     elsif (($newname = $fullname) =~ s|/([^/]+)$|/Attic/$1| &&
 804            -f $newname . ",v") {
 805         # The file has been removed and is in the Attic.
 806         # Send a credirect pointing to the file in the Attic.
 807         (my $newplace = $scriptwhere) =~ s|/([^/]+)$|/Attic/$1|;
 808         &credirect($newplace . "?" . $ENV{QUERY_STRING});
 809         exit;
 810     }
 811     elsif (0 && (my @files = &safeglob($fullname . ",v"))) {
 812         http_header("text/plain");
 813         print "You matched the following files:\n";
 814         print join("\n", @files);
 815         # Find the tags from each file
 816         # Display a form offering diffs between said tags
 817     }
 818     else {
 819         my $fh = do {local(*FH);};
 820         my ($xtra, $module);
 821         # Assume it's a module name with a potential path following it.
 822         $xtra = $& if (($module = $where) =~ s|/.*||);
 823         # Is there an indexed version of modules?
 824         if (open($fh, "$cvsroot/CVSROOT/modules")) {
 825             while (<$fh>) {
 826                 if (/^(\S+)\s+(\S+)/o && $module eq $1
 827                     && -d "${cvsroot}/$2" && $module ne $2) {
 828                     &credirect($scriptname . '/' . $2 . $xtra);
 829                 }
 830             }
 831         }
 832         &fatal("404 Not Found","$where: no such file or directory");
 833     }
 834
 835 gzipclose();
 836 ## End MAIN
 837
 838 sub printDiffSelect($) {
 839     my ($use_java_script) = @_;
 840     $use_java_script = 0 if (!defined($use_java_script));
 841     my ($f) = $input{'f'};
 842     print "<SELECT NAME=\"f\"";
 843     print " onchange=\"submit()\"" if ($use_java_script);
 844     print ">\n";
 845     print "<OPTION VALUE=h",$f eq "h" ? " SELECTED" : "", ">Colored Diff";
 846     print "<OPTION VALUE=H",$f eq "H" ? " SELECTED" : "", ">Long Colored Diff";
 847     print "<OPTION VALUE=u",$f eq "u" ? " SELECTED" : "", ">Unidiff";
 848     print "<OPTION VALUE=c",$f eq "c" ? " SELECTED" : "", ">Context Diff";
 849     #print "<OPTION VALUE=s",$f eq "s" ? " SELECTED" : "", ">Side by Side";
 850     print "</SELECT>";
 851 }
 852
 853 sub findLastModifiedSubdirs(@) {
 854     my (@dirs) = @_;
 855     my ($dirname, @files);
 856
 857     foreach $dirname (@dirs) {
 858         next if ($dirname eq ".");
 859         next if ($dirname eq "..");
 860         my ($dir) = "$fullname/$dirname";
 861         next if (!-d $dir);
 862
 863         my ($lastmod) = undef;
 864         my ($lastmodtime) = undef;
 865         my $dh = do {local(*DH);};
 866
 867         opendir($dh,$dir) || next;
 868         my (@filenames) = readdir($dh);
 869         closedir($dh);
 870
 871         foreach my $filename (@filenames) {
 872             $filename = "$dirname/$filename";
 873             my ($file) = "$fullname/$filename";
 874             next if ($filename !~ /,v$/ || !-f $file);
 875             $filename =~ s/,v$//;
 876             my $modtime = -M $file;
 877             if (!defined($lastmod) || $modtime < $lastmodtime) {
 878                 $lastmod = $filename;
 879                 $lastmodtime = $modtime;
 880             }
 881         }
 882         push(@files, $lastmod) if (defined($lastmod));
 883     }
 884     return @files;
 885 }
 886
 887 sub htmlify($) {
 888         my($string) = @_;
 889
 890         # Special Characters; RFC 1866
 891         $string =~ s/&/&amp;/g;
 892         $string =~ s/\"/&quot;/g;
 893         $string =~ s/</&lt;/g;
 894         $string =~ s/>/&gt;/g;
 895
 896         # get URL's as link ..
 897         $string =~ s§(http|ftp|https)(://[-a-zA-Z0-9%.~:_/]+)([?&]([-a-zA-Z0-9%.~:_]+)=([-a-zA-Z0-9%.~:_])+)*§<A HREF="$1$2$3">$1$2$3</A>§;
 898         # get e-mails as link
 899         $string =~ s§([-a-zA-Z0-9_.]+@([-a-zA-Z0-9]+\.)+[A-Za-z]{2,4})§<A HREF="mailto:$1">$1</A>§;
 900
 901         return $string;
 902 }
 903
 904 sub spacedHtmlText($) {
 905         my($string) = @_;
 906
 907         # Cut trailing spaces
 908         s/\s+$//;
 909
 910         # Expand tabs
 911         $string =~ s/\t+/' ' x (length($&) * $tabstop - length($`) % $tabstop)/e
 912             if (defined($tabstop));
 913
 914         # replace <tab> and <space> (§ is to protect us from htmlify)
 915         # gzip can make excellent use of this repeating pattern :-)
 916         $string =~ s/§/§%/g; #protect our & substitute
 917         if ($hr_breakable) {
 918             # make every other space 'breakable'
 919             $string =~ s/       / §nbsp; §nbsp; §nbsp; §nbsp;/g;    # <tab>
 920             $string =~ s/  / §nbsp;/g;                              # 2 * <space>
 921             # leave single space as it is
 922         }
 923         else {
 924             $string =~ s/       /§nbsp;§nbsp;§nbsp;§nbsp;§nbsp;§nbsp;§nbsp;§nbsp;/g;
 925             $string =~ s/ /§nbsp;/g;
 926         }
 927
 928         $string = htmlify($string);
 929
 930         # unescape
 931         $string =~ s/§([^%])/&$1/g;
 932         $string =~ s/§%/§/g;
 933
 934         return $string;
 935 }
 936
 937 sub link($$) {
 938         my($name, $where) = @_;
 939
 940         return "<A HREF=\"$where\">$name</A>\n";
 941 }
 942
 943 sub revcmp($$) {
 944         my($rev1, $rev2) = @_;
 945         my(@r1) = split(/\./, $rev1);
 946         my(@r2) = split(/\./, $rev2);
 947         my($a,$b);
 948
 949         while (($a = shift(@r1)) && ($b = shift(@r2))) {
 950             if ($a != $b) {
 951                 return $a <=> $b;
 952             }
 953         }
 954         if (@r1) { return 1; }
 955         if (@r2) { return -1; }
 956         return 0;
 957 }
 958
 959 sub fatal($$) {
 960         my($errcode, $errmsg) = @_;
 961         if (defined($ENV{'MOD_PERL'})) {
 962                 Apache->request->status((split(/ /, $errcode))[0]);
 963         }
 964         else {
 965                 print "Status: $errcode\n";
 966         }
 967         html_header("Error");
 968         print "Error: $errmsg\n";
 969         print &html_footer;
 970         exit(1);
 971 }
 972
 973 sub credirect($) {
 974         my($url) = @_;
 975         if (defined($ENV{'MOD_PERL'})) {
 976                 Apache->request->status(301);
 977                 Apache->request->header_out(Location => $url);
 978         }
 979         else {
 980                 print "Status: 301 Moved\r\n";
 981                 print "Location: $url\r\n";
 982         }
 983         html_header("Moved");
 984         print "This document is located <A HREF=$url>here</A>.\n";
 985         print &html_footer;
 986         exit(1);
 987 }
 988
 989 sub safeglob($) {
 990         my ($filename) = @_;
 991         my ($dirname);
 992         my (@results);
 993         my $dh = do {local(*DH);};
 994
 995         ($dirname = $filename) =~ s|/[^/]+$||;
 996         $filename =~ s|.*/||;
 997
 998         if (opendir($dh, $dirname)) {
 999                 my $glob = $filename;
1000                 my $t;
1001         #       transform filename from glob to regex.  Deal with:
1002         #       [, {, ?, * as glob chars
1003         #       make sure to escape all other regex chars
1004                 $glob =~ s/([\.\(\)\|\+])/\\$1/g;
1005                 $glob =~ s/\*/.*/g;
1006                 $glob =~ s/\?/./g;
1007                 $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg;
1008                 foreach (readdir($dh)) {
1009                         if (/^${glob}$/) {
1010                                 push(@results, $dirname . "/" .$_);
1011                         }
1012                 }
1013                 closedir($dh);
1014         }
1015
1016         @results;
1017 }
1018
1019 sub getMimeTypeFromSuffix($) {
1020     my ($fullname) = @_;
1021     my ($mimetype, $suffix);
1022     my $fh = do {local(*FH);};
1023
1024     ($suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/;
1025     $mimetype = $MTYPES{$suffix};
1026     $mimetype = $MTYPES{'*'} if (!$mimetype);
1027
1028     if (!$mimetype && -f $mime_types) {
1029         # okey, this is something special - search the
1030         # mime.types database
1031         open ($fh, "<$mime_types");
1032         while (<$fh>) {
1033             if ($_ =~ /^\s*(\S+\/\S+).*\b$suffix\b/) {
1034                 $mimetype = $1;
1035                 last;
1036             }
1037         }
1038         close ($fh);
1039     }
1040
1041 # okey, didn't find anything useful ..
1042     if (!($mimetype =~ /\S\/\S/)) {
1043         $mimetype = "text/plain";
1044     }
1045     return $mimetype;
1046 }
1047
1048 ###############################
1049 # show Annotation
1050 ###############################
1051 sub doAnnotate ($$) {
1052     my ($rev) = @_;
1053     my ($pid);
1054     my ($pathname, $filename);
1055     my $reader = do {local(*FH);};
1056     my $writer = do {local(*FH);};
1057
1058     # make sure the revisions are wellformed, for security
1059     # reasons ..
1060     if (!($rev =~ /^[\d\.]+$/)) {
1061         &fatal("404 Not Found",
1062                 "Malformed query \"$ENV{'QUERY_STRING'}\"");
1063     }
1064
1065     if (&forbidden_file($fullname)) {
1066         &fatal("403 Forbidden", "Access forbidden. This file is mentioned in \@DissallowRead");
1067         return;
1068     }
1069
1070     ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;
1071     ($filename = $where) =~ s/^.*\///;
1072
1073     http_header();
1074
1075     navigateHeader ($scriptwhere,$pathname,$filename,$rev, "annotate");
1076     print "<h3 align=center>Annotation of $pathname$filename, Revision $rev</h3>\n";
1077
1078     # this seems to be necessary
1079     $| = 1; $| = 0; # Flush
1080
1081     # this annotate version is based on the
1082     # cvs annotate-demo Perl script by Cyclic Software
1083     # It was written by Cyclic Software, http://www.cyclic.com/, and is in
1084     # the public domain.
1085     # we could abandon the use of rlog, rcsdiff and co using
1086     # the cvsserver in a similiar way one day (..after rewrite)
1087     $pid = open2($reader, $writer, "cvs server") || fatal ("500 Internal Error",
1088                                                                "Fatal Error - unable to open cvs for annotation");
1089
1090     # OK, first send the request to the server.  A simplified example is:
1091     #     Root /home/kingdon/zwork/cvsroot
1092     #     Argument foo/xx
1093     #     Directory foo
1094     #     /home/kingdon/zwork/cvsroot/foo
1095     #     Directory .
1096     #     /home/kingdon/zwork/cvsroot
1097     #     annotate
1098     # although as you can see there are a few more details.
1099
1100     print $writer "Root $cvsroot\n";
1101     print $writer "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n";
1102     # Don't worry about sending valid-requests, the server just needs to
1103     # support "annotate" and if it doesn't, there isn't anything to be done.
1104     print $writer "UseUnchanged\n";
1105     print $writer "Argument -r\n";
1106     print $writer "Argument $rev\n";
1107     print $writer "Argument $where\n";
1108
1109     # The protocol requires us to fully fake a working directory (at
1110     # least to the point of including the directories down to the one
1111     # containing the file in question).
1112     # So if $where is "dir/sdir/file", then @dirs will be ("dir","sdir","file")
1113     my @dirs = split('/', $where);
1114     my $path = "";
1115     foreach (@dirs) {
1116         if ($path eq "") {
1117             # In our example, $_ is "dir".
1118             $path = $_;
1119         }
1120         else {
1121             print $writer "Directory $path\n";
1122             print $writer "$cvsroot/$path\n";
1123             # In our example, $_ is "sdir" and $path becomes "dir/sdir"
1124             # And the next time, "file" and "dir/sdir/file" (which then gets
1125             # ignored, because we don't need to send Directory for the file).
1126             $path .= "/$_";
1127         }
1128     }
1129     # And the last "Directory" before "annotate" is the top level.
1130     print $writer "Directory .\n";
1131     print $writer "$cvsroot\n";
1132
1133     print $writer "annotate\n";
1134     # OK, we've sent our command to the server.  Thing to do is to
1135     # close the writer side and get all the responses.  If "cvs server"
1136     # were nicer about buffering, then we could just leave it open, I think.
1137     close ($writer) || die "cannot close: $!";
1138
1139     # Ready to get the responses from the server.
1140     # For example:
1141     #     E Annotations for foo/xx
1142     #     E ***************
1143     #     M 1.3          (kingdon  06-Sep-97): hello
1144     #     ok
1145     my ($lineNr) = 0;
1146     my ($oldLrev, $oldLusr) = ("", "");
1147     my ($revprint, $usrprint);
1148     if ($annTable) {
1149         print "<table border=0 cellspacing=0 cellpadding=0>\n";
1150     }
1151     else {
1152         print "<pre>";
1153     }
1154     while (<$reader>) {
1155         my @words = split;
1156         # Adding one is for the (single) space which follows $words[0].
1157         my $rest = substr ($_, length ($words[0]) + 1);
1158         if ($words[0] eq "E") {
1159             next;
1160         }
1161         elsif ($words[0] eq "M") {
1162             $lineNr++;
1163             my $lrev = substr ($_, 2, 13);
1164             my $lusr = substr ($_, 16,  9);
1165             my $line = substr ($_, 36);
1166             # we should parse the date here ..
1167             if ($lrev eq $oldLrev) {
1168                 $revprint = "             ";
1169             }
1170             else {
1171                 $revprint = $lrev; $oldLusr = "";
1172             }
1173             if ($lusr eq $oldLusr) {
1174                 $usrprint = "         ";
1175             }
1176             else {
1177                 $usrprint = $lusr;
1178             }
1179             $oldLrev = $lrev;
1180             $oldLusr = $lusr;
1181             # is there a less timeconsuming way to strip spaces ?
1182             ($lrev = $lrev) =~ s/\s+//g;
1183             my $isCurrentRev = ("$rev" eq "$lrev");
1184
1185             print "<b>" if ($isCurrentRev);
1186             printf ("%8s%s%8s %4d:", $revprint, ($isCurrentRev ? "|" : " "), $usrprint, $lineNr);
1187             print spacedHtmlText($line);
1188             print "</b>" if ($isCurrentRev);
1189         }
1190         elsif ($words[0] eq "ok") {
1191             # We could complain about any text received after this, like the
1192             # CVS command line client.  But for simplicity, we don't.
1193         }
1194         elsif ($words[0] eq "error") {
1195             fatal ("500 Internal Error", "Error occured during annotate: <b>$_</b>");
1196         }
1197     }
1198     if ($annTable) {
1199         print "</table>";
1200     }
1201     else {
1202         print "</pre>";
1203     }
1204     close ($reader) || warn "cannot close: $!";
1205     wait;
1206 }
1207
1208 ###############################
1209 # make Checkout
1210 ###############################
1211 sub doCheckout($$) {
1212     my ($fullname, $rev) = @_;
1213     my ($mimetype,$revopt);
1214     my $fh = do {local(*FH);};
1215
1216     if ($rev eq 'HEAD' || $rev eq '.') {
1217         $rev = undef;
1218     }
1219
1220     # make sure the revisions a wellformed, for security
1221     # reasons ..
1222     if (defined($rev) && !($rev =~ /^[\d\.]+$/)) {
1223         &fatal("404 Not Found",
1224                 "Malformed query \"$ENV{'QUERY_STRING'}\"");
1225     }
1226
1227     if (&forbidden_file($fullname)) {
1228         &fatal("403 Forbidden", "Access forbidden. This file is mentioned in \@DissallowRead");
1229         return;
1230     }
1231
1232     # get mimetype
1233     if (defined($input{"content-type"}) && ($input{"content-type"} =~ /\S\/\S/)) {
1234         $mimetype = $input{"content-type"}
1235     }
1236     else {
1237         $mimetype = &getMimeTypeFromSuffix($fullname);
1238     }
1239
1240     if (defined($rev)) {
1241         $revopt = "-r$rev";
1242         if ($use_moddate) {
1243             readLog($fullname,$rev);
1244             $moddate=$date{$rev};
1245         }
1246     }
1247     else {
1248         $revopt = "-rHEAD";
1249         if ($use_moddate) {
1250             readLog($fullname);
1251             $moddate=$date{$symrev{HEAD}};
1252         }
1253     }
1254
1255     ### just for the record:
1256     ### 'cvs co' seems to have a bug regarding single checkout of
1257     ### directories/files having spaces in it;
1258     ### this is an issue that should be resolved on cvs's side
1259     #
1260     # Safely for a child process to read from.
1261     if (! open($fh, "-|")) { # child
1262       open(STDERR, ">&STDOUT"); # Redirect stderr to stdout
1263       exec("cvs", "-d", "$cvsroot", "co", "-p", "$revopt", "$where");
1264     }
1265 #===================================================================
1266 #Checking out squid/src/ftp.c
1267 #RCS:  /usr/src/CVS/squid/src/ftp.c,v
1268 #VERS: 1.1.1.28.6.2
1269 #***************
1270
1271     # Parse CVS header
1272     my ($revision, $filename, $cvsheader);
1273     $filename = "";
1274     while(<$fh>) {
1275         last if (/^\*\*\*\*/);
1276         $revision = $1 if (/^VERS: (.*)$/);
1277         if (/^Checking out (.*)$/) {
1278                 $filename = $1;
1279                 $filename =~ s/^\.\/*//;
1280         }
1281         $cvsheader .= $_;
1282     }
1283     if ($filename ne $where) {
1284         &fatal("500 Internal Error",
1285                "Unexpected output from cvs co: $cvsheader"
1286                . "<p><b>Check whether the directory $cvsroot/CVSROOT exists "
1287                . "and the script has write-access to the CVSROOT/history "
1288                . "file if it exists."
1289                . "<br>The script needs to place lock files in the "
1290                . "directory the file is in as well.</b>");
1291     }
1292     $| = 1;
1293
1294     if ($mimetype eq "text/x-cvsweb-markup") {
1295         &cvswebMarkup($fh,$fullname,$revision);
1296     }
1297     else {
1298         http_header($mimetype);
1299         print <$fh>;
1300     }
1301     close($fh);
1302 }
1303
1304 sub cvswebMarkup($$$) {
1305     my ($filehandle,$fullname,$revision) = @_;
1306     my ($pathname, $filename);
1307
1308     ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;
1309     ($filename = $where) =~ s/^.*\///;
1310     my ($fileurl) = urlencode($filename);
1311
1312     http_header();
1313
1314     navigateHeader ($scriptwhere, $pathname, $filename, $revision, "view");
1315     print "<HR noshade>";
1316     print "<table width=\"100%\"><tr><td bgcolor=\"$markupLogColor\">";
1317     print "File: ", &clickablePath($where, 1);
1318     print "&nbsp;";
1319     &download_link(urlencode($fileurl), $revision, "(download)");
1320     if (!$defaultTextPlain) {
1321         print "&nbsp;";
1322         &download_link(urlencode($fileurl), $revision, "(as text)",
1323                "text/plain");
1324     }
1325     print "<BR>\n";
1326     if ($show_log_in_markup) {
1327         readLog($fullname); #,$revision);
1328         printLog($revision,0);
1329     }
1330     else {
1331         print "Version: <B>$revision</B><BR>\n";
1332         print "Tag: <B>", $input{only_with_tag}, "</b><br>\n" if
1333             $input{only_with_tag};
1334     }
1335     print "</td></tr></table>";
1336     my @content = <$filehandle>;
1337     my $url = download_url($fileurl, $revision, $mimetype);
1338     print "<HR noshade>";
1339     if ($mimetype =~ /^image/) {
1340         print "<IMG SRC=\"$url$barequery\"><BR>";
1341     }
1342     elsif ($mimetype =~ m%^application/pdf%) {
1343         print "<EMBED SRC=\"$url$barequery\" WIDTH=\"100%\"><BR>";
1344     }
1345     else {
1346         print "<PRE>";
1347         foreach (@content) {
1348             print spacedHtmlText($_);
1349         }
1350         print "</PRE>";
1351     }
1352 }
1353
1354 sub viewable($) {
1355     my ($mimetype) = @_;
1356
1357     $mimetype =~ m%^text/% ||
1358     $mimetype =~ m%^image/% ||
1359     $mimetype =~ m%^application/pdf% ||
1360     0;
1361 }
1362
1363 ###############################
1364 # Show Colored Diff
1365 ###############################
1366 sub doDiff($$$$$$) {
1367         my($fullname, $r1, $tr1, $r2, $tr2, $f) = @_;
1368         my $fh = do {local(*FH);};
1369         my ($rev1, $rev2, $sym1, $sym2, @difftype, $diffname, $f1, $f2);
1370
1371         if (&forbidden_file($fullname)) {
1372             &fatal("403 Forbidden", "Access forbidden. This file is mentioned in \@DissallowRead");
1373             return;
1374         }
1375
1376         if ($r1 =~ /([^:]+)(:(.+))?/) {
1377             $rev1 = $1;
1378             $sym1 = $3;
1379         }
1380         if ($r1 eq 'text') {
1381             $rev1 = $tr1;
1382             $sym1 = "";
1383         }
1384         if ($r2 =~ /([^:]+)(:(.+))?/) {
1385             $rev2 = $1;
1386             $sym2 = $3;
1387         }
1388         if ($r2 eq 'text') {
1389             $rev2 = $tr2;
1390             $sym2 = "";
1391         }
1392         # make sure the revisions a wellformed, for security
1393         # reasons ..
1394         if (!($rev1 =~ /^[\d\.]+$/) || !($rev2 =~ /^[\d\.]+$/)) {
1395             &fatal("404 Not Found",
1396                     "Malformed query \"$ENV{'QUERY_STRING'}\"");
1397         }
1398 #
1399 # rev1 and rev2 are now both numeric revisions.
1400 # Thus we do a DWIM here and swap them if rev1 is after rev2.
1401 # XXX should we warn about the fact that we do this?
1402         if (&revcmp($rev1,$rev2) > 0) {
1403             my ($tmp1, $tmp2) = ($rev1, $sym1);
1404             ($rev1, $sym1) = ($rev2, $sym2);
1405             ($rev2, $sym2) = ($tmp1, $tmp2);
1406         }
1407         my $human_readable = 0;
1408         if ($f eq 'c') {
1409             @difftype = qw{-c};
1410             $diffname = "Context diff";
1411         }
1412         elsif ($f eq 's') {
1413             @difftype = qw{--side-by-side --width=164};
1414             $diffname = "Side by Side";
1415         }
1416         elsif ($f eq 'H') {
1417             $human_readable = 1;
1418             @difftype = qw{--unified=15};
1419             $diffname = "Long Human readable";
1420         }
1421         elsif ($f eq 'h') {
1422             @difftype =qw{-u};
1423             $human_readable = 1;
1424             $diffname = "Human readable";
1425         }
1426         elsif ($f eq 'u') {
1427             @difftype = qw{-u};
1428             $diffname = "Unidiff";
1429         }
1430         else {
1431             fatal ("400 Bad arguments", "Diff format $f not understood");
1432         }
1433
1434         # apply special options
1435         if ($human_readable) {
1436             if ($hr_funout) {
1437                 push @difftype, '-p';
1438             }
1439             if ($hr_ignwhite) {
1440                 push @difftype, '-w';
1441             }
1442             if ($hr_ignkeysubst) {
1443                 push @difftype, '-kk';
1444             }
1445         }
1446         if (! open($fh, "-|")) { # child
1447                 open(STDERR, ">&STDOUT"); # Redirect stderr to stdout
1448                 exec("rcsdiff",@difftype,"-r$rev1","-r$rev2",$fullname);
1449         }
1450         if ($human_readable) {
1451             http_header();
1452             &human_readable_diff($fh, $rev2);
1453             gzipclose();
1454             exit;
1455         }
1456         else {
1457             http_header("text/plain");
1458         }
1459 #
1460 #===================================================================
1461 #RCS file: /home/ncvs/src/sys/netinet/tcp_output.c,v
1462 #retrieving revision 1.16
1463 #retrieving revision 1.17
1464 #diff -c -r1.16 -r1.17
1465 #*** /home/ncvs/src/sys/netinet/tcp_output.c     1995/11/03 22:08:08     1.16
1466 #--- /home/ncvs/src/sys/netinet/tcp_output.c     1995/12/05 17:46:35     1.17
1467 #
1468 # Ideas:
1469 # - nuke the stderr output if it's what we expect it to be
1470 # - Add "no differences found" if the diff command supplied no output.
1471 #
1472 #*** src/sys/netinet/tcp_output.c     1995/11/03 22:08:08     1.16
1473 #--- src/sys/netinet/tcp_output.c     1995/12/05 17:46:35     1.17 RELENG_2_1_0
1474 # (bogus example, but...)
1475 #
1476         if (grep { $_ eq '-u'} @difftype) {
1477             $f1 = '---';
1478             $f2 = '\+\+\+';
1479         }
1480         else {
1481             $f1 = '\*\*\*';
1482             $f2 = '---';
1483         }
1484         while (<$fh>) {
1485             if (m|^$f1 $cvsroot|o) {
1486                 s|$cvsroot/||o;
1487                 if ($sym1) {
1488                     chop;
1489                     $_ .= " $sym1\n";
1490                 }
1491             }
1492             elsif (m|^$f2 $cvsroot|o) {
1493                 s|$cvsroot/||o;
1494                 if ($sym2) {
1495                     chop;
1496                     $_ .= " $sym2\n";
1497                 }
1498             }
1499             print $_;
1500         }
1501         close($fh);
1502 }
1503
1504 ###############################
1505 # Show Logs ..
1506 ###############################
1507 sub getDirLogs($$@) {
1508     my ($cvsroot,$dirname,@otherFiles) = @_;
1509     my ($state,$otherFiles,$tag, $file, $date, $branchpoint, $branch, $log);
1510     my ($rev, $revision, $revwanted, $filename, $head, $author);
1511
1512     $tag = $input{only_with_tag};
1513
1514     my ($DirName) = "$cvsroot/$where";
1515     my (@files, @filetags);
1516     my $fh = do {local(*FH);};
1517
1518     push(@files, &safeglob("$DirName/*,v"));
1519     push(@files, &safeglob("$DirName/Attic/*,v")) if (!$input{'hideattic'});
1520     foreach $file (@otherFiles) {
1521         push(@files, "$DirName/$file");
1522     }
1523
1524     # just execute rlog if there are any files
1525     if ($#files < 0) {
1526         return;
1527     }
1528
1529     if (defined($tag)) {
1530         #can't use -r<tag> as - is allowed in tagnames, but misinterpreated by rlog..
1531         if (! open($fh, "-|")) {
1532                 open(STDERR, "> /dev/null"); # rlog may complain; ignore.
1533                 exec($no_rlog ? ( "cvs", "log") : ( "rlog" ) ,@files);
1534         }
1535     }
1536     else {
1537         my $kidpid = open($fh, "-|");
1538         if (! $kidpid) {
1539                 open(STDERR, "> /dev/null"); # rlog may complain; ignore.
1540                 exec($no_rlog ? ( "cvs", "log" ) : ( "rlog" ),"-r",@files);
1541         }
1542     }
1543     $state = "start";
1544     while (<$fh>) {
1545         if ($state eq "start") {
1546             #Next file. Initialize file variables
1547             $rev = undef;
1548             $revwanted = undef;
1549             $branch = undef;
1550             $branchpoint = undef;
1551             $filename = undef;
1552             $log = undef;
1553             $revision = undef;
1554             $branch = undef;
1555             %symrev = ();
1556             @filetags = ();
1557             #jump to head state
1558             $state = "head";
1559         }
1560         print "$state:$_" if ($verbose);
1561 again:
1562         if ($state eq "head") {
1563             #$rcsfile = $1 if (/^RCS file: (.+)$/); #not used (yet)
1564             $filename = $1 if (/^Working file: (.+)$/);
1565             $head = $1 if (/^head: (.+)$/);
1566             $branch = $1 if (/^branch: (.+)$/);
1567         }
1568         if ($state eq "head" && /^symbolic names/) {
1569             $state = "tags";
1570             ($branch = $head) =~ s/\.\d+$// if (!defined($branch));
1571             $branch =~ s/(\.?)(\d+)$/${1}0.$2/;
1572             $symrev{MAIN} = $branch;
1573             $symrev{HEAD} = $branch;
1574             $alltags{MAIN} = 1;
1575             $alltags{HEAD} = 1;
1576             push (@filetags, "MAIN", "HEAD");
1577             next;
1578         }
1579         if ($state eq "tags" &&
1580                             /^\s+(.+):\s+([\d\.]+)\s+$/) {
1581             push (@filetags, $1);
1582             $symrev{$1} = $2;
1583             $alltags{$1} = 1;
1584             next;
1585         }
1586         if ($state eq "tags" && /^\S/) {
1587             if (defined($tag) && (defined($symrev{$tag}) || $tag eq "HEAD")) {
1588                 $revwanted = $tag eq "HEAD" ? $symrev{"MAIN"} : $symrev{$tag};
1589                 ($branch = $revwanted) =~ s/\.0\././;
1590                 ($branchpoint = $branch) =~ s/\.?\d+$//;
1591                 $revwanted = undef if ($revwanted ne $branch);
1592             }
1593             elsif (defined($tag) && $tag ne "HEAD") {
1594                 print "Tag not found, skip this file" if ($verbose);
1595                 $state = "skip";
1596                 next;
1597             }
1598             foreach my $tagfound (@filetags) {
1599                 $tags{$tagfound} = 1;
1600             }
1601             $state = "head";
1602             goto again;
1603         }
1604         if ($state eq "head" && /^----------------------------$/) {
1605             $state = "log";
1606             $rev = undef;
1607             $date = undef;
1608             $log = "";
1609             # Try to reconstruct the relative filename if RCS spits out a full path
1610             $filename =~ s%^\Q$DirName\E/%%;
1611             next;
1612         }
1613         if ($state eq "log") {
1614             if (/^----------------------------$/
1615                 || /^=============================/) {
1616                 # End of a log entry.
1617                 my $revbranch;
1618                 ($revbranch = $rev) =~ s/\.\d+$//;
1619                 print "$filename $rev Wanted: $revwanted "
1620                     . "Revbranch: $revbranch Branch: $branch "
1621                     . "Branchpoint: $branchpoint\n" if ($verbose);
1622                 if (!defined($revwanted) && defined($branch)
1623                     && $branch eq $revbranch || !defined($tag)) {
1624                     print "File revision $rev found for branch $branch\n"
1625                         if ($verbose);
1626                     $revwanted = $rev;
1627                 }
1628                 if (defined($revwanted) ? $rev eq $revwanted :
1629                     defined($branchpoint) ? $rev eq $branchpoint :
1630                     0 && ($rev eq $head)) { # Don't think head is needed here..
1631                     print "File info $rev found for $filename\n" if ($verbose);
1632                     my @finfo = ($rev,$date,$log,$author,$filename);
1633                     my ($name);
1634                     ($name = $filename) =~ s%/.*%%;
1635                     $fileinfo{$name} = [ @finfo ];
1636                     $state = "done" if (defined($revwanted) && $rev eq $revwanted);
1637                 }
1638                 $rev = undef;
1639                 $date = undef;
1640                 $log = "";
1641             }
1642             elsif (!defined($date) && m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);|) {
1643                 my $yr = $1;
1644                 # damn 2-digit year routines :-)
1645                 if ($yr > 100) {
1646                     $yr -= 1900;
1647                 }
1648                 $date = &Time::Local::timegm($6,$5,$4,$3,$2 - 1,$yr);
1649                 ($author) = /author: ([^;]+)/;
1650                 $state = "log";
1651                 $log = '';
1652                 next;
1653             }
1654             elsif (!defined($rev) && m/^revision (.*)$/) {
1655                 $rev = $1;
1656                 next;
1657             }
1658             else {
1659                 $log = $log . $_;
1660             }
1661         }
1662         if (/^===============/) {
1663             $state = "start";
1664             next;
1665         }
1666     }
1667     if ($. == 0) {
1668         fatal("500 Internal Error",
1669               "Failed to spawn GNU rlog on <em>'".join(", ", @files)."'</em><p>did you set the <b>\$ENV{PATH}</b> in your configuration file correctly ?");
1670     }
1671     close($fh);
1672 }
1673
1674 sub readLog($;$) {
1675         my($fullname,$revision) = @_;
1676         my ($symnames, $head, $rev, $br, $brp, $branch, $branchrev);
1677         my $fh = do {local(*FH);};
1678
1679         if (defined($revision)) {
1680             $revision = "-r$revision";
1681         }
1682         else {
1683             $revision = "";
1684         }
1685
1686         undef %symrev;
1687         undef %revsym;
1688         undef @allrevisions;
1689         undef %date;
1690         undef %author;
1691         undef %state;
1692         undef %difflines;
1693         undef %log;
1694
1695         print("Going to rlog '$fullname'\n") if ($verbose);
1696         if (! open($fh, "-|")) { # child
1697                 if ($revision ne '') {
1698                         exec($no_rlog ? ( "cvs", "log" ) : ( "rlog" ),$revision,$fullname);
1699                 }
1700                 else {
1701                         exec($no_rlog ? ( "cvs", "log" ) : ( "rlog" ),$fullname);
1702                 }
1703         }
1704         while (<$fh>) {
1705             print if ($verbose);
1706             if ($symnames) {
1707                 if (/^\s+([^:]+):\s+([\d\.]+)/) {
1708                     $symrev{$1} = $2;
1709                 }
1710                 else {
1711                     $symnames = 0;
1712                 }
1713             }
1714             elsif (/^head:\s+([\d\.]+)/) {
1715                 $head = $1;
1716             }
1717             elsif (/^branch:\s+([\d\.]+)/) {
1718                 $curbranch = $1;
1719             }
1720             elsif (/^symbolic names/) {
1721                 $symnames = 1;
1722             }
1723             elsif (/^-----/) {
1724                 last;
1725             }
1726         }
1727         ($curbranch = $head) =~ s/\.\d+$// if (!defined($curbranch));
1728
1729 # each log entry is of the form:
1730 # ----------------------------
1731 # revision 3.7.1.1
1732 # date: 1995/11/29 22:15:52;  author: fenner;  state: Exp;  lines: +5 -3
1733 # log info
1734 # ----------------------------
1735         logentry:
1736         while (!/^=========/) {
1737             $_ = <$fh>;
1738             last logentry if (!defined($_));    # EOF
1739             print "R:", $_ if ($verbose);
1740             if (/^revision ([\d\.]+)/) {
1741                 $rev = $1;
1742                 unshift(@allrevisions,$rev);
1743             }
1744             elsif (/^========/ || /^----------------------------$/) {
1745                 next logentry;
1746             }
1747             else {
1748                 # The rlog output is syntactically ambiguous.  We must
1749                 # have guessed wrong about where the end of the last log
1750                 # message was.
1751                 # Since this is likely to happen when people put rlog output
1752                 # in their commit messages, don't even bother keeping
1753                 # these lines since we don't know what revision they go with
1754                 # any more.
1755                 next logentry;
1756 #               &fatal("500 Internal Error","Error parsing RCS output: $_");
1757             }
1758             $_ = <$fh>;
1759             print "D:", $_ if ($verbose);
1760             if (m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);\s+author:\s+(\S+);\s+state:\s+(\S+);\s+(lines:\s+([0-9\s+-]+))?|) {
1761                 my $yr = $1;
1762                 # damn 2-digit year routines :-)
1763                 if ($yr > 100) {
1764                     $yr -= 1900;
1765                 }
1766                 $date{$rev} = &Time::Local::timegm($6,$5,$4,$3,$2 - 1,$yr);
1767                 $author{$rev} = $7;
1768                 $state{$rev} = $8;
1769                 $difflines{$rev} = $10;
1770             }
1771             else {
1772                 &fatal("500 Internal Error", "Error parsing RCS output: $_");
1773             }
1774             line:
1775             while (<$fh>) {
1776                 print "L:", $_ if ($verbose);
1777                 next line if (/^branches:\s/);
1778                 last line if (/^----------------------------$/ || /^=========/);
1779                 $log{$rev} .= $_;
1780             }
1781             print "E:", $_ if ($verbose);
1782         }
1783         close($fh);
1784         print "Done reading RCS file\n" if ($verbose);
1785
1786         @revorder = reverse sort {revcmp($a,$b)} @allrevisions;
1787         print "Done sorting revisions",join(" ",@revorder),"\n" if ($verbose);
1788
1789 #
1790 # HEAD is an artificial tag which is simply the highest tag number on the main
1791 # branch, unless there is a branch tag in the RCS file in which case it's the
1792 # highest revision on that branch.  Find it by looking through @revorder; it
1793 # is the first commit listed on the appropriate branch.
1794 # This is not neccesary the same revision as marked as head in the RCS file.
1795         my $headrev = $curbranch || "1";
1796         ($symrev{"MAIN"} = $headrev) =~ s/(\.?)(\d+)$/${1}0.$2/;
1797         revision:
1798         foreach $rev (@revorder) {
1799             if ($rev =~ /^(\S*)\.\d+$/ && $headrev eq $1) {
1800                 $symrev{"HEAD"} = $rev;
1801                 last revision;
1802             }
1803         }
1804         ($symrev{"HEAD"} = $headrev) =~ s/\.\d+$//
1805             if (!defined($symrev{"HEAD"}));
1806         print "Done finding HEAD\n" if ($verbose);
1807 #
1808 # Now that we know all of the revision numbers, we can associate
1809 # absolute revision numbers with all of the symbolic names, and
1810 # pass them to the form so that the same association doesn't have
1811 # to be built then.
1812 #
1813         undef @branchnames;
1814         undef %branchpoint;
1815         undef $sel;
1816
1817         foreach (reverse sort keys %symrev) {
1818             $rev = $symrev{$_};
1819             if ($rev =~ /^((.*)\.)0\.(\d+)$/) {
1820                 push(@branchnames, $_);
1821                 #
1822                 # A revision number of A.B.0.D really translates into
1823                 # "the highest current revision on branch A.B.D".
1824                 #
1825                 # If there is no branch A.B.D, then it translates into
1826                 # the head A.B .
1827                 #
1828                 # This reasoning also applies to the main branch A.B,
1829                 # with the branch number 0.A, with the exception that
1830                 # it has no head to translate to if there is nothing on
1831                 # the branch, but I guess this can never happen?
1832                 #
1833                 # Since some stupid people actually import/check in
1834                 # files with version 0.X we assume that the above cannot
1835                 # happen, and regard 0.X(.*) as a revision and not a branch.
1836                 #
1837                 $head = defined($2) ? $2 : "";
1838                 $branch = $3;
1839                 $branchrev = $head . ($head ne "" ? "." : "") . $branch;
1840                 my $regex;
1841                 ($regex = $branchrev) =~ s/\./\\./g;
1842                 $rev = $head;
1843
1844                 revision:
1845                 foreach my $r (@revorder) {
1846                     if ($r =~ /^${regex}\b/) {
1847                         $rev = $branchrev;
1848                         last revision;
1849                     }
1850                 }
1851                 next if ($rev eq "");
1852                 if ($rev ne $head && $head ne "") {
1853                     $branchpoint{$head} .= ", " if ($branchpoint{$head});
1854                     $branchpoint{$head} .= $_;
1855                 }
1856             }
1857             $revsym{$rev} .= ", " if ($revsym{$rev});
1858             $revsym{$rev} .= $_;
1859             $sel .= "<OPTION VALUE=\"${rev}:${_}\">$_\n";
1860         }
1861         print "Done associating revisions with branches\n" if ($verbose);
1862
1863         my ($onlyonbranch, $onlybranchpoint);
1864         if ($onlyonbranch = $input{'only_with_tag'}) {
1865             $onlyonbranch = $symrev{$onlyonbranch};
1866             if ($onlyonbranch =~ s/\.0\././) {
1867                 ($onlybranchpoint = $onlyonbranch) =~ s/\.\d+$//;
1868             }
1869             else {
1870                 $onlybranchpoint = $onlyonbranch;
1871             }
1872             if (!defined($onlyonbranch) || $onlybranchpoint eq "") {
1873                 fatal("404 Tag not found","Tag $input{'only_with_tag'} not defined");
1874             }
1875         }
1876
1877         undef @revisions;
1878
1879         foreach (@allrevisions) {
1880             ($br = $_) =~ s/\.\d+$//;
1881             ($brp = $br) =~ s/\.\d+$//;
1882             next if ($onlyonbranch && $br ne $onlyonbranch &&
1883                                         $_ ne $onlybranchpoint);
1884             unshift(@revisions,$_);
1885         }
1886
1887         if ($logsort eq "date") {
1888             # Sort the revisions in commit order an secondary sort on revision
1889             # (secondary sort needed for imported sources, or the first main
1890             # revision gets before the same revision on the 1.1.1 branch)
1891             @revdisplayorder = sort {$date{$b} <=> $date{$a} || -revcmp($a, $b)} @revisions;
1892         }
1893         elsif ($logsort eq "rev") {
1894             # Sort the revisions in revision order, highest first
1895             @revdisplayorder = reverse sort {revcmp($a,$b)} @revisions;
1896         }
1897         else {
1898             # No sorting. Present in the same order as rlog / cvs log
1899             @revdisplayorder = @revisions;
1900         }
1901
1902 }
1903
1904 sub printLog($;$) {
1905         my ($link, $br, $brp);
1906         ($_,$link) = @_;
1907         ($br = $_) =~ s/\.\d+$//;
1908         ($brp = $br) =~ s/\.?\d+$//;
1909         my ($isDead, $prev);
1910
1911         $link = 1 if (!defined($link));
1912         $isDead = ($state{$_} eq "dead");
1913
1914         if ($link && !$isDead) {
1915             my ($filename);
1916             ($filename = $where) =~ s/^.*\///;
1917             my ($fileurl) = urlencode($filename);
1918             print "<a NAME=\"rev$_\"></a>";
1919             if (defined($revsym{$_})) {
1920                 foreach my $sym (split(", ", $revsym{$_})) {
1921                     print "<a NAME=\"$sym\"></a>";
1922                 }
1923             }
1924             if (defined($revsym{$br}) && $revsym{$br} && !defined($nameprinted{$br})) {
1925                 foreach my $sym (split(", ", $revsym{$br})) {
1926                     print "<a NAME=\"$sym\"></a>";
1927                 }
1928                 $nameprinted{$br} = 1;
1929             }
1930             print "\n Revision ";
1931             &download_link($fileurl, $_, $_,
1932                 $defaultViewable ? "text/x-cvsweb-markup" : undef);
1933             if ($defaultViewable) {
1934                 print " / ";
1935                 &download_link($fileurl, $_, "(download)", $mimetype);
1936             }
1937             if (not $defaultTextPlain) {
1938                 print " / ";
1939                 &download_link($fileurl, $_, "(as text)",
1940                            "text/plain");
1941             }
1942             if (!$defaultViewable) {
1943                 print " / ";
1944                 &download_link($fileurl, $_, "(view)", "text/x-cvsweb-markup");
1945             }
1946             if ($allow_annotate) {
1947                 print " - <a href=\"" . $scriptname . "/" . urlencode($where) . "?annotate=$_$barequery\">";
1948                 print "annotate</a>";
1949             }
1950             # Plus a select link if enabled, and this version isn't selected
1951             if ($allow_version_select) {
1952                 if ((!defined($input{"r1"}) || $input{"r1"} ne $_)) {
1953                     print " - <A HREF=\"${scriptwhere}?r1=$_$barequery" .
1954                         "\">[select for diffs]</A>\n";
1955                 }
1956                 else {
1957                     print " - <b>[selected]</b>";
1958                 }
1959             }
1960         }
1961         else {
1962             print "Revision <B>$_</B>";
1963         }
1964         if (/^1\.1\.1\.\d+$/) {
1965             print " <i>(vendor branch)</i>";
1966         }
1967         if (defined @mytz) {
1968             my ($est) = $mytz[(localtime($date{$_}))[8]];
1969             print ", <i>" . scalar localtime($date{$_}) . " $est</i> (";
1970         } else {
1971             print ", <i>" . scalar gmtime($date{$_}) . " UTC</i> (";
1972         }
1973         print readableTime(time() - $date{$_},1) . " ago)";
1974         print " by ";
1975         print "<i>" . $author{$_} . "</i>\n";
1976         print "<BR>Branch: <b>",$link?link_tags($revsym{$br}):$revsym{$br},"</b>\n"
1977             if ($revsym{$br});
1978         print "<BR>CVS Tags: <b>",$link?link_tags($revsym{$_}):$revsym{$_},"</b>"
1979             if ($revsym{$_});
1980         print "<BR>Branch point for: <b>",$link?link_tags($branchpoint{$_}):$branchpoint{$_},"</b>\n"
1981             if ($branchpoint{$_});
1982         # Find the previous revision
1983         my @prevrev = split(/\./, $_);
1984         do {
1985             if (--$prevrev[$#prevrev] <= 0) {
1986                 # If it was X.Y.Z.1, just make it X.Y
1987                 pop(@prevrev);
1988                 pop(@prevrev);
1989             }
1990             $prev = join(".", @prevrev);
1991         } until (defined($date{$prev}) || $prev eq "");
1992         if ($prev ne "") {
1993             if ($difflines{$_}) {
1994                 print "<BR>Changes since <b>$prev: $difflines{$_} lines</b>";
1995             }
1996         }
1997         if ($isDead) {
1998             print "<BR><B><I>FILE REMOVED</I></B>\n";
1999         }
2000         elsif ($link) {
2001             my %diffrev = ();
2002             $diffrev{$_} = 1;
2003             $diffrev{""} = 1;
2004             print "<BR>Diff";
2005             #
2006             # Offer diff to previous revision
2007             if ($prev) {
2008                 $diffrev{$prev} = 1;
2009                 print " to previous <A HREF=\"${scriptwhere}.diff?r1=$prev";
2010                 print "&amp;r2=$_" . $barequery . "\">$prev</A>\n";
2011                 if (!$hr_default) { # offer a human readable version if not default
2012                     print "(<A HREF=\"${scriptwhere}.diff?r1=$prev";
2013                     print "&amp;r2=$_" . $barequery . "&amp;f=h\">colored</A>)\n";
2014                 }
2015             }
2016             #
2017             # Plus, if it's on a branch, and it's not a vendor branch,
2018             # offer a diff with the branch point.
2019             if ($revsym{$brp} && !/^1\.1\.1\.\d+$/ && !defined($diffrev{$brp})) {
2020                 print " to branchpoint <A HREF=\"${scriptwhere}.diff?r1=$brp";
2021                 print "&amp;r2=$_" . $barequery . "\">$brp</A>\n";
2022                 if (!$hr_default) { # offer a human readable version if not default
2023                 print "(<A HREF=\"${scriptwhere}.diff?r1=$brp";
2024                 print "&amp;r2=$_" . $barequery . "&amp;f=h\">colored</A>)\n";
2025                 }
2026             }
2027             #
2028             # Plus, if it's on a branch, and it's not a vendor branch,
2029             # offer to diff with the next revision of the higher branch.
2030             # (e.g. change gets committed and then brought
2031             # over to -stable)
2032             if (/^\d+\.\d+\.\d+/ && !/^1\.1\.1\.\d+$/) {
2033                 my ($i,$nextmain);
2034                 for ($i = 0; $i < $#revorder && $revorder[$i] ne $_; $i++){}
2035                 my (@tmp2) = split(/\./, $_);
2036                 for ($nextmain = ""; $i > 0; $i--) {
2037                     my ($next) = $revorder[$i-1];
2038                     my (@tmp1) = split(/\./, $next);
2039                     if ($#tmp1 < $#tmp2) {
2040                         $nextmain = $next;
2041                         last;
2042                     }
2043                     # Only the highest version on a branch should have
2044                     # a diff for the "next main".
2045                     last if ($#tmp1 == $#tmp2 && join(".",@tmp1[0..$#tmp1-1])
2046                              eq join(".",@tmp2[0..$#tmp1-1]));
2047                 }
2048                 if (!defined($diffrev{$nextmain})) {
2049                     $diffrev{$nextmain} = 1;
2050                     print " next main <A HREF=\"${scriptwhere}.diff?r1=$nextmain";
2051                     print "&amp;r2=$_" . $barequery .
2052                         "\">$nextmain</A>\n";
2053                     if (!$hr_default) { # offer a human readable version if not default
2054                         print "(<A HREF=\"${scriptwhere}.diff?r1=$nextmain";
2055                         print "&amp;r2=$_" . $barequery .
2056                             "&amp;f=h\">colored</A>)\n";
2057                     }
2058                 }
2059             }
2060             # Plus if user has selected only r1, then present a link
2061             # to make a diff to that revision
2062             if (defined($input{"r1"}) && !defined($diffrev{$input{"r1"}})) {
2063                 $diffrev{$input{"r1"}} = 1;
2064                 print " to selected <A HREF=\"${scriptwhere}.diff?"
2065                         . "r1=$input{'r1'}&amp;r2=$_" . $barequery
2066                         . "\">$input{'r1'}</A>\n";
2067                 if (!$hr_default) { # offer a human readable version if not default
2068                     print "(<A HREF=\"${scriptwhere}.diff?r1=$input{'r1'}";
2069                     print "&amp;r2=$_" . $barequery .
2070                         "&amp;f=h\">colored</A>)\n";
2071
2072                 }
2073             }
2074         }
2075         print "<PRE>\n";
2076         print &htmlify($log{$_});
2077         print "</PRE>\n";
2078 }
2079
2080 sub doLog($) {
2081         my($fullname) = @_;
2082         my ($diffrev, $upwhere, $filename, $backurl);
2083
2084         readLog($fullname);
2085
2086         html_header("CVS log for $where");
2087         ($upwhere = $where) =~ s|(Attic/)?[^/]+$||;
2088         ($filename = $where) =~ s|^.*/||;
2089         $backurl = $scriptname . "/" . urlencode($upwhere) . $query;
2090         print &link($backicon, "$backurl#$filename"),
2091               " <b>Up to ", &clickablePath($upwhere, 1), "</b><p>\n";
2092         print "<A HREF=\"#diff\">Request diff between arbitrary revisions</A>\n";
2093         print "<HR NOSHADE>\n";
2094         if ($curbranch) {
2095             print "Default branch: ";
2096             print ($revsym{$curbranch} || $curbranch);
2097         }
2098         else {
2099             print "No default branch";
2100         }
2101         print "<BR>\n";
2102         if ($input{only_with_tag}) {
2103             print "Current tag: $input{only_with_tag}<BR>\n";
2104         }
2105
2106         undef %nameprinted;
2107
2108         for (my $i = 0; $i <= $#revdisplayorder; $i++) {
2109             print "<HR size=1 NOSHADE>";
2110             printLog($revdisplayorder[$i]);
2111         }
2112
2113         print "<HR NOSHADE>";
2114         print "<A NAME=diff>\n";
2115         print "This form allows you to request diff's between any two\n";
2116         print "revisions of a file.  You may select a symbolic revision\n";
2117         print "name using the selection box or you may type in a numeric\n";
2118         print "name using the type-in text box.\n";
2119         print "</A><P>\n";
2120         print "<FORM METHOD=\"GET\" ACTION=\"${scriptwhere}.diff\" NAME=\"diff_select\">\n";
2121         foreach (@stickyvars) {
2122             print "<INPUT TYPE=HIDDEN NAME=\"$_\" VALUE=\"$input{$_}\">\n"
2123                 if (defined($input{$_})
2124                     && ((!defined($DEFAULTVALUE{$_})
2125                          || $input{$_} ne $DEFAULTVALUE{$_})
2126                         && $input{$_} ne ""));
2127         }
2128         print "Diffs between \n";
2129         print "<SELECT NAME=\"r1\">\n";
2130         print "<OPTION VALUE=\"text\" SELECTED>Use Text Field\n";
2131         print $sel;
2132         print "</SELECT>\n";
2133         $diffrev = $revdisplayorder[$#revdisplayorder];
2134         $diffrev = $input{"r1"} if (defined($input{"r1"}));
2135         print "<INPUT TYPE=\"TEXT\" SIZE=\"$inputTextSize\" NAME=\"tr1\" VALUE=\"$diffrev\" onChange='document.diff_select.r1.selectedIndex=0'>\n";
2136         print " and \n";
2137         print "<SELECT NAME=\"r2\">\n";
2138         print "<OPTION VALUE=\"text\" SELECTED>Use Text Field\n";
2139         print $sel;
2140         print "</SELECT>\n";
2141         $diffrev = $revdisplayorder[0];
2142         $diffrev = $input{"r2"} if (defined($input{"r2"}));
2143         print "<INPUT TYPE=\"TEXT\" SIZE=\"$inputTextSize\" NAME=\"tr2\" VALUE=\"$diffrev\" onChange='document.diff_select.r2.selectedIndex=0'>\n";
2144         print "<BR>Type of Diff should be a&nbsp;";
2145         printDiffSelect(0);
2146         print "<INPUT TYPE=SUBMIT VALUE=\"  Get Diffs  \">\n";
2147         print "</FORM>\n";
2148         print "<HR noshade>\n";
2149         if (@branchnames) {
2150             print "<A name=branch></A>\n";
2151             print "<FORM METHOD=\"GET\" ACTION=\"$scriptwhere\">\n";
2152             foreach (@stickyvars) {
2153                 next if ($_ eq "only_with_tag");
2154                 next if ($_ eq "logsort");
2155                 print "<INPUT TYPE=HIDDEN NAME=\"$_\" VALUE=\"$input{$_}\">\n"
2156                     if (defined($input{$_})
2157                         && (!defined($DEFAULTVALUE{$_})
2158                             || $input{$_} ne $DEFAULTVALUE{$_})
2159                         && $input{$_} ne "");
2160             }
2161             print "View only Branch: \n";
2162             print "<SELECT NAME=\"only_with_tag\"";
2163             print " onchange=\"submit()\"" if ($use_java_script);
2164             print ">\n";
2165             print "<OPTION VALUE=\"\"";
2166             print " SELECTED" if (defined($input{"only_with_tag"}) &&
2167                 $input{"only_with_tag"} eq "");
2168             print ">Show all branches\n";
2169             foreach (reverse sort @branchnames) {
2170                 print "<OPTION";
2171                 print " SELECTED" if (defined($input{"only_with_tag"})
2172                         && $input{"only_with_tag"} eq $_);
2173                 print ">${_}\n";
2174             }
2175             print "</SELECT>\n";
2176             print "<INPUT TYPE=SUBMIT VALUE=\"  View Branch  \">\n";
2177             print "</FORM>\n";
2178         }
2179         print "<A name=logsort></A>\n";
2180         print "<FORM METHOD=\"GET\" ACTION=\"$scriptwhere\">\n";
2181         foreach (@stickyvars) {
2182             next if ($_ eq "only_with_tag");
2183             next if ($_ eq "logsort");
2184             print "<INPUT TYPE=HIDDEN NAME=\"$_\" VALUE=\"$input{$_}\">\n"
2185                 if (defined($input{$_})
2186                     && (!defined($DEFAULTVALUE{$_})
2187                         || $input{$_} ne $DEFAULTVALUE{$_})
2188                     && $input{$_} ne "");
2189         }
2190         print "Sort log by: \n";
2191         print "<SELECT NAME=\"logsort\"";
2192         print " onchange=\"submit()\"" if ($use_java_script);
2193         print ">\n";
2194         print "<OPTION VALUE=cvs",$logsort eq "cvs" ? " SELECTED" : "", ">Not sorted";
2195         print "<OPTION VALUE=date",$logsort eq "date" ? " SELECTED" : "", ">Commit date";
2196         print "<OPTION VALUE=rev",$logsort eq "rev" ? " SELECTED" : "", ">Revision";
2197         print "</SELECT>\n";
2198         print "<INPUT TYPE=SUBMIT VALUE=\"  Sort  \">\n";
2199         print "</FORM>\n";
2200         print &html_footer;
2201         print "</BODY></HTML>\n";
2202 }
2203
2204 sub flush_diff_rows ($$$$)
2205 {
2206     my $j;
2207     my ($leftColRef,$rightColRef,$leftRow,$rightRow) = @_;
2208
2209     if (!defined($state)) {
2210         return;
2211     }
2212
2213     if ($state eq "PreChangeRemove") {          # we just got remove-lines before
2214       for ($j = 0 ; $j < $leftRow; $j++) {
2215           print  "<tr><td bgcolor=\"$diffcolorRemove\">@$leftColRef[$j]</td>";
2216           print  "<td bgcolor=\"$diffcolorEmpty\">&nbsp;</td></tr>\n";
2217       }
2218     }
2219     elsif ($state eq "PreChange") {             # state eq "PreChange"
2220       # we got removes with subsequent adds
2221       for ($j = 0; $j < $leftRow || $j < $rightRow ; $j++) {  # dump out both cols
2222           print  "<tr>";
2223           if ($j < $leftRow) {
2224               print  "<td bgcolor=\"$diffcolorChange\">@$leftColRef[$j]</td>";
2225           }
2226           else {
2227               print  "<td bgcolor=\"$diffcolorDarkChange\">&nbsp;</td>";
2228           }
2229           if ($j < $rightRow) {
2230               print  "<td bgcolor=\"$diffcolorChange\">@$rightColRef[$j]</td>";
2231           }
2232           else {
2233               print  "<td bgcolor=\"$diffcolorDarkChange\">&nbsp;</td>";
2234           }
2235           print  "</tr>\n";
2236       }
2237     }
2238 }
2239
2240 ##
2241 # Function to generate Human readable diff-files
2242 # human_readable_diff(String revision_to_return_to);
2243 ##
2244 sub human_readable_diff($){
2245   my ($i,$difftxt, $where_nd, $filename, $pathname, $scriptwhere_nd);
2246   my ($fh, $rev) = @_;
2247   my ($date1, $date2, $r1d, $r2d, $r1r, $r2r, $rev1, $rev2, $sym1, $sym2);
2248   my (@rightCol, @leftCol);
2249
2250   ($where_nd = $where) =~ s/.diff$//;
2251   ($filename = $where_nd) =~ s/^.*\///;
2252   ($pathname = $where_nd) =~ s/(Attic\/)?[^\/]*$//;
2253   ($scriptwhere_nd = $scriptwhere) =~ s/.diff$//;
2254
2255   navigateHeader ($scriptwhere_nd, $pathname, $filename, $rev, "diff");
2256
2257   # Read header to pick up read revision and date, if possible
2258   while (<$fh>) {
2259       ($r1d,$r1r) = /\t(.*)\t(.*)$/ if (/^--- /);
2260       ($r2d,$r2r) = /\t(.*)\t(.*)$/ if (/^\+\+\+ /);
2261       last if (/^\+\+\+ /);
2262   }
2263   if (defined($r1r) && $r1r =~ /^(\d+\.)+\d+$/) {
2264     $rev1 = $r1r;
2265     $date1 = $r1d;
2266   }
2267   if (defined($r2r) && $r2r =~ /^(\d+\.)+\d+$/) {
2268     $rev2 = $r2r;
2269     $date2 = $r2d;
2270   }
2271
2272   print "<h3 align=center>Diff for /$where_nd between version $rev1 and $rev2</h3>\n";
2273
2274   print "<table border=0 cellspacing=0 cellpadding=0 width=\"100%\">\n";
2275   print "<tr bgcolor=\"#ffffff\">\n";
2276   print "<th width=\"50%\" valign=TOP>";
2277   print "version $rev1";
2278   print ", $date1" if (defined($date1));
2279   print "<br>Tag: $sym1\n" if ($sym1);
2280   print "</th>\n";
2281   print "<th width=\"50%\" valign=TOP>";
2282   print "version $rev2";
2283   print ", $date2" if (defined($date2));
2284   print "<br>Tag: $sym2\n" if ($sym1);
2285   print "</th>\n";
2286
2287   my $fs = "<font face=\"$difffontface\" size=\"$difffontsize\">";
2288   my $fe = "</font>";
2289
2290   my $leftRow = 0;
2291   my $rightRow = 0;
2292   my ($oldline, $newline, $funname, $diffcode, $rest);
2293
2294   # Process diff text
2295   # The diffrows are could make excellent use of
2296   # cascading style sheets because we've to set the
2297   # font and color for each row. anyone ...?
2298   ####
2299   while (<$fh>) {
2300       $difftxt = $_;
2301
2302       if ($difftxt =~ /^@@/) {
2303           ($oldline,$newline,$funname) = $difftxt =~ /@@ \-([0-9]+).*\+([0-9]+).*@@(.*)/;
2304           print  "<tr bgcolor=\"$diffcolorHeading\"><td width=\"50%\">";
2305           print  "<table width=\"100%\" border=1 cellpadding=5><tr><td><b>Line $oldline</b>";
2306           print  "&nbsp;<font size=-1>$funname</font></td></tr></table>";
2307           print  "</td><td width=\"50%\">";
2308           print  "<table width=\"100%\" border=1 cellpadding=5><tr><td><b>Line $newline</b>";
2309           print  "&nbsp;<font size=-1>$funname</font></td></tr></table>";
2310           print  "</td>\n";
2311           $state = "dump";
2312           $leftRow = 0;
2313           $rightRow = 0;
2314       }
2315       else {
2316           ($diffcode,$rest) = $difftxt =~ /^([-+ ])(.*)/;
2317           $_ = spacedHtmlText ($rest);
2318
2319           # Add fontface, size
2320           $_ = "$fs&nbsp;$_$fe";
2321
2322           #########
2323           # little state machine to parse unified-diff output (Hen, zeller@think.de)
2324           # in order to get some nice 'ediff'-mode output
2325           # states:
2326           #  "dump"             - just dump the value
2327           #  "PreChangeRemove"  - we began with '-' .. so this could be the start of a 'change' area or just remove
2328           #  "PreChange"        - okey, we got several '-' lines and moved to '+' lines -> this is a change block
2329           ##########
2330
2331           if ($diffcode eq '+') {
2332               if ($state eq "dump") {  # 'change' never begins with '+': just dump out value
2333                   print  "<tr><td bgcolor=\"$diffcolorEmpty\">&nbsp;</td><td bgcolor=\"$diffcolorAdd\">$_</td></tr>\n";
2334               }
2335               else {                   # we got minus before
2336                   $state = "PreChange";
2337                   $rightCol[$rightRow++] = $_;
2338               }
2339           }
2340           elsif ($diffcode eq '-') {
2341               $state = "PreChangeRemove";
2342               $leftCol[$leftRow++] = $_;
2343         }
2344         else {  # empty diffcode
2345             flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;
2346               print  "<tr><td>$_</td><td>$_</td></tr>\n";
2347               $state = "dump";
2348               $leftRow = 0;
2349               $rightRow = 0;
2350           }
2351       }
2352   }
2353   flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;
2354
2355   # state is empty if we didn't have any change
2356   if (!$state) {
2357       print "<tr><td colspan=2>&nbsp;</td></tr>";
2358       print "<tr bgcolor=\"$diffcolorEmpty\" >";
2359       print "<td colspan=2 align=center><b>- No viewable Change -</b></td></tr>";
2360   }
2361   print  "</table>";
2362   close($fh);
2363
2364   print "<br><hr noshade width=\"100%\">\n";
2365
2366   print "<table border=0>";
2367
2368   print "<tr><td>";
2369   # print legend
2370   print "<table border=1><tr><td>";
2371   print  "Legend:<br><table border=0 cellspacing=0 cellpadding=1>\n";
2372   print  "<tr><td align=center bgcolor=\"$diffcolorRemove\">Removed from v.$rev1</td><td bgcolor=\"$diffcolorEmpty\">&nbsp;</td></tr>";
2373   print  "<tr bgcolor=\"$diffcolorChange\"><td align=center colspan=2>changed lines</td></tr>";
2374   print  "<tr><td bgcolor=\"$diffcolorEmpty\">&nbsp;</td><td align=center bgcolor=\"$diffcolorAdd\">Added in v.$rev2</td></tr>";
2375   print  "</table></td></tr></table>\n";
2376
2377   print "<td>";
2378   # Print format selector
2379   print "<FORM METHOD=\"GET\" ACTION=\"${scriptwhere}\">\n";
2380   foreach my $var (keys %input) {
2381     next if ($var eq "f");
2382     next if (defined($DEFAULTVALUE{$var})
2383              && $DEFAULTVALUE{$var} eq $input{$var});
2384     print "<INPUT TYPE=HIDDEN NAME=\"",urlencode($var),"\" VALUE=\"",
2385             urlencode($input{$var}),"\">\n";
2386   }
2387   printDiffSelect($use_java_script);
2388   print "<INPUT TYPE=SUBMIT VALUE=\"Show\">\n";
2389   print "</FORM>\n";
2390   print "</td>";
2391
2392   print "</tr></table>";
2393 }
2394
2395 sub navigateHeader ($$$$$) {
2396     my ($swhere,$path,$filename,$rev,$title) = @_;
2397     $swhere = "" if ($swhere eq $scriptwhere);
2398     $swhere = urlencode($filename) if ($swhere eq "");
2399     print "<\!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\">";
2400     print "<HTML>\n<HEAD>\n";
2401     local $charset = $config{'cvsenc'} || &get_charset();
2402     if ($charset) {
2403         print "<meta http-equiv=\"Content-Type\" content=\"text/html; Charset=$charset\">\n";
2404         }
2405     print '<!-- hennerik CVSweb $Revision: 1.112 $ -->';
2406     print "\n<TITLE>$path$filename - $title - $rev</TITLE></HEAD>\n";
2407     print  "<BODY BGCOLOR=\"$backcolor\">\n";
2408     print "<table width=\"100%\" border=0 cellspacing=0 cellpadding=1 bgcolor=\"$navigationHeaderColor\">";
2409     print "<tr valign=bottom><td>";
2410     print  "<a href=\"$swhere$query#rev$rev\">$backicon";
2411     print "</a> <b>Return to ", &link("$filename","$swhere$query#rev$rev")," CVS log";
2412     print "</b> $fileicon</td>";
2413
2414     print "<td align=right>$diricon <b>Up to ", &clickablePath($path, 1), "</b></td>";
2415     print "</tr></table>";
2416 }
2417
2418 sub plural_write ($$)
2419 {
2420     my ($num,$text) = @_;
2421     if ($num != 1) {
2422         $text = $text . "s";
2423     }
2424     if ($num > 0) {
2425         return $num . " " . $text;
2426     }
2427     else {
2428         return "";
2429     }
2430 }
2431
2432 ##
2433 # print readable timestamp in terms of
2434 # '..time ago'
2435 # H. Zeller <zeller@think.de>
2436 ##
2437 sub readableTime($$) {
2438     my ($i, $break, $retval);
2439     my ($secs,$long) = @_;
2440
2441     # this function works correct for time >= 2 seconds
2442     if ($secs < 2) {
2443         return "very little time";
2444     }
2445
2446     my %desc = (1 , 'second',
2447                    60, 'minute',
2448                    3600, 'hour',
2449                    86400, 'day',
2450                    604800, 'week',
2451                    2628000, 'month',
2452                    31536000, 'year');
2453     my @breaks = sort {$a <=> $b} keys %desc;
2454     $i = 0;
2455     while ($i <= $#breaks && $secs >= 2 * $breaks[$i]) {
2456         $i++;
2457     }
2458     $i--;
2459     $break = $breaks[$i];
2460     $retval = plural_write(int ($secs / $break), $desc{"$break"});
2461
2462     if ($long == 1 && $i > 0) {
2463         my $rest = $secs % $break;
2464         $i--;
2465         $break = $breaks[$i];
2466         my $resttime = plural_write(int ($rest / $break),
2467                                 $desc{"$break"});
2468         if ($resttime) {
2469             $retval = $retval . ", " . $resttime;
2470         }
2471     }
2472
2473     return $retval;
2474 }
2475
2476 ##
2477 # clickablePath(String pathname, boolean last_item_clickable)
2478 #
2479 # returns a html-ified path whereas each directory is a link for
2480 # faster navigation. last_item_clickable controls whether the
2481 # basename (last directory/file) is a link as well
2482 ##
2483 sub clickablePath($$) {
2484     my ($pathname,$clickLast) = @_;
2485     my $retval = '';
2486
2487     if ($pathname eq '/') {
2488         # this should never happen - chooseCVSRoot() is
2489         # intended to do this
2490         $retval = "[$cvstree]";
2491     }
2492     else {
2493         $retval = $retval . " <a href=\"${scriptname}/${query}#dirlist\">[$cvstree]</a>";
2494         my $wherepath = '';
2495         my ($lastslash) = $pathname =~ m|/$|;
2496         foreach (split(/\//, $pathname)) {
2497             $retval = $retval . " / ";
2498             $wherepath = $wherepath . '/' . $_;
2499             my ($last) = "$wherepath/" eq "/$pathname"
2500                 || "$wherepath" eq "/$pathname";
2501             if ($clickLast || !$last) {
2502                 $retval = $retval . "<a href=\"${scriptname}"
2503                     . urlencode($wherepath)
2504                     . (!$last || $lastslash ? '/' : '')
2505                     . ${query}
2506                     . (!$last || $lastslash ? "#dirlist" : "")
2507                     . "\">$_</a>";
2508             }
2509             else { # do not make a link to the current dir
2510                 $retval = $retval .  $_;
2511             }
2512         }
2513     }
2514     return $retval;
2515 }
2516
2517 sub chooseCVSRoot() {
2518     my @foo;
2519     foreach (sort keys %CVSROOT) {
2520         if (-d $CVSROOT{$_}) {
2521             push(@foo, $_);
2522         }
2523     }
2524     if (@foo > 1) {
2525         my ($k);
2526         print "<form method=\"GET\" action=\"${scriptwhere}\">\n";
2527         foreach $k (keys %input) {
2528             print "<input type=hidden NAME=$k VALUE=$input{$k}>\n"
2529                 if ($input{$k}) && ($k ne "cvsroot");
2530         }
2531         # Form-Elements look wierd in Netscape if the background
2532         # isn't gray and the form elements are not placed
2533         # within a table ...
2534         print "<table><tr>";
2535         print "<td>CVS Root:</td>";
2536         print "<td>\n<select name=\"cvsroot\"";
2537         print " onchange=\"submit()\"" if ($use_java_script);
2538         print ">\n";
2539         foreach $k (@foo) {
2540             print "<option value=\"$k\"";
2541             print " selected" if ("$k" eq "$cvstree");
2542             print ">" . ($CVSROOTdescr{"$k"} ? $CVSROOTdescr{"$k"} :
2543                         $k). "</option>\n";
2544         }
2545         print "</select>\n</td>";
2546         print "<td><input type=submit value=\"Go\"></td>";
2547         print "</tr></table></form>";
2548     }
2549     else {
2550         # no choice ..
2551         print "CVS Root: <b>[$cvstree]</b>";
2552     }
2553 }
2554
2555 sub chooseMirror() {
2556     my ($mirror,$moremirrors);
2557     $moremirrors = 0;
2558     # This code comes from the original BSD-cvsweb
2559     # and may not be useful for your site; If you don't
2560     # set %MIRRORS this won't show up, anyway
2561     #
2562     # Should perhaps exlude the current site somehow..
2563     if (keys %MIRRORS) {
2564         print "\nThis cvsweb is mirrored in:\n";
2565         foreach $mirror (keys %MIRRORS) {
2566             print ", " if ($moremirrors);
2567             print qq(<a href="$MIRRORS{$mirror}">$mirror</A>\n);
2568             $moremirrors = 1;
2569         }
2570         print "<p>\n";
2571     }
2572 }
2573
2574 sub fileSortCmp() {
2575     my ($comp) = 0;
2576     my ($c,$d,$af,$bf);
2577
2578     ($af = $a) =~ s/,v$//;
2579     ($bf = $b) =~ s/,v$//;
2580     my ($rev1,$date1,$log1,$author1,$filename1) = @{$fileinfo{$af}}
2581         if (defined($fileinfo{$af}));
2582     my ($rev2,$date2,$log2,$author2,$filename2) = @{$fileinfo{$bf}}
2583         if (defined($fileinfo{$bf}));
2584
2585     if (defined($filename1) && defined($filename2) && $af eq $filename1 && $bf eq $filename2) {
2586         # Two files
2587         $comp = -revcmp($rev1, $rev2) if ($byrev && $rev1 && $rev2);
2588         $comp = ($date2 <=> $date1) if ($bydate && $date1 && $date2);
2589         $comp = ($log1 cmp $log2) if ($bylog && $log1 && $log2);
2590         $comp = ($author1 cmp $author2) if ($byauthor && $author1 && $author2);
2591     }
2592     if ($comp == 0) {
2593         # Directories first, then sorted on name if no other sort critera
2594         # available.
2595         my $ad = ((-d "$fullname/$a")?"D":"F");
2596         my $bd = ((-d "$fullname/$b")?"D":"F");
2597         ($c=$a) =~ s|.*/||;
2598         ($d=$b) =~ s|.*/||;
2599         $comp = ("$ad$c" cmp "$bd$d");
2600     }
2601     return $comp;
2602 }
2603
2604 # make A url for downloading
2605 sub download_url($$$) {
2606     my ($url,$revision,$mimetype) = @_;
2607
2608     $revision =~ s/\.0\././;
2609
2610     if (defined($checkout_magic)
2611         && (!defined($mimetype) || $mimetype ne "text/x-cvsweb-markup")) {
2612         my ($path);
2613         ($path = $where) =~ s|/[^/]*$|/|;
2614         $url = "$scriptname/$checkoutMagic/${path}$url";
2615     }
2616     $url .= "?rev=$revision";
2617     $url .= "&amp;content-type=$mimetype" if (defined($mimetype));
2618
2619     return $url;
2620 }
2621
2622 # Presents a link to download the
2623 # selected revision
2624 sub download_link($$$$) {
2625     my ($url,$revision,$textlink,$mimetype) = @_;
2626     my ($fullurl) = download_url($url,$revision,$mimetype);
2627     my ($paren) = $textlink =~ /^\(/;
2628     $textlink =~ s/^\(// if ($paren);
2629     $textlink =~ s/\)$// if ($paren);
2630     print "(" if ($paren);
2631     print "<A HREF=\"$fullurl";
2632     print $barequery;
2633     print "\"";
2634     if ($open_extern_window && (!defined($mimetype) || $mimetype ne "text/x-cvsweb-markup")) {
2635         print " target=\"cvs_checkout\"";
2636         # we should have
2637         #   'if (document.cvswin==null) document.cvswin=window.open(...'
2638         # in order to allow the user to resize the window; otherwise
2639         # the user may resize the window, but on next checkout - zap -
2640         # its original (configured s. cvsweb.conf) size is back again
2641         # .. annoying (if $extern_window_(width|height) is defined)
2642         # but this if (..) solution is far from perfect
2643         # what we need to do as well is
2644         # 1) save cvswin in an invisible frame that always exists
2645         #    (document.cvswin will be void on next load)
2646         # 2) on close of the cvs_checkout - window set the cvswin
2647         #    variable to 'null' again - so that it will be
2648         #    reopenend with the configured size
2649         # anyone a JavaScript programmer ?
2650         # .. so here without if (..):
2651         # currently, the best way is to comment out the size parameters
2652         # ($extern_window...) in cvsweb.conf.
2653         if ($use_java_script) {
2654             print " onClick=\"window.open('$fullurl','cvs_checkout',";
2655             print "'resizeable,scrollbars";
2656             print ",status,toolbar" if (defined($mimetype)
2657                 && $mimetype eq "text/html");
2658             print ",width=$extern_window_width" if (defined($extern_window_width));
2659             print ",height=$extern_window_height" if (defined($extern_window_height));
2660             print"');\"";
2661         }
2662     }
2663     print "><b>$textlink</b></A>";
2664     print ")" if ($paren);
2665 }
2666
2667 # Returns a Query string with the
2668 # specified parameter toggled
2669 sub toggleQuery($$) {
2670     my ($toggle,$value) = @_;
2671     my ($newquery,$var);
2672     my (%vars);
2673     %vars = %input;
2674     if (defined($value)) {
2675         $vars{$toggle} = $value;
2676     }
2677     else {
2678         $vars{$toggle} = $vars{$toggle} ? 0 : 1;
2679     }
2680     # Build a new query of non-default paramenters
2681     $newquery = "";
2682     foreach $var (@stickyvars) {
2683         my ($value) = defined($vars{$var}) ? $vars{$var} : "";
2684         my ($default) = defined($DEFAULTVALUE{$var}) ? $DEFAULTVALUE{$var} : "";
2685         if ($value ne $default) {
2686             $newquery .= "&amp;" if ($newquery ne "");
2687             $newquery .= urlencode($var) . "=" . urlencode($value);
2688         }
2689     }
2690     if ($newquery) {
2691         return '?' . $newquery;
2692     }
2693     return "";
2694 }
2695
2696 sub urlencode($) {
2697     my ($in) = @_;
2698     my ($out);
2699     ($out = $in) =~ s/([\000-+{-\377])/sprintf("%%%02x", ord($1))/ge;
2700     return $out;
2701 }
2702
2703 sub http_header(;$) {
2704     my $content_type = shift || "text/html";
2705     my $is_mod_perl = defined($ENV{'MOD_PERL'});
2706     if (defined($moddate)) {
2707         if ($is_mod_perl) {
2708             Apache->request->header_out("Last-Modified" => scalar gmtime($moddate) . " GMT");
2709         }
2710         else {
2711             print "Last-Modified: " . scalar gmtime($moddate) . " GMT\r\n";
2712         }
2713     }
2714     if ($is_mod_perl) {
2715         Apache->request->content_type($content_type);
2716     }
2717     else {
2718             print "Content-type: $content_type\r\n";
2719     }
2720     if ($allow_compress && $maycompress) {
2721         if ($has_zlib || (defined($GZIPBIN) && open(GZIP, "|$GZIPBIN -1 -c"))) {
2722             if ($is_mod_perl) {
2723                     Apache->request->content_encoding("x-gzip");
2724                     Apache->request->header_out(Vary => "Accept-Encoding");
2725                     Apache->request->send_http_header;
2726             }
2727             else {
2728                     print "Content-encoding: x-gzip\r\n";
2729                     print "Vary: Accept-Encoding\r\n";  #RFC 2068, 14.43
2730                     print "\r\n"; # Close headers
2731             }
2732             $| = 1; $| = 0; # Flush header output
2733             if ($has_zlib) {
2734                 tie *GZIP, __PACKAGE__, \*STDOUT;
2735             }
2736             select(GZIP);
2737             $gzip_open = 1;
2738 #           print "<!-- gzipped -->" if ($content_type eq "text/html");
2739         }
2740         else {
2741             if ($is_mod_perl) {
2742                     Apache->request->send_http_header;
2743             }
2744             else {
2745                     print "\r\n"; # Close headers
2746             }
2747             print "<font size=-1>Unable to find gzip binary in the \$PATH to compress output</font><br>";
2748         }
2749     }
2750     else {
2751             if ($is_mod_perl) {
2752                     Apache->request->send_http_header;
2753             }
2754             else {
2755                     print "\r\n"; # Close headers
2756             }
2757     }
2758 }
2759
2760 sub html_header($) {
2761     &ui_print_header(undef, $text{'cvsweb_title'}, "");
2762 #   if (!&has_command("rlog")) {
2763 #       print "<p>",&text('cvsweb_ecmd', "<tt>rlog</tt>"),"<p>\n";
2764 #       &ui_print_footer("", $text{'index_return'});
2765 #       exit;
2766 #       }
2767     if (!&has_command("rlog")) {
2768         $no_rlog++;
2769         }
2770     return;
2771 }
2772
2773 sub html_footer() {
2774     &ui_print_footer("", $text{'index_return'});
2775     return undef;
2776 }
2777
2778 sub link_tags($)
2779 {
2780     my ($tags) = @_;
2781     my ($ret) = "";
2782     my ($fileurl,$filename);
2783
2784     ($filename = $where) =~ s/^.*\///;
2785     $fileurl = urlencode($filename);
2786
2787     foreach my $sym (split(", ", $tags)) {
2788         $ret .= ",\n" if ($ret ne "");
2789         $ret .= "<A HREF=\"$fileurl"
2790                 . toggleQuery('only_with_tag',$sym) . "\">$sym</A>";
2791     }
2792     return $ret."\n";
2793 }
2794
2795 #
2796 # See if a module is listed in the config file's @HideModule list.
2797 #
2798 sub forbidden_module($) {
2799     my($module) = @_;
2800     return checkForbidden($module, @HideModules);
2801 }
2802
2803 sub forbidden_file($) {
2804     my($file) = @_;
2805     $file =~ s|^.*/||;
2806     return checkForbidden($file, @DissallowRead);
2807 }
2808
2809 sub checkForbidden($@) {
2810     my($item, @list) = @_;
2811     for (my $i=0; $i < @list; $i++) {
2812         return 1 if $item =~ $list[$i];
2813     }
2814     return 0;
2815 }
2816
2817 # Close the GZIP handle remove the tie.
2818
2819 sub gzipclose() {
2820         if ($gzip_open) {
2821             select(STDOUT);
2822             close(GZIP);
2823             untie *GZIP;
2824             $gzip_open = 0;
2825         }
2826 }
2827
2828 # implement a gzipped file handle via the Compress:Zlib compression
2829 # library.
2830
2831 sub MAGIC1() { 0x1f }
2832 sub MAGIC2() { 0x8b }
2833 sub OSCODE() { 3    }
2834
2835 sub TIEHANDLE {
2836         my ($class, $out) = @_;
2837         my ($d) = Compress::Zlib::deflateInit(-Level => Compress::Zlib::Z_BEST_COMPRESSION(),
2838                 -WindowBits => -Compress::Zlib::MAX_WBITS()) or return undef;
2839         my ($o) = {
2840                 handle => $out,
2841                 dh => $d,
2842                 crc => 0,
2843                 len => 0,
2844         };
2845         my ($header) = pack("c10", MAGIC1, MAGIC2, Compress::Zlib::Z_DEFLATED(), 0,0,0,0,0,0, OSCODE);
2846         print {$o->{handle}} $header;
2847         return bless($o, $class);
2848 }
2849
2850 sub PRINT {
2851         my ($o) = shift;
2852         my ($buf) = join(defined $, ? $, : "",@_);
2853         my ($len) = length($buf);
2854         my ($compressed, $status) = $o->{dh}->deflate($buf);
2855         print {$o->{handle}} $compressed if defined($compressed);
2856         $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});
2857         $o->{len} += $len;
2858         return $len;
2859 }
2860
2861 sub PRINTF {
2862         my ($o) = shift;
2863         my ($fmt) = shift;
2864         my ($buf) = sprintf($fmt, @_);
2865         my ($len) = length($buf);
2866         my ($compressed, $status) = $o->{dh}->deflate($buf);
2867         print {$o->{handle}} $compressed if defined($compressed);
2868         $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});
2869         $o->{len} += $len;
2870         return $len;
2871 }
2872
2873 sub WRITE {
2874         my ($o, $buf, $len, $off) = @_;
2875         my ($compressed, $status) = $o->{dh}->deflate(substr($buf, 0, $len));
2876         print {$o->{handle}} $compressed if defined($compressed);
2877         $o->{crc} = Compress::Zlib::crc32(substr($buf, 0, $len), $o->{crc});
2878         $o->{len} += $len;
2879         return $len;
2880 }
2881
2882 sub CLOSE {
2883         my ($o) = @_;
2884         return if !defined( $o->{dh});
2885         my ($buf) = $o->{dh}->flush();
2886         $buf .= pack("V V", $o->{crc}, $o->{len});
2887         print {$o->{handle}} $buf;
2888         undef $o->{dh};
2889 }
2890
2891 sub DESTROY {
2892         my ($o) = @_;
2893         CLOSE($o);
2894 }