[BACK]Return to cvsweb.cgi CVS log [TXT][DIR] Up to [cvsweb.bsd.lv] / cvsweb

Diff for /cvsweb/cvsweb.cgi between version 3.3 and 4.10

version 3.3, 2000/07/27 16:16:41 version 4.10, 2019/11/09 10:18:09
Line 1 
Line 1 
 #!/usr/bin/perl -ws  #!/usr/bin/perl
   # $Id$
   # $knu: cvsweb.cgi,v 1.299 2010/11/13 16:37:18 simon
 #  #
 # cvsweb - a CGI interface to CVS trees.  # cvsweb - a CGI interface to CVS trees.
 #  #
 # Written in their spare time by  # Written in their spare time by
 #             Bill Fenner      <fenner@FreeBSD.org>   (original work)  #             Bill Fenner          <fenner@FreeBSD.org>   (original work)
 # extended by Henner Zeller    <zeller@think.de>,  # extended by Henner Zeller        <zeller@think.de>,
 #             Henrik Nordstrom <hno@hem.passagen.se>  #             Henrik Nordstrom     <hno@hem.passagen.se>
 #             Ken Coar         <coar@Apache.Org>  #             Ken Coar             <coar@Apache.Org>
 #             Dick Balaska     <dick@buckosoft.com>  #             Dick Balaska         <dick@buckosoft.com>
 #             Akinori MUSHA    <knu@FreeBSD.org>  #             Akinori MUSHA        <knu@FreeBSD.org>
   #             Jens-Uwe Mager       <jum@helios.de>
   #             Ville Skyttä         <scop@FreeBSD.org>
   #             Vassilii Khachaturov <vassilii@tarunz.org>
 #  #
 # Based on:  # Based on:
 # * Bill Fenners cvsweb.cgi revision 1.28 available from:  # * Bill Fenners cvsweb.cgi revision 1.28 available from:
 #   http://www.freebsd.org/cgi/cvsweb.cgi/www/en/cgi/cvsweb.cgi  #   http://www.FreeBSD.org/cgi/cvsweb.cgi/www/en/cgi/cvsweb.cgi
 #  #
 # Copyright (c) 1996-1998 Bill Fenner  # Copyright (c) 1996-1998 Bill Fenner
 #           (c) 1998-1999 Henner Zeller  #           (c) 1998-1999 Henner Zeller
 #           (c) 1999      Henrik Nordstrom  #           (c) 1999      Henrik Nordstrom
 #           (c) 2000      Akinori MUSHA  #           (c) 2000-2002 Akinori MUSHA
   #           (c) 2002-2005 Ville Skyttä
 # All rights reserved.  # All rights reserved.
 #  #
 # Redistribution and use in source and binary forms, with or without  # Redistribution and use in source and binary forms, with or without
Line 40 
Line 46 
 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY  # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF  # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 # SUCH DAMAGE.  # SUCH DAMAGE.
 #  
 # $Id$  
 #  
 ###  
   
   require 5.006;
   
 use strict;  use strict;
   use warnings;
   use filetest qw(access);
   
 use vars qw (  use vars qw (
     $config $allow_version_select $verbose    $VERSION $CheckoutMagic $MimeTypes $DEBUG
     %CVSROOT %CVSROOTdescr %MIRRORS %DEFAULTVALUE %ICONS %MTYPES    $config $allow_version_select
     %alltags @tabcolors %fileinfo %tags @branchnames %nameprinted    @CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr
     %symrev %revsym @allrevisions %date %author @revdisplayorder    %MIRRORS %DEFAULTVALUE %ICONS %MTYPES
     @revisions %state %difflines %log %branchpoint @revorder $prcgi    %DIFF_COMMANDS @DIFFTYPES %DIFFTYPES @LOGSORTKEYS %LOGSORTKEYS
     @prcategories $prcategories    %alltags %fileinfo %tags @branchnames %nameprinted
     $checkoutMagic $doCheckout $scriptname $scriptwhere    %symrev %revsym @allrevisions %date %author @revdisplayorder
     $where $pathinfo $Browser $nofilelinks $maycompress @stickyvars    @revisions %state %difflines %log %branchpoint @revorder $keywordsubstitution
     %funcline_regexp $is_mod_perl    $prcgi @prcategories $re_prcategories $prkeyword $re_prkeyword $mancgi
     $is_lynx $is_msie $is_mozilla3    $doCheckout $scriptname $scriptwhere
     %input $query $barequery $sortby $bydate $byrev $byauthor    $where $Browser $nofilelinks $maycompress @stickyvars
     $bylog $byfile $hr_default $logsort $cvstree $cvsroot    $is_links $is_lynx $is_w3m $is_msie $is_mozilla3 $is_textbased
     $mimetype $defaultTextPlain $defaultViewable $allow_compress    %input $query $barequery $sortby $bydate $byrev $byauthor
     $GZIPBIN $backicon $diricon $fileicon $fullname $newname    $bylog $byfile $defaultDiffType $logsort $cvstree $cvsroot
     $cvstreedefault $body_tag $logo $defaulttitle $address    $charset $output_filter
     $backcolor $long_intro $short_instruction $shortLogLen    @command_path %CMD $allow_compress $backicon $diricon $fileicon $graphicon
     $show_author $dirtable $tablepadding $columnHeaderColorDefault    $fullname $cvstreedefault $logo $defaulttitle $address $binfileicon
     $columnHeaderColorSorted $hr_breakable $showfunc $hr_ignwhite    $long_intro $short_instruction $shortLogLen $show_author
     $hr_ignkeysubst $diffcolorHeading $diffcolorEmpty $diffcolorRemove    $tablepadding $hr_breakable $showfunc $hr_ignwhite $hr_ignkeysubst
     $diffcolorChange $diffcolorAdd $diffcolorDarkChange $difffontface    $inputTextSize $mime_types $allow_annotate $allow_markup $allow_mailtos
     $difffontsize $inputTextSize $mime_types $allow_annotate    $allow_log_extra $allow_dir_extra $allow_source_extra
     $allow_markup $use_java_script $open_extern_window    $allow_cvsgraph $cvsgraph_config $use_java_script $edit_option_form
     $extern_window_width $extern_window_height $edit_option_form    $show_subdir_lastmod $show_log_in_markup $preformat_in_markup
     $checkout_magic $show_subdir_lastmod $show_log_in_markup $v    $tabstop $state $annTable $sel @ForbiddenFiles
     $navigationHeaderColor $tableBorderColor $markupLogColor    $use_descriptions %descriptions @mytz $dwhere
     $tabstop $state $annTable $sel $curbranch @HideModules    $use_moddate $gzip_open $file_list_len
     $module $use_descriptions %descriptions @mytz $dwhere $moddate    $allow_tar @tar_options @gzip_options @zip_options @cvs_options
     $use_moddate    @annotate_options @rcsdiff_options
     $HTML_DOCTYPE $HTML_META $cssurl $CSS $cvshistory_url
     $allow_enscript @enscript_options %enscript_types
 );  );
   
 ##### Start of Configuration Area ########  use Cwd                   qw(abs_path);
 # == EDIT this ==  use File::Path            qw(rmtree);
 # User configuration is stored in  use File::Spec::Functions qw(canonpath catdir catfile curdir devnull rootdir
 $config = defined($ENV{CVSWEB_CONFIG}) ? $ENV{CVSWEB_CONFIG} : '/usr/local/etc/cvsweb.conf';                               tmpdir updir);
   use File::Temp            qw(tempdir tempfile);
   use IPC::Run              qw();
   use Time::Local           qw(timegm);
   use URI::Escape           qw(uri_escape uri_unescape);
   
 # == Configuration defaults ==  use constant VALID_PATH   => qr/^([[:^cntrl:]]+)$/o;
 # Defaults for configuration variables that shouldn't need  use constant VALID_TAG1   => qr/^([a-zA-Z][[:graph:]]*)$/o;
 # to be configured..  use constant VALID_TAG2   => qr/^([^\$,.:;@]+)$/o;
 $allow_version_select = 1;  use constant CVSWEBMARKUP => qr{^text/(x-cvsweb|vnd\.viewcvs)-markup$}io;
   use constant LOG_FILESEPR => qr/^={77}$/o;
   use constant LOG_REVSEPR  => qr/^-{28}$/o;
   
 ##### End of Configuration Area   ########  use constant HAS_ZLIB     => eval { require Compress::Zlib; };
   use constant HAS_EDIFF    => eval { require String::Ediff;  };
   
 ######## Configuration variables #########  # -----------------------------------------------------------------------------
 # These are defined to allow checking with perl -cw  
 %CVSROOT = %MIRRORS = %DEFAULTVALUE = %ICONS = %MTYPES =  
 %tags = %alltags = @tabcolors = ();  
 $cvstreedefault = $body_tag = $logo = $defaulttitle = $address =  
 $backcolor = $long_intro = $short_instruction = $shortLogLen =  
 $show_author = $dirtable = $tablepadding = $columnHeaderColorDefault =  
 $columnHeaderColorSorted = $hr_breakable = $showfunc = $hr_ignwhite =  
 $hr_ignkeysubst = $diffcolorHeading = $diffcolorEmpty = $diffcolorRemove =  
 $diffcolorChange = $diffcolorAdd = $diffcolorDarkChange = $difffontface =  
 $difffontsize = $inputTextSize = $mime_types = $allow_annotate =  
 $allow_markup = $use_java_script = $open_extern_window =  
 $extern_window_width = $extern_window_height = $edit_option_form =  
 $checkout_magic = $show_subdir_lastmod = $show_log_in_markup = $v =  
 $navigationHeaderColor = $tableBorderColor = $markupLogColor =  
 $tabstop = $use_moddate = $moddate = undef;  
   
 ##### End of configuration variables #####  # All global initialization that can be done in compile time should go to
   # the BEGIN block.  Persistent environments, such as mod_perl, will benefit
   # from this.
   
 use Time::Local;  BEGIN
 use IPC::Open2;  {
     $VERSION = '3.1';
   
 $verbose = $v;    $HTML_DOCTYPE =
 $checkoutMagic = "~checkout~";      '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" ' .
 $pathinfo = defined($ENV{PATH_INFO}) ? $ENV{PATH_INFO} : '';      '"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">';
 $where = $pathinfo;  
 $doCheckout = ($where =~ /^\/$checkoutMagic/);    $HTML_META = <<EOM;
 $where =~ s|^/($checkoutMagic)?||;  <meta name="robots" content="nofollow" />
 $where =~ s|/+$||;  <meta name="generator" content="FreeBSD-CVSweb $VERSION" />
 $scriptname = defined($ENV{SCRIPT_NAME}) ? $ENV{SCRIPT_NAME} : '';  <meta http-equiv="Content-Script-Type" content="text/javascript" />
 $scriptname =~ s|^/?|/|;  <meta http-equiv="Content-Style-Type" content="text/css" />
 $scriptname =~ s|/+$||;  EOM
 $scriptwhere = $scriptname;  
 if ($where) {    # Use MIME::Types for MIME type lookups if it's available.
     $scriptwhere .= '/' . urlencode($where);    eval {
       require MIME::Types;
       $MimeTypes = MIME::Types->new(only_complete => 1);
     };
     $MimeTypes = undef if $@;
   
     $CheckoutMagic = '~checkout~';
 }  }
   
 $is_mod_perl = defined($ENV{MOD_PERL});  # -----------------------------------------------------------------------------
   
 # in lynx, it it very annoying to have two links  sub printDiffSelect($);
 # per file, so disable the link at the icon  sub printDiffSelectStickyVars();
 # in this case:  sub getDiffLinks($$$);
 $Browser = $ENV{HTTP_USER_AGENT} || '';  sub printLogSortSelect($);
 $is_lynx = ($Browser =~ m`^Lynx/`);  sub findLastModifiedSubdirs(@);
 $is_msie = ($Browser =~ m`MSIE`);  sub htmlify_sub(&$);
 $is_mozilla3 = ($Browser =~ m`^Mozilla/[3456789]`);  sub htmlify($;$);
   sub spacedHtmlText($;$);
   sub link($$);
   sub revcmp($$);
   sub fatal($$@);
   sub config_error($$);
   sub redirect($;$);
   sub safeglob($);
   sub search_path($);
   sub getEnscriptHL($);
   sub getMimeType($;$);
   sub head($;$);
   sub scan_directives(@);
   sub openOutputFilter();
   sub doAnnotate($$);
   sub doCheckout($$$);
   sub doEnscript($$$;$);
   sub doGraph();
   sub doGraphView();
   sub cvswebMarkup($$$$$$;$);
   sub viewable($);
   sub doDiff($$$$$$);
   sub getDirLogs($$@);
   sub readLog($;$);
   sub printLog($$$;$$);
   sub doLog($);
   sub flush_diff_rows($$$$);
   sub human_readable_diff($$);
   sub navigateHeader($$$$$;$);
   sub plural_write($$);
   sub readableTime($$);
   sub clickablePath($$);
   sub chooseCVSRoot();
   sub chooseMirror();
   sub fileSortCmp();
   sub download_url($$;$);
   sub download_link($$$;$);
   sub display_url($$;$);
   sub display_link($$;$$);
   sub graph_link($;$);
   sub history_link($$;$);
   sub toggleQuery($;$);
   sub htmlquote($);
   sub htmlunquote($);
   sub uri_escape_path($);
   sub http_header(;$$);
   sub html_header($;$);
   sub html_footer();
   sub link_tags($);
   sub forbidden($);
   sub startproc(@);
   sub runproc(@);
   sub checkout_to_temp($$$);
   
 $nofilelinks = $is_lynx;  # Get rid of unsafe environment vars.  Don't do this in the BEGIN block
   # (think mod_perl)...
   delete(@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)});
   
   # Location of the configuration file inside the web server chroot:
   $config = '/conf/cvsweb/cvsweb.conf';
   
   ######## Configuration parameters #########
   
   @CVSrepositories = @CVSROOT = %CVSROOT = %MIRRORS = %DEFAULTVALUE = %ICONS =
     %MTYPES = %tags = %alltags = %fileinfo = %DIFF_COMMANDS = ();
   
   $cvstreedefault = $logo = $defaulttitle =
     $address = $long_intro = $short_instruction = $shortLogLen = $show_author =
     $tablepadding = $hr_breakable = $showfunc = $hr_ignwhite =
     $hr_ignkeysubst = $inputTextSize = $mime_types = $allow_annotate =
     $allow_markup = $allow_compress = $use_java_script = $edit_option_form =
     $show_subdir_lastmod = $show_log_in_markup = $preformat_in_markup =
     $tabstop = $use_moddate = $gzip_open = $DEBUG = $allow_cvsgraph =
     $cvsgraph_config = $cvshistory_url = $allow_tar = undef;
   
   $allow_version_select = $allow_mailtos = $allow_log_extra = 1;
   
   @DIFFTYPES = qw(h H u c);
   @DIFFTYPES{@DIFFTYPES} = (
     {
       'descr'   => 'colored',
       'opts'    => ['-u'],
       'colored' => 1,
     },
     {
       'descr'   => 'long colored',
       'opts'    => ['--unified=15'],
       'colored' => 1,
     },
     {
       'descr'   => 'unified',
       'opts'    => ['-u'],
       'colored' => 0,
     },
     {
       'descr'   => 'context',
       'opts'    => ['-c'],
       'colored' => 0,
     },
   );
   
   @LOGSORTKEYS = qw(cvs date rev);
   @LOGSORTKEYS{@LOGSORTKEYS} = (
     { descr => 'Not sorted',  },
     { descr => 'Commit date', },
     { descr => 'Revision',    },
   );
   
   ##### End of configuration parameters #####
   
   my $pathinfo = '';
   if (defined($ENV{PATH_INFO}) && $ENV{PATH_INFO} ne '') {
     ($pathinfo) = ($ENV{PATH_INFO} =~ VALID_PATH)
       or fatal('500 Internal Error',
                'Illegal PATH_INFO in environment: <code>%s</code>',
                $ENV{PATH_INFO});
   }
   if ($ENV{SCRIPT_NAME}) {
     ($scriptname) = ($ENV{SCRIPT_NAME} =~ VALID_PATH)
       or fatal('500 Internal Error',
                'Illegal SCRIPT_NAME in environment: <code>%s</code>',
                $ENV{SCRIPT_NAME});
   }
   
   $scriptname    = '' unless defined($scriptname);
   
   $where         =  $pathinfo;
   $doCheckout    =  $where =~ s|^/$CheckoutMagic/|/|o;
   $where         =~ s|^/||;
   $scriptname    =~ s|^/*|/|;
   
   # Let's workaround thttpd's stupidity..
   if ($scriptname =~ m|/$|) {
     $pathinfo .= '/';
     my $re = quotemeta $pathinfo;
     $scriptname =~ s/$re$//;
   }
   
   # $scriptname : the URI escaped path to this script
   # $where      : the path in the CVS repository (without leading /, or only /)
   # $scriptwhere: the URI escaped $scriptname + '/' + $where
   $scriptname   = uri_escape_path($scriptname);
   $scriptwhere  = join('/', $scriptname, uri_escape_path($where));
   $where        = '/' if ($where eq '');
   
   # In text-based browsers, it's very annoying to have two links per file;
   # skip linking the image for them.
   
   $Browser     = $ENV{HTTP_USER_AGENT} || '';
   $is_links    = ($Browser =~ m`^E?Links `);
   $is_lynx     = ($Browser =~ m`^Lynx/`i);
   $is_w3m      = ($Browser =~ m`^w3m/`i);
   $is_msie     = ($Browser =~ m`MSIE`);
   $is_mozilla3 = ($Browser =~ m`^Mozilla/[3-9]`);
   
   $is_textbased = ($is_links || $is_lynx || $is_w3m);
   
   $nofilelinks = $is_textbased;
   
 # newer browsers accept gzip content encoding  # newer browsers accept gzip content encoding
 # and state this in a header  # and state this in a header
 # (netscape did always but didn't state it)  # (netscape did always but didn't state it)
Line 146  $nofilelinks = $is_lynx;
Line 310  $nofilelinks = $is_lynx;
 #  braindamaged MS-Internet Exploders claim that they  #  braindamaged MS-Internet Exploders claim that they
 # accept gzip .. but don't in fact and  # accept gzip .. but don't in fact and
 # display garbage then :-/  # display garbage then :-/
 # Turn off gzip if running under mod_perl. piping does  # Turn off gzip if running under mod_perl and no zlib is available,
 # not work as expected inside the server. One can probably  # piping does not work as expected inside the server.
 # achieve the same result using Apache::GZIPFilter.  $maycompress = (
 $maycompress =(($ENV{HTTP_ACCEPT_ENCODING} =~ m`gzip`    ((defined($ENV{HTTP_ACCEPT_ENCODING})
                 || $is_mozilla3)      && $ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/)
                && !$is_msie     || $is_mozilla3)
                && !$is_mod_perl);    && !$is_msie
     && !(defined($ENV{MOD_PERL}) && !HAS_ZLIB)
   );
   
 # put here the variables we need in order  # Parameters that will be sticky in all constructed links/query strings.
 # to hold our state - they will be added (with  @stickyvars =
 # their current value) to any link/query string    qw(cvsroot hideattic ignorecase sortby logsort f only_with_tag ln
 # you construct       hidecvsroot hidenonreadable);
 @stickyvars = qw(cvsroot hideattic sortby logsort fonly_with_tag);  
   
   #
   # Load configuration.
   #
 if (-f $config) {  if (-f $config) {
     do $config;    do "$config" or config_error($config, $@);
   } else {
     fatal("500 Internal Error",
           'Configuration not found.  Set the parameter <code>$config</code> in cvsweb.cgi to your <b>cvsweb.conf</b> configuration file first.');
 }  }
 else {  
    &fatal("500 Internal Error",  # Try to find a readable dir where we can cd into.  Some abs_path()
           'Configuration not found.  Set the variable <code>$config</code> '  # implementations as well as various cvs operations require such a dir to
           . 'in cvsweb.cgi, or the environment variable '  # work properly.
           . '<code>CVSWEB_CONFIG</code>, to your <b>cvsweb.conf</b> '  {
           . 'configuration file first.');    local $^W = 0;
     for my $dir (tmpdir(), rootdir()) {
       last if (-r $dir && chdir($dir));
     }
 }  }
   
   $CSS = $cssurl ?
     sprintf("<link rel=\"stylesheet\" type=\"text/css\" href=\"%s\" />\n",
             htmlquote($cssurl)) : '';
   
   # --- input parameters
   
   my %query = ();
   if (defined($ENV{QUERY_STRING})) {
     for my $p (split(/[;&]+/, $ENV{QUERY_STRING})) {
       next unless $p;
       $p =~ y/+/ /;
       my ($key, $val) = split(/=/, $p, 2);
       next unless defined($key);
       $key = uri_unescape($key);
       $key =~ /([^a-z_12-])/ and fatal('404 Not Found',
         'Invalid character "%s" in query parameter "%s"', $1, $key);
       if (defined $val) {
         $val = uri_unescape($val);
         $val =~ /([^a-zA-Z_01-9.\/-])/ and fatal('404 Not Found',
           'Invalid character "%s" in the value "%s" of the query parameter "%s"',
           $1, $value, $key);
       } else {
         $val = 1;
       }
       $query{$key} = $val;
     }
   }
   
 undef %input;  undef %input;
 $query = $ENV{QUERY_STRING};  
   
 if ($query ne '') {  my $t;
     foreach (split(/&/, $query)) {  for my $p (qw(graph hideattic hidecvsroot hidenonreadable ignorecase ln copt
         s/%(..)/sprintf("%c", hex($1))/ge;      # unquote %-quoted                makeimage options tarball)) {
         if (/(\S+)=(.*)/) {    $t = $query{$p};
             $input{$1} = $2 if ($2 ne "");    if (defined($t)) {
         }      ($input{$p}) = ($t =~ /^([01]|on)$/)
         else {        or fatal('500 Internal Error',
             $input{$_}++;                 'Invalid boolean value: <code>%s=%s</code>', $p, $t);
         }    }
   }
   for my $p (qw(annotate r1 r2 rev tr1 tr2)) {
     $t = $query{$p};
     if (defined($t)) {
       if (($p eq 'r1' || $p eq 'r2') && $t eq 'text') {
         # Special case for the "Use text field" option in the log view diff form.
         $input{$p} = $t;
         next;
       } elsif (($p eq 'rev' || $p eq 'annotate') && ($t eq '.' || $t eq 'HEAD')){
         # Another special case, allow linking to latest revision using these.
         $input{$p} = '.';
         next;
     }      }
       my ($rev, $tag) = split(/:/, $t, 2);
       ($input{$p}) = ($rev =~ /^(\d+(?:\.\d+)*)$/)
         or fatal('500 Internal Error',
                  'Invalid revision: <code>%s=%s</code>', $p, $t);
       if (defined($tag)) {
         ($tag) = ($tag =~ VALID_TAG1)
           or fatal('500 Internal Error',
                    'Invalid tag/branch name in revision: <code>%s=%s</code>',
                    $p, $t);
         ($tag) = ($tag =~ VALID_TAG2)
           or fatal('500 Internal Error',
                    'Invalid tag/branch name in revision: <code>%s=%s</code>',
                    $p, $t);
         $input{$p} .= ':' . $tag;
       }
     }
 }  }
   $t = defined($query{only_with_tag}) ?
     $query{only_with_tag} : $query{only_on_branch}; # Backwards compatibility.
   if (defined($t)) {
     ($input{only_with_tag}) = ($t =~ VALID_TAG1)
       or fatal('500 Internal Error',
                'Invalid tag/branch name: <code>%s</code>', $t);
     ($input{only_with_tag}) = ($t =~ VALID_TAG2)
       or fatal('500 Internal Error',
                'Invalid tag/branch name: <code>%s</code>', $t);
   }
   $t = $query{logsort};
   if (defined($t)) {
     ($input{logsort}) = ($t =~ /^(cvs|date|rev)$/)
       or fatal('500 Internal Error',
                'Unsupported log sort key: <code>%s</code>', $t);
   }
   $t = $query{f};
   if (defined($t)) {
     ($input{f}) = ($t =~ /^(([hH]|[ucs]c?)|ext\d*)$/)
       or fatal('500 Internal Error',
                'Unsupported diff format: <code>%s</code>', $t);
   }
   $t = $query{sortby};
   if (defined($t)) {
     ($input{sortby}) = ($t =~ /^(file|date|rev|author|log)$/)
       or fatal('500 Internal Error',
                'Unsupported dir sort key: <code>%s</code>', $t);
   }
   $t = $query{'content-type'};
   if (defined($t)) {
     ($input{'content-type'}) = ($t =~ m|^([-0-9A-Za-z]+/[-0-9A-Za-z\.\+]+)$|)
       or fatal('500 Internal Error',
                'Unsupported content type: <code>%s</code>', $t);
   }
   $t = $query{cvsroot};
   if (defined($t)) {
     ($input{cvsroot}) = ($t =~ /^([[:print:]]+)$/)
       or fatal('500 Internal Error',
                'Invalid symbolic CVS root name: <code>%s</code>', $t);
   }
   $t = $query{path};
   if (defined($t)) {
     ($input{path}) = ($t =~ VALID_PATH)
       or fatal('500 Internal Error',
                'Invalid path: <code>%s</code>', $t);
   }
   undef($t);
   undef(%query);
   
 # For backwards compability, set only_with_tag to only_on_branch if set.  # --- end input parameters
 $input{only_with_tag} = $input{only_on_branch}  
     if (defined($input{only_on_branch}));  
   
 $DEFAULTVALUE{'cvsroot'} = $cvstreedefault;  #
   # CVS roots
   #
   my $rootfound = 0;
   for (my $i = 0; $i < scalar(@CVSrepositories); $i += 2) {
     my $key = $CVSrepositories[$i];
     my ($descr, $root) = @{$CVSrepositories[$i+1]};
     $root = canonpath($root);
     unless (-d $root) {
       warn("Root '$root' defined in \@CVSrepositories is not a directory, " .
            'entry ignored');
       next;
     }
     $rootfound ||= 1;
     $cvstreedefault = $key unless defined($cvstreedefault);
     $CVSROOTdescr{$key} = $descr;
     $CVSROOT{$key} = $root;
     push(@CVSROOT, $key);
   }
   unless ($rootfound) {
     fatal('500 Internal Error',
           'No valid CVS roots found!  See <code>@CVSrepositories</code> in ' .
           'the configuration file (<code>%s</code>).',
           $config);
   }
   undef $rootfound;
   
 foreach (keys %DEFAULTVALUE)  #
 {  # Default CVS root
     # replace not given parameters with the default parameters  #
     if (!defined($input{$_}) || $input{$_} eq "") {  if (!defined($CVSROOT{$cvstreedefault})) {
         # Empty Checkboxes in forms return -- nothing. So we define a helper    fatal("500 Internal Error",
         # variable in these forms (copt) which indicates that we just set          '<code>$cvstreedefault</code> points to a repository (%s) not ' .
         # parameters with a checkbox          'defined in <code>@CVSrepositories</code> in your configuration ' .
         if (!defined($input{"copt"})) {          'file (<code>%s</code>).',
             # 'copt' isn't defined --> empty input is not the result          $cvstreedefault,
             # of empty input checkbox --> set default          $config);
             $input{$_} = $DEFAULTVALUE{$_} if (defined($DEFAULTVALUE{$_}));  
         }  
         else {  
             # 'copt' is defined -> the result of empty input checkbox  
             # -> set to zero (disable) if default is a boolean (0|1).  
             $input{$_} = 0  
                 if (defined($DEFAULTVALUE{$_})  
                     && ($DEFAULTVALUE{$_} eq "0" || $DEFAULTVALUE{$_} eq "1"));  
         }  
     }  
 }  }
   
   $DEFAULTVALUE{cvsroot} = $cvstreedefault;
   
   while (my ($key, $defval) = each %DEFAULTVALUE) {
   
     # Replace not given parameters with defaults.
     next unless (defined($defval) && $defval =~ /\S/ && !defined($input{$key}));
   
     # Empty checkboxes in forms return nothing, so we define a helper parameter
     # in these forms (copt) which indicates that we just set parameters with a
     # checkbox.
     if ($input{copt}) {
   
       # 'copt' is set -> the result of empty input checkbox
       # -> set to zero (disable) if default is a boolean (0|1).
       $input{$key} = 0 if ($defval eq '0' || $defval eq '1');
   
     } else {
   
       # 'copt' isn't set --> empty input is not the result
       # of empty input checkbox --> set default.
       $input{$key} = $defval;
     }
   }
   
 $barequery = "";  $barequery = "";
   my @barequery;
 foreach (@stickyvars) {  foreach (@stickyvars) {
     # construct a query string with the sticky non default parameters set  
     if (defined($input{$_}) && $input{$_} ne "" && $input{$_} ne $DEFAULTVALUE{$_}) {    # construct a query string with the sticky non default parameters set
         if ($barequery) {    if (defined($input{$_})
             $barequery = $barequery . "&amp;";        && !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_}))
         }    {
         my $thisval = urlencode($_) . "=" . urlencode($input{$_});      push(@barequery, join('=', uri_escape($_), uri_escape($input{$_})));
         $barequery .= $thisval;    }
     }  
 }  }
   
   if ($allow_enscript) {
     push(@DIFFTYPES, qw(uc cc));
     @DIFFTYPES{qw(uc cc)} = (
       {
        'descr'   => 'unified, colored',
        'opts'    => ['-u'],
        'colored' => 0,
       },
       {
        'descr'   => 'context, colored',
        'opts'    => ['-c'],
        'colored' => 0,
       },
     );
   } else {
     # No Enscript -> respect difftype, but don't offer colorization.
     if ($input{f} && $input{f} =~ /^([ucs])c$/) {
       $input{f} = $1;
     }
   }
   
 # is there any query ?  # is there any query ?
 if ($barequery) {  if (@barequery) {
     $query = "?$barequery";    $barequery = join (';', @barequery);
     $barequery = "&amp;" . $barequery;    $query     = "?$barequery";
     $barequery = ";$barequery";
   } else {
     $query = "";
 }  }
 else {  undef @barequery;
     $query = "";  
   if (defined($input{path})) {
     redirect("$scriptname/$input{path}$query");
 }  }
   
 # get actual parameters  # get actual parameters
 $sortby = $input{"sortby"};  {
 $bydate = 0;    my $sortby = $input{sortby} || 'file';
 $byrev = 0;    $bydate    = 0;
 $byauthor = 0;    $byrev     = 0;
 $bylog = 0;    $byauthor  = 0;
 $byfile = 0;    $bylog     = 0;
 if ($sortby eq "date") {    $byfile    = 0;
     if ($sortby eq 'date') {
     $bydate = 1;      $bydate = 1;
 }    } elsif ($sortby eq 'rev') {
 elsif ($sortby eq "rev") {  
     $byrev = 1;      $byrev = 1;
 }    } elsif ($sortby eq 'author') {
 elsif ($sortby eq "author") {  
     $byauthor = 1;      $byauthor = 1;
 }    } elsif ($sortby eq 'log') {
 elsif ($sortby eq "log") {  
     $bylog = 1;      $bylog = 1;
 }    } else {
 else {  
     $byfile = 1;      $byfile = 1;
     }
 }  }
   
 $hr_default = $input{'f'} eq 'h';  $defaultDiffType = $input{f};
   
 $logsort = $input{'logsort'};  $logsort = $input{logsort};
   
   
 ## Default CVS-Tree  
 if (!defined($CVSROOT{$cvstreedefault})) {  
    &fatal("500 Internal Error",  
           "<code>\$cvstreedefault</code> points to a repository "  
           . "not defined in <code>%CVSROOT</code> "  
           . "(edit your configuration file $config)");  
 }  
   
 # alternate CVS-Tree, configured in cvsweb.conf  # alternate CVS-Tree, configured in cvsweb.conf
 if ($input{'cvsroot'} && $CVSROOT{$input{'cvsroot'}}) {  if ($input{cvsroot} && $CVSROOT{$input{cvsroot}}) {
     $cvstree = $input{'cvsroot'};    $cvstree = $input{cvsroot};
 } else {  } else {
     $cvstree = $cvstreedefault;    $cvstree = $cvstreedefault;
 }  }
   
 $cvsroot = $CVSROOT{$cvstree};  $cvsroot = $CVSROOT{$cvstree};
   
 # create icons out of description  # create icons out of description
 foreach my $k (keys %ICONS) {  foreach my $k (keys %ICONS) {
     no strict 'refs';    my ($itxt, $ipath, $iwidth, $iheight) = @{$ICONS{$k}};
     my ($itxt,$ipath,$iwidth,$iheight) = @{$ICONS{$k}};    no strict 'refs';
     if ($ipath) {    if ($ipath) {
         ${"${k}icon"} = "<IMG SRC=\"$ipath\" ALT=\"$itxt\" BORDER=\"0\" WIDTH=\"$iwidth\" HEIGHT=\"$iheight\">";      ${"${k}icon"} =
     }        sprintf('<img src="%s" alt="%s" border="0" width="%d" height="%d" />',
     else {                htmlquote($ipath), htmlquote($itxt), $iwidth, $iheight);
         ${"${k}icon"} = $itxt;    } else {
     }      ${"${k}icon"} = $itxt;
     }
 }  }
   
   my $config_cvstree = "$config-$cvstree";
   
 # Do some special configuration for cvstrees  # Do some special configuration for cvstrees
 do "$config-$cvstree" if (-f "$config-$cvstree");  if (-f $config_cvstree) {
     do "$config_cvstree"
       or fatal("500 Internal Error",
                'Error in loading configuration file: %s<br /><br />%s<br />',
                $config_cvstree, $@);
   }
   undef $config_cvstree;
   
 $prcategories = '(?:' . join('|', @prcategories) . ')';  $re_prcategories  = '(?:' . join ('|', @prcategories) . ')' if @prcategories;
   $re_prkeyword     = quotemeta($prkeyword) if defined($prkeyword);
   $prcgi           .= '%s' if defined($prcgi) && $prcgi !~ /%s/;
   
 $fullname = $cvsroot . '/' . $where;  $fullname         = catfile($cvsroot, $where);
 $mimetype = &getMimeTypeFromSuffix ($fullname);  
 $defaultTextPlain = ($mimetype eq "text/plain");  
 $defaultViewable = $allow_markup && viewable($mimetype);  
   
 # search for GZIP if compression allowed  my $rewrite = 0;
 # We've to find out if the GZIP-binary exists .. otherwise  if ($pathinfo =~ m|//|) {
 # ge get an Internal Server Error if we try to pipe the    $pathinfo =~ y|/|/|s;
 # output through the nonexistent gzip ..    $rewrite = 1;
 # any more elegant ways to prevent this are welcome!  
 if ($allow_compress && $maycompress) {  
     foreach (split(/:/, $ENV{PATH})) {  
         if (-x "$_/gzip") {  
             $GZIPBIN = "$_/gzip";  
             last;  
         }  
     }  
 }  }
   
 if (-d $fullname) {  if (-d $fullname) {
     #    if ($pathinfo !~ m|/$|) {
     # ensure, that directories always end with (exactly) one '/'      $pathinfo .= '/';
     # to allow relative URL's. If they're not, make a redirect.      $rewrite   = 1;
     ##    }
     if (!($pathinfo =~ m|/$|) || ($pathinfo =~ m |/{2,}$|)) {  } elsif ($pathinfo =~ m|/$|) {
         redirect ($scriptwhere . '/' . $query);    chop $pathinfo;
     }    $rewrite = 1;
     else {  
         $where .= '/';  
         $scriptwhere .= '/';  
     }  
 }  }
   if ($rewrite) {
     redirect($scriptname . uri_escape_path($pathinfo) . $query, 1);
   }
   undef $rewrite;
   
   undef $pathinfo;
   
 if (!-d $cvsroot) {  if (!-d $cvsroot) {
     &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.');    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.');
 }  }
   
 #  #
 # See if the module is in our forbidden list.  # Short-circuit forbidden things.  Note that $fullname should not change
   # after this, because the rest of the code assumes this check has already
   # been done.
 #  #
 $where =~ m:([^/]*):;  fatal('403 Forbidden', 'Access to %s forbidden.', $where)
 $module = $1;    if forbidden($fullname);
 if ($module && &forbidden_module($module)) {  
     &fatal("403 Forbidden", "Access to $where forbidden.");  #
   # Handle tarball downloads before any headers are output.
   #
   if ($input{tarball}) {
     fatal('403 Forbidden', 'Downloading tarballs is prohibited.')
       unless $allow_tar;
   
     my ($module)  =  ($where =~ m,^/?(.*),);    # untaint
     $module       =~ s,/([^/]*)$,,;
     my ($ext)     =  ($1 =~ /(\.t(?:ar\.)?gz|\.zip)$/);
     my ($basedir) =  ($module =~ m,([^/]+)$,);
   
     if ($basedir eq '' || $module eq '') {
       fatal('500 Internal Error',
             'You cannot download the top level directory.');
     }
   
     my $istar = ($ext eq '.tar.gz' || $ext eq '.tgz');
     if ($istar) {
       fatal('500 Internal Error', 'tar command not found.') unless $CMD{tar};
       fatal('500 Internal Error', 'gzip command not found.') unless $CMD{gzip};
     }
     my $iszip = ($ext eq '.zip');
     if ($iszip && !$CMD{zip}) {
       fatal('500 Internal Error', 'zip command not found.');
     }
     if (!$istar && !$iszip) {
       fatal('500 Internal Error', 'Unsupported archive type.');
     }
   
     my $tmpexportdir;
     eval {
       local $SIG{__DIE__};
       # Don't use the CLEANUP argument to tempdir() here, since we might be under
       # mod_perl (the process runs for a long time), unlink explicitly later.
       $tmpexportdir = tempdir('.cvsweb.XXXXXXXX', TMPDIR => 1);
     };
     if ($@) {
       fatal('500 Internal Error', 'Unable to make temporary directory: %s', $@);
     }
     if (!chdir($tmpexportdir)) {
       fatal('500 Internal Error',
             "Can't cd to temporary directory %s: %s", $tmpexportdir, $!);
     }
   
     my @fatal;
     my $tag = $input{only_with_tag} || 'HEAD';
     $tag = 'HEAD' if ($tag eq 'MAIN');
   
     my @cmd =
       ($CMD{cvs}, @cvs_options, '-Qd', $cvsroot, 'export', '-r', $tag,
        '-d', $basedir, $module);
     my $export_err;
     my ($errcode, $err) = runproc(\@cmd, '2>', \$export_err);
     if ($errcode) {
       @fatal =
         ('500 Internal Error',
          'Export failure (exit status %s), output: <pre>%s</pre>',
          $errcode, $err || $export_err);
   
     } else {
   
       $| = 1;    # Essential to get the buffering right.
       local (*TAR_OUT);
   
       my (@cmd, $ctype);
       if ($istar) {
         my @tar = ($CMD{tar}, @tar_options, '-cf', '-', $basedir);
         my @gzip = ($CMD{gzip}, @gzip_options, '-c');
         push(@cmd, \@tar, '|', \@gzip);
         $ctype = 'application/x-gzip';
       } elsif ($iszip) {
         my @zip = ($CMD{zip}, @zip_options, '-r', '-', $basedir);
         push(@cmd, \@zip, \'');
         $ctype = 'application/zip';
       }
       push(@cmd, '>pipe', \*TAR_OUT);
   
       my ($h, $err) = startproc(@cmd);
       if ($h) {
         print "Content-Type: $ctype\r\n\r\n";
         local $/ = undef;
         print <TAR_OUT>;
         $h->finish();
       } else {
         @fatal = ('500 Internal Error',
                   '%s failure (exit status %s), output: <pre>%s</pre>',
                   $istar ? 'Tar' : 'Zip', $? >> 8 || -1, $err);
       }
     }
   
     # Clean up.
     rmtree($tmpexportdir);
   
     &fatal(@fatal) if @fatal;
   
     exit;
 }  }
   
 ##############################  ##############################
 # View a directory  # View a directory
 ###############################  ###############################
 elsif (-d $fullname) {  if (-d $fullname) {
         my $dh = do {local(*DH);};  
         opendir($dh, $fullname) || &fatal("404 Not Found","$where: $!");  
         my @dir = readdir($dh);  
         closedir($dh);  
         my @subLevelFiles = findLastModifiedSubdirs(@dir)  
             if ($show_subdir_lastmod);  
         getDirLogs($cvsroot,$where,@subLevelFiles);  
   
         if ($where eq '/') {    my $dh = do { local (*DH); };
             html_header($defaulttitle);    opendir($dh, $fullname) or fatal("404 Not Found", '%s: %s', $where, $!);
             $long_intro =~ s/!!CVSROOTdescr!!/$CVSROOTdescr{$cvstree}/g;    my @dir = grep(!forbidden(catfile($fullname, $_)), readdir($dh));
             print $long_intro;    closedir($dh);
         }    my @subLevelFiles = findLastModifiedSubdirs(@dir) if $show_subdir_lastmod;
         else {    my @unreadable = getDirLogs($cvsroot, $where, @subLevelFiles);
             html_header($where);  
             print $short_instruction;  
         }  
   
         my $descriptions;    if ($where eq '/') {
         if (($use_descriptions) && open (DESC, "<$cvsroot/CVSROOT/descriptions")) {      html_header($defaulttitle);
             while (<DESC>) {      $long_intro =~ s/!!CVSROOTdescr!!/$CVSROOTdescr{$cvstree}/g;
                 chomp;      print $long_intro;
                 my ($dir,$description) = /(\S+)\s+(.*)/;    } else {
                 $descriptions{$dir} = $description;      html_header($where);
             }      my $html = (-f catfile($fullname, 'README.cvs.html,v') ||
         }                  -f catfile($fullname, 'Attic', 'README.cvs.html,v'));
       my $text = (!$html &&
                   (-f catfile($fullname, 'README.cvs,v') ||
                    -f catfile($fullname, 'Attic', 'README.cvs,v')));
       if ($html || $text) {
         my $rev = $input{only_with_tag} || 'HEAD';
         my $cr = abs_path($cvsroot) || $cvsroot;
         my $co = "$where/README.cvs.html" if $html;
         $co ||= "$where/README.cvs" if $text;
         # abs_path() taints when run as a CGI...
         if ($cr =~ VALID_PATH) {
           $cr = $1;
         } else {
           fatal('500 Internal Error', 'Illegal CVS root: <code>%s</code>', $cr);
         }
         my @cmd = ($CMD{cvs}, @cvs_options, '-d', $cr, 'co', '-p', "-r$rev",$co);
         local (*CVS_OUT, *CVS_ERR);
         my ($h, $err) = startproc(\@cmd, \"", '>pipe', \*CVS_OUT,
                                   '2>pipe', \*CVS_ERR);
         fatal('500 Internal Error', $err) unless $h;
         if ($html) {
           local $/ = undef;
           print <CVS_OUT>;
         } else {
           print "<p>\n";
           while (<CVS_OUT>) {
             chomp;
             print htmlquote($_), '<br />';
           }
           print "</p>";
         }
         $h->finish();
       }
       print $short_instruction;
     }
   
         print "<P><a name=\"dirlist\"></a>\n";    if ($use_descriptions &&
         # give direct access to dirs        open(DESC, catfile($cvsroot, 'CVSROOT', 'descriptions'))) {
         if ($where eq '/') {      while (<DESC>) {
             chooseMirror();        chomp;
             chooseCVSRoot();        my ($dir, $description) = /(\S+)\s+(.*)/;
         }        $descriptions{$dir} = $description;
         else {      }
             print "<p>Current directory: <b>", &clickablePath($where,0), "</b>\n";      close(DESC);
     }
   
             print "<P>Current tag: <B>", $input{only_with_tag}, "</b>\n" if    print "<p><a name=\"dirlist\"></a></p>\n";
                 $input{only_with_tag};  
   
         }    # give direct access to dirs
     if ($where eq '/') {
       chooseMirror();
       chooseCVSRoot();
   
         print "<HR NOSHADE>\n";    } else {
         # Using <MENU> in this manner violates the HTML2.0 spec but      print '<p>Current directory: <b>', clickablePath($where, 0), '</b>';
         # provides the results that I want in most browsers.  Another      if ($cvshistory_url) {
         # case of layout spooging up HTML.        (my $d = $where) =~ s|^/*(.*?)/*$|$1|;
         print ' - ', history_link($d, '');
         my $infocols = 0;      }
         if ($dirtable) {      print "</p>\n";
             if (defined($tableBorderColor)) {      print "<p>Current tag: <b>", htmlquote($input{only_with_tag}), "</b></p>\n"
                 # Can't this be done by defining the border for the inner table?        if $input{only_with_tag};
                 print "<table border=0 cellpadding=0 width=\"100%\"><tr><td bgcolor=\"$tableBorderColor\">";    }
             }  
             print "<table  width=\"100%\" border=0 cellspacing=1 cellpadding=$tablepadding>\n";  
             $infocols++;  
             print "<tr><th align=left bgcolor=\"" . (($byfile) ?  
                                                    $columnHeaderColorSorted :  
                                                    $columnHeaderColorDefault) . "\">";  
             print "<a href=\"./" . &toggleQuery("sortby","file") .  
                 "#dirlist\">" if (!$byfile);  
             print "File";  
             print "</a>" if (!$byfile);  
             print "</th>";  
             # do not display the other column-headers, if we do not have any files  
             # with revision information:  
             if (scalar(%fileinfo)) {  
                 $infocols++;  
                 print "<th align=left bgcolor=\"" . (($byrev) ?  
                                                    $columnHeaderColorSorted :  
                                                    $columnHeaderColorDefault) . "\">";  
                 print "<a href=\"./" . &toggleQuery ("sortby","rev") .  
                     "#dirlist\">" if (!$byrev);  
                 print "Rev.";  
                 print "</a>" if (!$byrev);  
                 print "</th>";  
                 $infocols++;  
                 print "<th align=left bgcolor=\"" . (($bydate) ?  
                                                    $columnHeaderColorSorted :  
                                                    $columnHeaderColorDefault) . "\">";  
                 print "<a href=\"./" . &toggleQuery ("sortby","date") .  
                     "#dirlist\">" if (!$bydate);  
                 print "Age";  
                 print "</a>" if (!$bydate);  
                 print "</th>";  
                 if ($show_author) {  
                     $infocols++;  
                     print "<th align=left bgcolor=\"" . (($byauthor) ?  
                                                    $columnHeaderColorSorted :  
                                                    $columnHeaderColorDefault) . "\">";  
                     print "<a href=\"./" . &toggleQuery ("sortby","author") .  
                             "#dirlist\">" if (!$byauthor);  
                     print "Author";  
                     print "</a>" if (!$byauthor);  
                     print "</th>";  
                 }  
                 $infocols++;  
                 print "<th align=left bgcolor=\"" . (($bylog) ?  
                                                $columnHeaderColorSorted :  
                                                $columnHeaderColorDefault) . "\">";  
                 print "<a href=\"./", toggleQuery("sortby","log"), "#dirlist\">" if (!$bylog);  
                 print "Last log entry";  
                 print "</a>" if (!$bylog);  
                 print "</th>";  
             }  
             elsif ($use_descriptions) {  
                 print "<th align=left bgcolor=\"". $columnHeaderColorDefault . "\">";  
                 print "Description";  
                 $infocols++;  
             }  
             print "</tr>\n";  
         }  
         else {  
             print "<menu>\n";  
         }  
         my $dirrow = 0;  
   
         my $i;  
         lookingforattic:  
         for ($i = 0; $i <= $#dir; $i++) {  
                 if ($dir[$i] eq "Attic") {  
                     last lookingforattic;  
                 }  
         }  
         if (!$input{'hideattic'} && ($i <= $#dir) &&  
             opendir($dh, $fullname . "/Attic")) {  
             splice(@dir, $i, 1,  
                         grep((s|^|Attic/|,!m|/\.|), readdir($dh)));  
             closedir($dh);  
         }  
   
         my $hideAtticToggleLink = "<a href=\"./" .    print "<hr />\n";
                 &toggleQuery ("hideattic") .  
                 "#dirlist\">[Hide]</a>" if (!$input{'hideattic'});  
   
         # Sort without the Attic/ pathname.    my $infocols = 1;
         # place directories first  
   
         my $attic;    printf(<<EOF, $tablepadding, 'Directory index of ' . htmlquote($where));
         my $url;  <table class="dir" width="100%%" cellspacing="0" cellpadding="%s" summary="%s">
         my $fileurl;  <tr>
         my $filesexists;  EOF
         my $filesfound;    printf('<th colspan="2"%s>', ($byfile ? ' class="sorted"' : ''));
   
         foreach (sort { &fileSortCmp } @dir) {    if ($byfile) {
             if ($_ eq '.') {      print 'File';
                 next;    } else {
             }      print &link('File',
             # ignore CVS lock and stale NFS files                  sprintf('./%s#dirlist', toggleQuery('sortby', 'file')));
             next if (/^#cvs\.|^,|^\.nfs/);    }
     print "</th>\n";
   
             # Check whether to show the CVSROOT path    # Do not display the other column headers if we do not have any files
             next if ($input{'hidecvsroot'} && ($_ eq 'CVSROOT'));    # with revision information.
     if (scalar(%fileinfo)) {
       $infocols++;
       printf('<th%s>', ($byrev ? ' class="sorted"' : ''));
   
             # Check whether the module is in the restricted list      if ($byrev) {
             next if ($_ && &forbidden_module($_));        print 'Rev.';
       } else {
         print &link('Rev.',
                     sprintf('./%s#dirlist', toggleQuery('sortby', 'rev')));
       }
       print "</th>\n";
       $infocols++;
       printf('<th%s>', ($bydate ? ' class="sorted"' : ''));
   
             # Ignore non-readable files      if ($bydate) {
             next if ($input{'hidenonreadable'} && !(-r "$fullname/$_"));        print 'Age';
       } else {
         print &link('Age',
                     sprintf('./%s#dirlist', toggleQuery('sortby', 'date')));
       }
       print "</th>\n";
   
             if (s|^Attic/||) {      if ($show_author) {
                 $attic  = " (in the Attic)&nbsp;" . $hideAtticToggleLink;        $infocols++;
             }        printf('<th%s>', ($byauthor ? ' class="sorted"' : ''));
             else {  
                 $attic = "";  
             }  
   
             if ($_ eq '..' || -d "$fullname/$_") {        if ($byauthor) {
                 next if ($_ eq '..' && $where eq '/');          print 'Author';
                 my ($rev,$date,$log,$author,$filename) = @{$fileinfo{$_}}        } else {
                     if (defined($fileinfo{$_}));          print
                 print "<tr bgcolor=\"" . @tabcolors[$dirrow%2] . "\"><td>" if ($dirtable);            &link('Author',
                 if ($_ eq '..') {                  sprintf('./%s#dirlist', toggleQuery('sortby', 'author')));
                     $url = "../" . $query;        }
                     if ($nofilelinks) {        print "</th>\n";
                         print $backicon;      }
                     }      $infocols++;
                     else {      printf('<th%s>', ($bylog ? ' class="sorted"' : ''));
                         print &link($backicon,$url);  
                     }  
                     print " ", &link("Previous Directory",$url);  
                 }  
                 else {  
                     $url = urlencode($_) . '/' . $query;  
                     print "<A NAME=\"$_\"></A>";  
                     if ($nofilelinks) {  
                         print $diricon;  
                     }  
                     else {  
                         print &link($diricon,$url);  
                     }  
                     print " ", &link($_ . "/", $url), $attic;  
                     if ($_ eq "Attic") {  
                         print "&nbsp; <a href=\"./" .  
                             &toggleQuery ("hideattic") .  
                                 "#dirlist\">[Don't hide]</a>";  
                     }  
                 }  
                 # Show last change in dir  
                 if ($filename) {  
                     print "</td><td>&nbsp;</td><td>&nbsp;" if ($dirtable);  
                     if ($date) {  
                         print " <i>" . readableTime(time() - $date,0) . "</i>";  
                     }  
                     if ($show_author) {  
                         print "</td><td>&nbsp;" if ($dirtable);  
                         print $author;  
                     }  
                     print "</td><td>&nbsp;" if ($dirtable);  
                     $filename =~ s%^[^/]+/%%;  
                     print "$filename/$rev";  
                     print "<BR>" if ($dirtable);  
                     if ($log) {  
                         print "&nbsp;<font size=-1>"  
                             . &htmlify(substr($log,0,$shortLogLen));  
                         if (length $log > 80) {  
                             print "...";  
                         }  
                         print "</font>";  
                     }  
                 }  
                 else {  
                     my ($dwhere) = ($where ne "/" ? $where : "") . $_;  
                     if ($use_descriptions && defined $descriptions{$dwhere}) {  
                         print "<TD COLSPAN=" . ($infocols-1) . ">&nbsp;" if $dirtable;  
                         print $descriptions{$dwhere};  
                     } elsif ($dirtable && $infocols > 1) {  
                         # close the row with the appropriate number of  
                         # columns, so that the vertical seperators are visible  
                         my($cols) = $infocols;  
                         while ($cols > 1) {  
                             print "</td><td>&nbsp;";  
                             $cols--;  
                         }  
                     }  
                 }  
                 if ($dirtable) {  
                     print "</td></tr>\n";  
                 }  
                 else {  
                     print "<br>\n";  
                 }  
                 $dirrow++;  
             }  
             elsif (s/,v$//) {  
                 $fileurl = ($attic ? "Attic/" : "") . urlencode($_);  
                 $url = $fileurl . $query;  
                 my $rev = '';  
                 my $date = '';  
                 my $log = '';  
                 my $author = '';  
                 $filesexists++;  
                 next if (!defined($fileinfo{$_}));  
                 ($rev,$date,$log,$author) = @{$fileinfo{$_}};  
                 $filesfound++;  
                 print "<tr bgcolor=\"" . @tabcolors[$dirrow%2] . "\"><td>" if ($dirtable);  
                 print "<A NAME=\"$_\"></A>";  
                 if ($nofilelinks) {  
                     print $fileicon;  
                 }  
                 else {  
                     print &link($fileicon,$url);  
                 }  
                 print " ", &link($_, $url), $attic;  
                 print "</td><td>&nbsp;" if ($dirtable);  
                 download_link($fileurl,  
                         $rev, $rev,  
                         $defaultViewable ? "text/x-cvsweb-markup" : undef);  
                 print "</td><td>&nbsp;" if ($dirtable);  
                 if ($date) {  
                     print " <i>" . readableTime(time() - $date,0) . "</i>";  
                 }  
                 if ($show_author) {  
                     print "</td><td>&nbsp;" if ($dirtable);  
                     print $author;  
                 }  
                 print "</td><td>&nbsp;" if ($dirtable);  
                 if ($log) {  
                     print " <font size=-1>" . &htmlify(substr($log,0,$shortLogLen));  
                     if (length $log > 80) {  
                         print "...";  
                     }  
                     print "</font>";  
                 }  
                 print "</td>" if ($dirtable);  
                 print (($dirtable) ? "</tr>" : "<br>");  
                 $dirrow++;  
             }  
             print "\n";  
         }  
         if ($dirtable && defined($tableBorderColor)) {  
             print "</td></tr></table>";  
         }  
         print "". ($dirtable == 1) ? "</table>" : "</menu>" . "\n";  
   
         if ($filesexists && !$filesfound) {  
             print "<P><B>NOTE:</B> There are $filesexists files, but none matches the current tag ($input{only_with_tag})\n";  
         }  
         if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}})) {  
             %tags = %alltags  
         }  
         if (scalar %tags  
             || $input{only_with_tag}  
             || $edit_option_form  
             || defined($input{"options"})) {  
             print "<hr size=1 NOSHADE>";  
         }  
   
         if (scalar %tags || $input{only_with_tag}) {      if ($bylog) {
             print "<FORM METHOD=\"GET\" ACTION=\"./\">\n";        print 'Last log entry';
             foreach my $var (@stickyvars) {      } else {
                 print "<INPUT TYPE=HIDDEN NAME=\"$var\" VALUE=\"$input{$var}\">\n"        print &link('Last log entry',
                     if (defined($input{$var})                    sprintf('./%s#dirlist', toggleQuery('sortby', 'log')));
                         && $input{$var} ne $DEFAULTVALUE{$var}      }
                         && $input{$var} ne ""      print "</th>\n";
                         && $var ne "only_with_tag");    } elsif ($use_descriptions) {
             }      print "<th>Description</th>\n";
             print "Show only files with tag:\n";      $infocols++;
             print "<SELECT NAME=only_with_tag";    }
             print " onchange=\"submit()\"" if ($use_java_script);    print "</tr>\n";
             print ">";  
             print "<OPTION VALUE=\"\">All tags / default branch\n";  
             foreach my $tag (reverse sort { lc $a cmp lc $b } keys %tags) {  
                 print "<OPTION",defined($input{only_with_tag}) &&  
                        $input{only_with_tag} eq $tag ? " SELECTED":"",  
                        ">$tag\n";  
             }  
             print "</SELECT>\n";  
             print "<INPUT TYPE=SUBMIT VALUE=\"Go\">\n";  
             print "</FORM>\n";  
         }  
         my $formwhere = $scriptwhere;  
         $formwhere =~ s|Attic/?$|| if ($input{'hideattic'});  
   
         if ($edit_option_form || defined($input{"options"})) {    my $dirrow = 0;
             print "<FORM METHOD=\"GET\" ACTION=\"${formwhere}\">\n";  
             print "<INPUT TYPE=HIDDEN NAME=\"copt\" VALUE=\"1\">\n";  
             if ($cvstree ne $cvstreedefault) {  
                 print "<INPUT TYPE=HIDDEN NAME=\"cvsroot\" VALUE=\"$cvstree\">\n";  
             }  
             print "<center><table cellpadding=0 cellspacing=0>";  
             print "<tr bgcolor=\"$columnHeaderColorDefault\"><th colspan=2>Preferences</th></tr>";  
             print "<tr><td>Sort files by <SELECT name=\"sortby\">";  
             print "<OPTION VALUE=\"\">File";  
             print "<OPTION",$bydate ? " SELECTED" : ""," VALUE=date>Age";  
             print "<OPTION",$byauthor ? " SELECTED" : ""," VALUE=author>Author"  
                 if ($show_author);  
             print "<OPTION",$byrev ? " SELECTED" : ""," VALUE=rev>Revision";  
             print "<OPTION",$bylog ? " SELECTED" : ""," VALUE=log>Log message";  
             print "</SELECT></td>";  
             print "<td>revisions by: \n";  
             print "<SELECT NAME=logsort>\n";  
             print "<OPTION VALUE=cvs",$logsort eq "cvs" ? " SELECTED" : "", ">Not sorted";  
             print "<OPTION VALUE=date",$logsort eq "date" ? " SELECTED" : "", ">Commit date";  
             print "<OPTION VALUE=rev",$logsort eq "rev" ? " SELECTED" : "", ">Revision";  
             print "</SELECT></td></tr>";  
             print "<tr><td>Diff format: ";  
             printDiffSelect();  
             print "</td>";  
             print "<td>Show Attic files: ";  
             print "<INPUT NAME=hideattic TYPE=CHECKBOX", $input{'hideattic'}?" CHECKED":"",  
             "></td></tr>\n";  
             print "<tr><td align=center colspan=2><input type=submit value=\"Change Options\">";  
             print "</td></tr></table></center></FORM>\n";  
         }  
         print &html_footer;  
         print "</BODY></HTML>\n";  
     }  
   
     my $i;
     lookingforattic:
     for ($i = 0; $i <= $#dir; $i++) {
       if ($dir[$i] eq "Attic") {
         last lookingforattic;
       }
     }
   
     if (!$input{hideattic}
         && ($i <= $#dir)
         && opendir($dh, $fullname . '/Attic'))
     {
       splice(@dir, $i, 1, grep((s|^|Attic/|, !m|/\.|), readdir($dh)));
       closedir($dh);
     }
   
     my $hideAtticToggleLink =
       $input{hideattic}
       ? ''
       : &link('[hide]', sprintf('./%s#dirlist', &toggleQuery('hideattic')));
   
     # Sort without the Attic/ pathname.
     # place directories first
   
     my $filesexists;
     my $filesfound;
   
     foreach my $file (sort { &fileSortCmp } @dir) {
   
       next if ($file eq curdir());
   
       # ignore CVS lock and stale NFS files
       next if ($file =~ /^\#cvs\.|^,|^\.nfs/); # \# for XEmacs cperl-mode...
   
       # Check whether to show the CVSROOT path
       next if ($input{hidecvsroot} && $where eq '/' && $file eq 'CVSROOT');
   
       # Is it a directory?
       my $isdir = -d catdir($fullname, $file);
   
       # Ignore non-readable files and directories?
       next if ($input{hidenonreadable} && (! -r _ || ($isdir && ! -x _)));
   
       my $attic = '';
       if ($file =~ s|^Attic/||) {
         $attic = ' <span class="attic">(in the Attic) ' .
           $hideAtticToggleLink . '</span>';
       }
   
       if ($file eq updir() || $isdir) {
         next if ($file eq updir() && $where eq '/');
         my ($rev, $date, $log, $author, $filename, $keywordsubst) =
           @{$fileinfo{$file}} if (defined($fileinfo{$file}));
         printf "<tr class=\"%s\">\n<td class=\"dir\" colspan=\"2\">",
           ($dirrow % 2) ? 'even' : 'odd';
   
         if ($file eq updir()) {
           my $url = "../$query";
           print $nofilelinks ? $backicon : &link($backicon, $url);
           print '&nbsp;', &link("Parent Directory", $url);
   
         } else {
           my $url = './' . uri_escape_path($file) . "/$query";
           print '<a name="', htmlquote($file), '"></a>';
           print $nofilelinks ? $diricon : &link($diricon, $url);
           print '&nbsp;', &link(htmlquote("$file/"), $url), $attic;
           if ($file eq "Attic") {
             print ' <span class="attic">',
               &link('[show]',
                     sprintf('./%s#dirlist', &toggleQuery('hideattic'))),
                       '</span>';
           }
         }
   
         # Show last change in dir
         if ($filename) {
           my $ageclass = 'age';
           my $age      = '';
           if ($date) {
             $age       = readableTime(time() - $date, 0);
             $ageclass .= " $1" if ($age =~ /^\d+ ([a-z]+)/);
           }
           print "</td>\n<td>&nbsp;</td>\n<td class=\"$ageclass\">$age";
           print "</td>\n<td class=\"author\">", htmlquote($author)
             if $show_author;
           print "</td>\n<td class=\"log\">";
           $filename =~ s%^[^/]+/%%;
           print &link(htmlquote("$filename/$rev"),
                       sprintf('%s/%s%s#rev%s',
                               uri_escape($file), uri_escape($filename),
                               $query, $rev)), '<br />';
           if ($log) {
             print htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra);
             print '...' if (length($log) > 80);
           }
   
         } else {
           my $dwhere = ($where ne '/' ? $where : '') . $file;
   
           if ($use_descriptions && defined $descriptions{$dwhere}) {
             print '<td colspan="', ($infocols - 1), '">';
             print $descriptions{$dwhere};
   
           } elsif ($infocols > 1) {
   
             # close the row with the appropriate number of
             # columns, so that the vertical seperators are visible
             my ($cols) = $infocols;
             while ($cols > 1) {
               print "</td>\n<td>&nbsp;";
               $cols--;
             }
           }
         }
   
         print "</td>\n</tr>\n";
         $dirrow++;
   
       } elsif ($file =~ s/,v$//) {
   
         my $fileurl = ($attic ? 'Attic/' : '') . uri_escape_path($file);
         my $url     = './' . $fileurl . $query;
         $filesexists++;
         next if (!defined($fileinfo{$file}));
         my ($rev, $date, $log, $author, $filename, $keywordsubst) =
           @{$fileinfo{$file}};
         my $isbinary = $keywordsubst eq 'b' ? 1 : 0;
         $filesfound++;
   
         printf "<tr class=\"%s\">\n", ($dirrow % 2) ? 'even' : 'odd';
         printf '<td class="file"%s>', $allow_cvsgraph ? '' : ' colspan="2"';
   
         my $icon = $isbinary ? $binfileicon : $fileicon;
         print $nofilelinks ? $icon : &link($icon, $url);
         print '&nbsp;', &link(htmlquote($file), $url), $attic;
         print '</td><td class="graph">', graph_link($fileurl) if $allow_cvsgraph;
         print "</td>\n<td width=\"30\">", display_link($fileurl, $rev);
         my $ageclass = 'age';
         my $age      = '';
         if ($date) {
           $age       = readableTime(time() - $date, 0);
           $ageclass .= " $1" if ($age =~ /^\d+ ([a-z]+)/);
         }
         print "</td>\n<td class=\"$ageclass\">$age";
         print "</td>\n<td class=\"author\">", htmlquote($author) if $show_author;
         print "</td>\n<td class=\"log\">";
   
         if ($log) {
           print htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra);
           print '...' if (length $log > 80);
         }
         print "</td>\n</tr>";
         $dirrow++;
       }
       print "\n";
     }
   
     print "</table>\n";
   
     if ((my $num = scalar(@unreadable)) && ! $input{hidenonreadable}) {
       printf(<<EOF, $num, htmlquote(join(', ', @unreadable)));
   <p>
    <b>NOTE:</b> The following %d unreadable files were ignored:<br />
    <em>%s</em>
   </p>
   EOF
     }
   
     if ($filesexists && !$filesfound) {
       my $currtag = defined($input{only_with_tag}) ?
         sprintf(' (%s)', htmlquote($input{only_with_tag})) : '';
       printf(<<EOF, $filesexists, $currtag);
   <p>
    <b>NOTE:</b> There are %d files, but none matches the current tag%s.
   </p>
   EOF
     }
   
     if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}})) {
       %tags = %alltags;
     }
   
     if (scalar %tags
         || $input{only_with_tag}
         || $edit_option_form
         || defined($input{options}))
     {
       print "<hr />\n";
     }
   
     if (scalar %tags || $input{only_with_tag}) {
       print "<form method=\"get\" action=\"./\">\n<p>\n";
       foreach my $var (@stickyvars) {
         printf("<input type=\"hidden\" name=\"%s\" value=\"%s\" />\n",
                $var, htmlquote($input{$var}))
           if (defined($input{$var})
               && (!defined($DEFAULTVALUE{$var})
                   || $input{$var} ne $DEFAULTVALUE{$var})
               && $var ne 'only_with_tag');
       }
       printf(<<EOF, ($use_java_script ? ' onchange="this.form.submit()"' : ''));
   <span class="nowrap">
   <label for="only_with_tag" accesskey="T">Show only files with tag:
   <select id="only_with_tag" name="only_with_tag"%s>
   <option value="">All tags / default branch</option>
   EOF
       foreach my $tag (reverse sort { lc $a cmp lc $b } keys %tags) {
         my $selected =
           defined($input{only_with_tag}) && $input{only_with_tag} eq $tag;
         printf("<option%s>%s</option>\n",
                $selected ? ' selected="selected"' : '',
                htmlquote($tag));
       }
       printf(<<EOF, htmlquote($where));
   </select>
   </label></span> <span class="nowrap">
   <label for="path" accesskey="P">Module path or alias:
   <input type="text" id="path" name="path" value="%s" size="15" /></label>
   </span>
   <input type="submit" value="Go" accesskey="G" />
   </p>
   </form>
   EOF
     }
   
     if ($allow_tar && $filesfound) {
       my ($basefile) = ($where =~ m,(?:.*/)?([^/]+),);
       my $havetar = $CMD{tar} && $CMD{gzip};
       my $havezip = $CMD{zip};
       if (defined($basefile) && $basefile ne '' && ($havetar || $havezip)) {
         my $q = ($query ? "$query;" : '?') . 'tarball=1';
         print "<hr />\n",
           '<div style="text-align: center">Download this directory in ';
         # Mangle the filename so browsers show a reasonable filename to download.
         my @types = ();
         $basefile = uri_escape($basefile);
         push(@types, &link('tarball', "$basefile.tar.gz$q")) if $havetar;
         push(@types, &link('zip archive', "$basefile.zip$q")) if $havezip;
         print join(' or ', @types), "</div>\n";
       }
     }
   
     if ($edit_option_form || defined($input{options})) {
   
       print <<EOF;
   <form method="get" action="./">
   <fieldset>
   <legend>General options</legend>
   <input type="hidden" name="copt" value="1" />
   EOF
       for my $v qw(hidecvsroot hidenonreadable) {
         printf(qq{<input type="hidden" name="%s" value="%s" />\n},
                $v, $input{$v} || 0);
       }
       if ($cvstree ne $cvstreedefault) {
         print "<input type=\"hidden\" name=\"cvsroot\" value=\"$cvstree\" />\n";
       }
       print <<EOF;
   <table summary="General options">
   <tr>
   <td class="opt-label">
   <label for="sortby" accesskey="F">Sort files by:</label>
   </td>
   <td class="opt-value">
   <select id="sortby" name="sortby">
   <option value="">File</option>
   EOF
       print "<option", $bydate ? ' selected="selected"' : '',
         " value=\"date\">Age</option>\n";
       print "<option", $byauthor ? ' selected="selected"' : '',
         " value=\"author\">Author</option>\n"
           if $show_author;
       print "<option", $byrev ? ' selected="selected"' : '',
         " value=\"rev\">Revision</option>\n";
       print "<option", $bylog ? ' selected="selected"' : '',
         " value=\"log\">Log message</option>\n";
       print <<EOF;
   </select>,
   <label for="ignorecase" accesskey="I">case-insensitive:
   EOF
       print '<input id="ignorecase" name="ignorecase" type="checkbox"',
         $input{ignorecase} ? ' checked="checked"' : '',
           " value=\"1\" /></label>\n";
       print <<EOF;
   </td>
   <td class="opt-label">
   <label for="hideattic" accesskey="A">Hide files in Attic:</label>
   </td>
   <td class="opt-value">
   EOF
       print '<input id="hideattic" name="hideattic" type="checkbox"',
         $input{hideattic} ? ' checked="checked"' : '', ' value="1" />';
       print <<EOF;
   </td>
   </tr>
   <tr>
   <td class="opt-label">
   <label for="logsort" accesskey="L">Sort log by:</label>
   </td>
   <td class="opt-value">
   EOF
       printLogSortSelect(0);
       print <<EOF;
   </td>
   <td class="opt-label">
   <label for="ln" accesskey="N">Show line numbers:</label>
   </td>
   <td class="opt-value">
   EOF
       print '<input id="ln" name="ln" type="checkbox"',
         $input{ln} ? ' checked="checked"' : '', " value=\"1\" />\n";
       print <<EOF;
   </td>
   </tr>
   <tr>
   <td class="opt-label">
   <label for="f" accesskey="D">Diff format:</label>
   </td>
   <td>
   EOF
       printDiffSelect(0);
       print <<EOF;
   </td>
   <td colspan="2" class="opt-label">
   <input type="submit" value="Change Options" accesskey="C" />
   </td>
   </tr>
   </table>
   </fieldset>
   </form>
   EOF
     }
     html_footer();
   }
   
 ###############################  ###############################
 # View Files  # View Files
 ###############################  ###############################
     elsif (-f $fullname . ',v') {  elsif (-f $fullname . ',v') {
         if (defined($input{'rev'}) || $doCheckout) {  
             &doCheckout($fullname, $input{'rev'});    if (defined($input{rev}) || $doCheckout) {
             exit;      &doCheckout($fullname, $input{rev}, $input{only_with_tag});
         }      gzipclose();
         if (defined($input{'annotate'}) && $allow_annotate) {      exit;
             &doAnnotate($input{'annotate'});    }
             exit;  
         }    if (defined($input{annotate}) && $allow_annotate) {
         if (defined($input{'r1'}) && defined($input{'r2'})) {      &doAnnotate($input{annotate}, $input{only_with_tag});
             &doDiff($fullname, $input{'r1'}, $input{'tr1'},      gzipclose();
                     $input{'r2'}, $input{'tr2'}, $input{'f'});      exit;
             exit;    }
         }  
         print("going to dolog($fullname)\n") if ($verbose);    if (defined($input{r1}) && defined($input{r2})) {
         &doLog($fullname);      &doDiff($fullname,  $input{r1},  $input{tr1},
               $input{r2}, $input{tr2}, $input{f});
       gzipclose();
       exit;
     }
   
     if ($allow_cvsgraph && $input{graph}) {
       if ($input{makeimage}) {
         doGraph();
       } else {
         doGraphView();
       }
       gzipclose();
       exit;
     }
   
     &doLog($fullname);
   }
   
 ##############################  ##############################
 # View Diff  # View Diff
 ##############################  ##############################
     }  elsif ($fullname =~ s/\.diff$//
     elsif ($fullname =~ s/\.diff$// && -f $fullname . ",v" &&         && -f $fullname . ',v' && $input{r1} && $input{r2})
            $input{'r1'} && $input{'r2'}) {  {
   
         # $where-diff-removal if 'cvs rdiff' is used    # $where-diff-removal if 'cvs rdiff' is used
         # .. but 'cvs rdiff'doesn't support some options    # .. but 'cvs rdiff'doesn't support some options
         # rcsdiff does (-w and -p), so it is disabled    # rcsdiff does (-w and -p), so it is disabled
         # $where =~ s/\.diff$//;    # $where =~ s/\.diff$//;
   
         # Allow diffs using the ".diff" extension    # Allow diffs using the ".diff" extension so that browsers that default
         # so that browsers that default to the URL    # to the filename in the URL when saving don't save diffs as eg. foo.c.
         # for a save filename don't save diff's as    &doDiff($fullname,  $input{r1},  $input{tr1},
         # e.g. foo.c            $input{r2}, $input{tr2}, $input{f});
         &doDiff($fullname, $input{'r1'}, $input{'tr1'},    gzipclose();
                 $input{'r2'}, $input{'tr2'}, $input{'f'});    exit;
         exit;  
   }
   
   elsif (do { (my $tmp = $fullname) =~ s|/([^/]+)$|/Attic/$1|; -f "$tmp,v" }) {
     # The file has been removed and is in the Attic.
     # Send a redirect pointing to the file in the Attic.
     (my $newplace = $scriptwhere) =~ s|/([^/]+)$|/Attic/$1|;
     if ($ENV{QUERY_STRING} ne "") {
       redirect("$newplace?$ENV{QUERY_STRING}");
     } else {
       redirect($newplace);
     }
     exit;
   
   }
   
   elsif (0 && (my @files = &safeglob($fullname . ",v"))) {
     http_header("text/plain");
     print "You matched the following files:\n";
     print join ("\n", @files);
   
     # TODO:
     # Find the tags from each file
     # Display a form offering diffs between said tags
   }
   
   else {
     # Assume it's a module name with a potential path following it.
     my $module;
     my $xtra = (($module = $where) =~ s|(/.*)||) ? $1 : '';
   
     # Is there an indexed version of modules?
     my $fh = do { local (*FH); };
     if (open($fh, catfile($cvsroot, 'CVSROOT', 'modules'))) {
       while (<$fh>) {
         if (/^(\S+)\s+(\S+)/o
             && $module eq $1
             && $module ne $2
             && -d "$cvsroot/$2")
         {
           close($fh);
           redirect("$scriptname/$2$xtra$query");
         }
     }      }
     elsif (($newname = $fullname) =~ s|/([^/]+)$|/Attic/$1| &&      close($fh);
            -f $newname . ",v") {    }
         # The file has been removed and is in the Attic.    fatal("404 Not Found", '%s: no such file or directory', $where);
         # Send a redirect pointing to the file in the Attic.  }
         (my $newplace = $scriptwhere) =~ s|/([^/]+)$|/Attic/$1|;  
         &redirect($newplace);  gzipclose();
         exit;  
     }  
     elsif (0 && (my @files = &safeglob($fullname . ",v"))) {  
         http_header("text/plain");  
         print "You matched the following files:\n";  
         print join("\n", @files);  
         # Find the tags from each file  
         # Display a form offering diffs between said tags  
     }  
     else {  
         my $fh = do {local(*FH);};  
         my ($xtra, $module);  
         # Assume it's a module name with a potential path following it.  
         $xtra = $& if (($module = $where) =~ s|/.*||);  
         # Is there an indexed version of modules?  
         if (open($fh, "$cvsroot/CVSROOT/modules")) {  
             while (<$fh>) {  
                 if (/^(\S+)\s+(\S+)/o && $module eq $1  
                     && -d "${cvsroot}/$2" && $module ne $2) {  
                     &redirect($scriptname . '/' . $2 . $xtra);  
                 }  
             }  
         }  
         &fatal("404 Not Found","$where: no such file or directory");  
     }  
 ## End MAIN  ## End MAIN
   
 sub printDiffSelect {  
     my ($use_java_script) = @_;  sub printDiffSelect($)
     $use_java_script = 0 if (!defined($use_java_script));  {
     my ($f) = $input{'f'};    my ($use_java_script) = @_;
     print "<SELECT NAME=\"f\"";  
     print " onchange=\"submit()\"" if ($use_java_script);    print '<select id="f" name="f"';
     print ">\n";    print ' onchange="this.form.submit()"' if $use_java_script;
     print "<OPTION VALUE=h",$f eq "h" ? " SELECTED" : "", ">Colored Diff";    print ">\n";
     print "<OPTION VALUE=H",$f eq "H" ? " SELECTED" : "", ">Long Colored Diff";  
     print "<OPTION VALUE=u",$f eq "u" ? " SELECTED" : "", ">Unidiff";    for my $difftype (@DIFFTYPES) {
     print "<OPTION VALUE=c",$f eq "c" ? " SELECTED" : "", ">Context Diff";      printf("<option value=\"%s\"%s>%s</option>\n",
     print "<OPTION VALUE=s",$f eq "s" ? " SELECTED" : "", ">Side by Side";             $difftype, $input{f} eq $difftype ? ' selected="selected"' : '',
     print "</SELECT>";             "\u$DIFFTYPES{$difftype}{descr}");
     }
   
     print "</select>";
 }  }
   
 sub findLastModifiedSubdirs {  
     my (@dirs) = @_;  
     my ($dirname, @files);  
   
     foreach $dirname (@dirs) {  sub printDiffSelectStickyVars()
         next if ($dirname eq ".");  {
         next if ($dirname eq "..");    while (my ($key, $val) = each %input) {
         my ($dir) = "$fullname/$dirname";      next if ($key eq 'f');
         next if (!-d $dir);      next if (defined($DEFAULTVALUE{$key}) && $DEFAULTVALUE{$key} eq $val);
       print "<input type=\"hidden\" name=\"", htmlquote($key), "\" value=\"",
         htmlquote($val), "\" />\n";
     }
   }
   
         my ($lastmod) = undef;  
         my ($lastmodtime) = undef;  
         my $dh = do {local(*DH);};  
   
         opendir($dh,$dir) || next;  sub printLogSortSelect($)
         my (@filenames) = readdir($dh);  {
         closedir($dh);    my ($use_java_script) = @_;
   
         foreach my $filename (@filenames) {    print '<select id="logsort" name="logsort"';
             $filename = "$dirname/$filename";    print ' onchange="this.form.submit()"' if $use_java_script;
             my ($file) = "$fullname/$filename";    print ">\n";
             next if ($filename !~ /,v$/ || !-f $file);  
             $filename =~ s/,v$//;    for my $sortkey (@LOGSORTKEYS) {
             my $modtime = -M $file;      printf("<option value=\"%s\"%s>%s</option>\n",
             if (!defined($lastmod) || $modtime < $lastmodtime) {             $sortkey, $logsort eq $sortkey ? ' selected="selected"' : '',
                 $lastmod = $filename;             "\u$LOGSORTKEYS{$sortkey}{descr}");
                 $lastmodtime = $modtime;    }
             }  
         }    print "</select>";
         push(@files, $lastmod) if (defined($lastmod));  }
   
   
   #
   # Find the last modified, version controlled files in the given directories.
   # Compares solely based on modification timestamps.  Files in the returned list
   # are without the ,v suffix, and unreadable files have been filtered out.
   #
   sub findLastModifiedSubdirs(@)
   {
     my (@dirs) = @_;
   
     my @files;
     foreach my $dirname (@dirs) {
       next if ($dirname eq curdir() || $dirname eq updir());
       my $dir = catdir($fullname, $dirname);
       next if (!-d $dir);
   
       my $dh = do { local (*DH); };
       opendir($dh, $dir) or next;
       my (@filenames) = grep(!forbidden(catfile($dir, $_)), readdir($dh));
       closedir($dh);
   
       my $lastmod     = undef;
       my $lastmodtime = undef;
       foreach my $filename (@filenames) {
         ($filename) =
           (catfile($dirname, $filename) =~ VALID_PATH) or next; # untaint
         my ($file) = catfile($fullname, $filename);
         next if ($filename !~ /,v$/o || !-f $file || !-r _);
         my $modtime = -M _;
         if (!defined($lastmod) || $modtime < $lastmodtime) {
           ($lastmod    = $filename) =~ s/,v$//;
           $lastmodtime = $modtime;
         }
     }      }
     return @files;      push(@files, $lastmod) if (defined($lastmod));
     }
     return @files;
 }  }
   
 sub htmlify {  
         my($string, $pr) = @_;  
   
         # Special Characters; RFC 1866  sub htmlify_sub(&$)
         $string =~ s/&/&amp;/g;  {
         $string =~ s/\"/&quot;/g;    (my $proc, local $_) = @_;
         $string =~ s/</&lt;/g;    my @a = split(m|(<a [^>]+>[^<]*</a>)|i);
         $string =~ s/>/&gt;/g;    my $linked;
     my $result = '';
   
         # get URL's as link ..    while (($_, $linked) = splice(@a, 0, 2)) {
         $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>`;      &$proc();
         # get e-mails as link      $result .= $_      if defined($_);
         $string =~ s`([-a-zA-Z0-9_.]+@([-a-zA-Z0-9]+\.)+[A-Za-z]{2,4})`<A HREF="mailto:$1">$1</A>`;      $result .= $linked if defined($linked);
     }
   
         # get #PR as link ..    return $result;
         if ($pr && defined($prcgi)) {  }
             1 while $string =~ s`\b(pr[:#]?\s*(?:#?\d+[,\s]\s*)*#?)(\d+)\b`$1<A HREF="$prcgi?pr=$2">$2</A>`i;  
             $string =~ s`\b${prcategories}/(\d+)\b`<A HREF="$prcgi?pr=$1">$&</A>`igo;  
         }  
   
         return $string;  
   sub htmlify($;$)
   {
     (local $_, my $extra) = @_;
   
     $_ = htmlquote($_);
   
     # get URL's as link
     s{
       ((https?|ftp)://.+?)([\s\']|&(quot|[lg]t);)
      }{
        &link($1, htmlunquote($1)) . $3
      }egx;
   
     if ($allow_mailtos) {
       # Make mailto: links from email addresses.
       $_ = htmlify_sub {
         s<
           ([\w+=\-.!]+@[\w\-]+(?:\.[\w\-]+)+)
          ><
            &link($1, "mailto:$1")
          >egix;
       } $_;
     }
   
     if ($extra) {
   
       # get PR #'s as link: "PR#nnnn" "PR: nnnn, ..." "PR nnnn, ..." "bin/nnnn"
       if (defined($prcgi) && defined($re_prkeyword)) {
         my $prev;
   
         do {
           $prev = $_;
           $_ = htmlify_sub {
             s{
               (\b$re_prkeyword[:\#]?\s*
                (?:
                 \#?
                 \d+[,\s]\s*
                )*
                \#?)
               (\d+)\b
              }{
                $1 . &link($2, sprintf($prcgi, $2))
              }egix;
           } $_;
         } while ($_ ne $prev);
   
         if (defined($re_prcategories)) {
           $_ = htmlify_sub {
             s{
               (\b$re_prcategories/(\d+)\b)
              }{
                &link($1, sprintf($prcgi, $2))
              }egox;
           } $_;
         }
       }
   
       # get manpage specs as link: "foo.1" "foo(1)"
       if (defined($mancgi)) {
         $_ = htmlify_sub {
           s{
             (
              \b ( \w[\w+\-.]* (?: ::\w[\w+\-.]*)* )
              (?:
               \( ([0-9n]) \) \B
               |
               \. ([0-9n]) \b
              )
             )
            }{
               my($text, $name, $section) = ($1, $2, defined($3) ? $3 : $4);
               ($name =~ /[A-Za-z]/ && $name !~ /\.(:|$)/)
                ? &link($text, sprintf($mancgi, uri_escape($name), $section))
                 : $text;
            }egx;
         } $_;
       }
     }
   
     return $_;
 }  }
   
 sub spacedHtmlText {  
         my($string, $pr) = @_;  
   
         # Cut trailing spaces  sub spacedHtmlText($;$)
         s/\s+$//;  {
     (local $_, my $ts) = @_;
     return '' unless defined($_);
     $ts ||= $tabstop || 8;
   
         # Expand tabs    # Expand tabs
         $string =~ s/\t+/' ' x (length($&) * $tabstop - length($`) % $tabstop)/e    1 while s/(.*?)(\t+)/$1 . ' ' x (length($2) * $ts - length($1) % $ts)/e;
             if (defined($tabstop));  
   
         # replace <tab> and <space> (\001 is to protect us from htmlify)    if ($hr_breakable) {
         # gzip can make excellent use of this repeating pattern :-)      s/^ /\001nbsp;/;      # protect leading and...
         $string =~ s/\001/\001%/g; #protect our & substitute      s/ $/\001nbsp;/;      # ...trailing whitespace (mostly for String::Ediff),
         if ($hr_breakable) {      s/  / \001nbsp;/g;    # ...and leave every other space 'breakable'
             # make every other space 'breakable'    } else {
             $string =~ s/       / \001nbsp; \001nbsp; \001nbsp; \001nbsp;/g;    # <tab>      s/ /\001nbsp;/g;
             $string =~ s/  / \001nbsp;/g;                              # 2 * <space>    }
             # leave single space as it is  
         }  
         else {  
             $string =~ s/       /\001nbsp;\001nbsp;\001nbsp;\001nbsp;\001nbsp;\001nbsp;\001nbsp;\001nbsp;/g;  
             $string =~ s/ /\001nbsp;/g;  
         }  
   
         $string = htmlify($string);    $_ = htmlify($_, $allow_source_extra);
   
         # unescape    # unescape
         $string =~ s/\001([^%])/&$1/g;    y/\001/&/;
         $string =~ s/\001%/\001/g;  
   
         return $string;    return $_;
 }  }
   
 sub link {  
         my($name, $where) = @_;  
   
         return "<A HREF=\"$where\">$name</A>\n";  # Note that this doesn't htmlquote the first argument...
   sub link($$)
   {
     my ($name, $url) = @_;
     return sprintf('<a href="%s">%s</a>', htmlquote($url), $name);
 }  }
   
 sub revcmp {  
         my($rev1, $rev2) = @_;  
         my(@r1) = split(/\./, $rev1);  
         my(@r2) = split(/\./, $rev2);  
         my($a,$b);  
   
         while (($a = shift(@r1)) && ($b = shift(@r2))) {  sub revcmp($$)
             if ($a != $b) {  {
                 return $a <=> $b;    my ($rev1, $rev2) = @_;
             }  
         }    # make no comparison for a tag or a branch
         if (@r1) { return 1; }    return 0 if $rev1 =~ /[^\d.]/ || $rev2 =~ /[^\d.]/;
         if (@r2) { return -1; }  
         return 0;    my (@r1) = split(/\./, $rev1);
     my (@r2) = split(/\./, $rev2);
     my ($a, $b);
   
     while (($a = shift(@r1)) && ($b = shift(@r2))) {
       return $a <=> $b unless ($a == $b);
     }
     if (@r1) { return  1; }
     if (@r2) { return -1; }
     return 0;
 }  }
   
 sub fatal {  
         my($errcode, $errmsg) = @_;  #
         if ($is_mod_perl) {  # Signal a fatal error.
                 Apache->request->status((split(/ /, $errcode))[0]);  #
         }  sub fatal($$@)
         else {  {
                 print "Status: $errcode\n";    my ($errcode, $format, @args) = @_;
         }    print "Status: $errcode\r\n";
         html_header("Error");    html_header('Error');
         print "Error: $errmsg\n";    print '<div id="error">Error: ',
         print &html_footer;      sprintf($format, map(htmlquote($_), @args)), "</div>\n";
         exit(1);    html_footer();
     exit(1);
 }  }
   
 sub redirect {  
         my($url) = @_;  #
         if ($is_mod_perl) {  # Signal a (fatal) configuration error.
                 Apache->request->status(301);  #
                 Apache->request->header_out(Location => $url);  sub config_error($$)
         }  {
         else {    fatal('500 Internal Error',
                 print "Status: 301 Moved\n";          'Error loading configuration file "<code>%s</code>":<br /><br />' .
                 print "Location: $url\n";          '%s<br />', @_);
         }  
         html_header("Moved");  
         print "This document is located <A HREF=$url>here</A>.\n";  
         print &html_footer;  
         exit(1);  
 }  }
   
 sub safeglob {  
         my ($filename) = @_;  
         my ($dirname);  
         my (@results);  
         my $dh = do {local(*DH);};  
   
         ($dirname = $filename) =~ s|/[^/]+$||;  #
         $filename =~ s|.*/||;  # Sends a redirect to the given URL.
   #
   sub redirect($;$)
   {
     my ($url, $permanent) = @_;
     my ($status, $text);
     if ($permanent) {
       $status = '301';
       $text   = 'Moved Permanently';
     } else {
       $status = '302';
       $text   = 'Found';
     }
     print "Status: $status $text\r\n", "Location: $url\r\n";
     html_header($text);
     print "<p>This document has moved ", &link('here', $url), ".</p>\n";
     html_footer();
     exit(1);
   }
   
         if (opendir($dh, $dirname)) {  
                 my $glob = $filename;  
                 my $t;  
         #       transform filename from glob to regex.  Deal with:  
         #       [, {, ?, * as glob chars  
         #       make sure to escape all other regex chars  
                 $glob =~ s/([\.\(\)\|\+])/\\$1/g;  
                 $glob =~ s/\*/.*/g;  
                 $glob =~ s/\?/./g;  
                 $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg;  
                 foreach (readdir($dh)) {  
                         if (/^${glob}$/) {  
                                 push(@results, $dirname . "/" .$_);  
                         }  
                 }  
         }  
   
         @results;  sub safeglob($)
   {
     my ($filename) = @_;
   
     (my $dirname = $filename) =~ s|/[^/]+$||;
     $filename =~ s|.*/||;
   
     my @results;
     my $dh = do { local (*DH); };
     if (opendir($dh, $dirname)) {
       my $glob = $filename;
       my $t;
   
       #   transform filename from glob to regex.  Deal with:
       #   [, {, ?, * as glob chars
       #   make sure to escape all other regex chars
       $glob =~ s/([\.\(\)\|\+])/\\$1/g;
       $glob =~ s/\*/.*/g;
       $glob =~ s/\?/./g;
       $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg;
       $glob = qr/^$glob$/;
   
       foreach (readdir($dh)) {
         if ($_ =~ $glob && $_ =~ VALID_PATH) {
           push(@results, catfile($dirname, $1)); # untaint
         }
       }
       closedir($dh);
     }
   
     return @results;
 }  }
   
 sub getMimeTypeFromSuffix {  
     my ($fullname) = @_;  
     my ($mimetype, $suffix);  
     my $fh = do {local(*FH);};  
   
     ($suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/;  #
     $mimetype = $MTYPES{$suffix};  # Searches @command_path for the given executable file.
     $mimetype = $MTYPES{'*'} if (!$mimetype);  #
   sub search_path($)
     if (!$mimetype && -f $mime_types) {  {
         # okey, this is something special - search the    my ($command) = @_;
         # mime.types database    for my $d (@command_path) {
         open ($fh, "<$mime_types");      my $cmd = catfile($d, $command);
         while (<$fh>) {      return $cmd if (-x $cmd && !-d _);
             if ($_ =~ /^\s*(\S+\/\S+).*\b$suffix\b/) {    }
                 $mimetype = $1;    return '';
                 last;  }
             }  
         }  
         close ($fh);  #
   # Gets the enscript(1) highlight mode corresponding to the given filename,
   # or undef if unsupported.
   #
   sub getEnscriptHL($)
   {
     return undef unless $allow_enscript;
     my ($filename) = @_;
     while (my ($hl, $regex) = each %enscript_types) {
       return $hl if ($filename =~ $regex);
     }
     return undef;
   }
   
   
   #
   # Gets the MIME type for the given file name.
   #
   sub getMimeType($;$)
   {
     my ($fullname, $binary) = @_;
     $binary = ($keywordsubstitution && $keywordsubstitution =~ /b/)
       unless defined($binary);
   
     (my $suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/;
   
     my $mimetype = $MTYPES{$suffix};
     $mimetype  ||= $MimeTypes->mimeTypeOf($fullname) if defined($MimeTypes);
   
     if (!$mimetype && $suffix ne '*' && -f $mime_types && -r _) {
       my $fh = do { local (*FH); };
       if (open($fh, $mime_types)) {
         my $re = sprintf('^\s*(\S+\/\S+)\s.+\b%s\b', quotemeta($suffix));
         $re = qr/$re/;
         while (my $line = <$fh>) {
           if ($line =~ $re) {
             $mimetype = $1;
             $MTYPES{$suffix} = $mimetype;
             last;
           }
         }
         close($fh);
       } else {
         warn("Can't open MIME types file $mime_types for reading: $!");
     }      }
     }
 # okey, didn't find anything useful ..  
     if (!($mimetype =~ /\S\/\S/)) {    $mimetype ||= $MTYPES{'*'};
         $mimetype = "text/plain";    $mimetype ||= $binary ? 'application/octet-stream' : 'text/plain';
     return $mimetype;
   }
   
   
   ###############################
   # read first lines like head(1)
   ###############################
   sub head($;$)
   {
     my ($fh, $linecount) = @_;
     $linecount ||= 10;
   
     my @buf;
     if ($linecount > 0) {
       for (my $i = 0; !eof($fh) && $i < $linecount; $i++) {
         push @buf, scalar <$fh>;
     }      }
     return $mimetype;    } else {
       @buf = <$fh>;
     }
     return @buf;
 }  }
   
   
 ###############################  ###############################
   # scan vim and Emacs directives
   ###############################
   sub scan_directives(@)
   {
     my $ts = undef;
   
     for (@_) {
       $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/;
     }
   
     ('tabstop' => $ts);
   }
   
   
   sub openOutputFilter()
   {
     return unless $output_filter;
   
     open(STDOUT, "|-") and return;
   
     # child of child
     open(STDERR, '>', devnull()) unless $DEBUG;
     exec($output_filter) or exit -1;
   }
   
   
   ###############################
 # show Annotation  # show Annotation
 ###############################  ###############################
 sub doAnnotate ($$) {  sub doAnnotate($$)
     my ($rev) = @_;  {
     my ($pid);    my ($rev, $tag) = @_;
     my ($pathname, $filename);    $rev = $tag || 'HEAD' if ($rev eq '.');
     my $reader = do {local(*FH);};    (my $pathname = $where) =~ s|((?<=/)Attic/)?[^/]*$||;
     my $writer = do {local(*FH);};    (my $filename = $where) =~ s|^.*/||;
   
     # make sure the revisions a wellformed, for security    # This annotate version is based on the cvs annotate-demo Perl script by
     # reasons ..    # Cyclic Software.  It was written by Cyclic Software,
     if (!($rev =~ /^[\d\.]+$/)) {    # http://www.cyclic.com/, and is in the public domain.
         &fatal("404 Not Found",    # We could abandon the use of rlog, rcsdiff and co using
                 "Malformed query \"$ENV{QUERY_STRING}\"");    # the cvs server in a similiar way one day (..after rewrite).
   
     local (*CVS_IN, *CVS_OUT);
     my $annotate_err;
     my ($h, $err) =
       startproc([ $CMD{cvs}, @annotate_options, 'server' ],
                 '<pipe', \*CVS_IN, '>pipe', \*CVS_OUT,
                 '2>', \$annotate_err);
     fatal('500 Internal Error',
           'Annotate failure (exit status %s), output: <pre>%s</pre>',
           $? >> 8 || -1, $err)
       unless $h;
   
     # OK, first send the request to the server.  A simplified example is:
     #     Root /home/kingdon/zwork/cvsroot
     #     Argument foo/xx
     #     Directory foo
     #     /home/kingdon/zwork/cvsroot/foo
     #     Directory .
     #     /home/kingdon/zwork/cvsroot
     #     annotate
     # although as you can see there are a few more details.
   
     print CVS_IN "Root $cvsroot\n";
     print CVS_IN
       "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n";
   
     # Don't worry about sending valid-requests, the server just needs to
     # support "annotate" and if it doesn't, there isn't anything to be done.
     print CVS_IN "UseUnchanged\n";
     print CVS_IN "Argument -r\n";
     print CVS_IN "Argument $rev\n";
     print CVS_IN "Argument $where\n";
   
     # The protocol requires us to fully fake a working directory (at
     # least to the point of including the directories down to the one
     # containing the file in question).
     # So if $where is "dir/sdir/file", then dirs will be ("dir","sdir","file")
     my $path = '';
     foreach my $dir (split('/', $where)) {
   
       if ($path eq "") {
         # In our example, $dir is "dir".
         $path = $dir;
       } else {
         print CVS_IN "Directory $path\n";
         print CVS_IN "$cvsroot/$path\n";
   
         # In our example, $_ is "sdir" and $path becomes "dir/sdir"
         # And the next time, "file" and "dir/sdir/file" (which then gets
         # ignored, because we don't need to send Directory for the file).
         $path .= "/$dir";
     }      }
     }
     undef $path;
   
     ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;    # And the last "Directory" before "annotate" is the top level.
     ($filename = $where) =~ s/^.*\///;    print CVS_IN "Directory .\n";
     print CVS_IN "$cvsroot\n";
   
     http_header();    print CVS_IN "annotate\n";
   
     navigateHeader ($scriptwhere,$pathname,$filename,$rev, "annotate");    # OK, we've sent our command to the server.  Thing to do is to
     print "<h3 align=center>Annotation of $pathname$filename, Revision $rev</h3>\n";    # close the writer side and get all the responses.
     if (!close(CVS_IN)) {
       $h->finish();
       fatal('500 Internal Error',
             'Annotate failure (exit status %s): <code>%s</code>, output: ' .
             '<pre>%s</pre>', $? >> 8, $!, $annotate_err);
     }
   
     # this seems to be necessary    navigateHeader($scriptwhere, $pathname, $filename, $rev, 'annotate');
     $| = 1; $| = 0; # Flush  
   
     # this annotate version is based on the    my $revtype = ($rev =~ /\./) ? 'revision' : 'tag'; # TODO: tag -> branch/tag?
     # cvs annotate-demo Perl script by Cyclic Software    print '<h3 style="text-align: center">Annotation of ',
     # It was written by Cyclic Software, http://www.cyclic.com/, and is in      htmlquote("$pathname$filename"), ", $revtype $rev</h3>\n";
     # the public domain.  
     # we could abandon the use of rlog, rcsdiff and co using  
     # the cvsserver in a similiar way one day (..after rewrite)  
     $pid = open2($reader, $writer, "cvs server") || fatal ("500 Internal Error",  
                                                                "Fatal Error - unable to open cvs for annotation");  
   
     # OK, first send the request to the server.  A simplified example is:  
     #     Root /home/kingdon/zwork/cvsroot  
     #     Argument foo/xx  
     #     Directory foo  
     #     /home/kingdon/zwork/cvsroot/foo  
     #     Directory .  
     #     /home/kingdon/zwork/cvsroot  
     #     annotate  
     # although as you can see there are a few more details.  
   
     print $writer "Root $cvsroot\n";  
     print $writer "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n";  
     # Don't worry about sending valid-requests, the server just needs to  
     # support "annotate" and if it doesn't, there isn't anything to be done.  
     print $writer "UseUnchanged\n";  
     print $writer "Argument -r\n";  
     print $writer "Argument $rev\n";  
     print $writer "Argument $where\n";  
   
     # The protocol requires us to fully fake a working directory (at    # Ready to get the responses from the server.
     # least to the point of including the directories down to the one    # For example:
     # containing the file in question).    #     E Annotations for foo/xx
     # So if $where is "dir/sdir/file", then @dirs will be ("dir","sdir","file")    #     E ***************
     my @dirs = split('/', $where);    #     M 1.3          (kingdon  06-Sep-97): hello
     my $path = "";    #     ok
     foreach (@dirs) {    my ($lineNr) = 0;
         if ($path eq "") {    my ($oldLrev, $oldLusr) = ("", "");
             # In our example, $_ is "dir".    my ($revprint, $usrprint);
             $path = $_;  
         }    if ($annTable) {
         else {      print <<EOF;
             print $writer "Directory $path\n";  <table style="border: none" cellspacing="0" cellpadding="0" summary="Annotation">
             print $writer "$cvsroot/$path\n";  EOF
             # In our example, $_ is "sdir" and $path becomes "dir/sdir"    } else {
             # And the next time, "file" and "dir/sdir/file" (which then gets      print "<pre>";
             # ignored, because we don't need to send Directory for the file).    }
             $path .= "/$_";  
         }    # prefetch several lines
     my @buf = head(*CVS_OUT);
   
     my %d = scan_directives(@buf);
   
     while (@buf || !eof(*CVS_OUT)) {
   
       $_ = @buf ? shift @buf : <CVS_OUT>;
       my @words = split;
   
       # Adding one is for the (single) space which follows $words[0].
       my $rest = substr($_, length($words[0]) + 1);
       if ($words[0] eq "E") {
         next;
       } elsif ($words[0] eq "M") {
         $lineNr++;
         (my $lrev = substr($_, 2,  13)) =~ y/ //d;
         (my $lusr = substr($_, 16, 9))  =~ y/ //d;
         my $line = substr($_, 36);
         # TODO: this does not work for branch/tag revisions.
         my $isCurrentRev = ($rev eq $lrev);
   
         # we should parse the date here ..
         if ($lrev eq $oldLrev) {
           $revprint = sprintf('%-8s', '');
         } else {
           $revprint = sprintf('%-8s', $lrev);
           $revprint =~ s|(\S+)|&link($1, uri_escape($filename)."$query#rev$1")|e;
           $oldLusr = '';
         }
   
         $usrprint = ($lusr eq $oldLusr) ? '' : $lusr;
         $oldLrev = $lrev;
         $oldLusr = $lusr;
   
         print $is_textbased ? '<b>' : '<span class="current-rev">'
           if $isCurrentRev;
   
         $usrprint = sprintf('%-8s', $usrprint);
         printf '%s%s %s %4d:', $revprint, $isCurrentRev ? '!' : ' ',
           htmlquote($usrprint), $lineNr;
         print spacedHtmlText($line, $d{tabstop});
   
         print $is_textbased ? '</b>' : '</span>' if $isCurrentRev;
   
       } elsif ($words[0] eq "ok") {
         # We could complain about any text received after this, like the
         # CVS command line client.  But for simplicity, we don't.
   
       } elsif ($words[0] eq "error") {
         fatal("500 Internal Error",
               'Error occured during annotate: <b>%s</b>', $_);
     }      }
     # And the last "Directory" before "annotate" is the top level.    }
     print $writer "Directory .\n";    $h->finish();
     print $writer "$cvsroot\n";  
     if ($annTable) {
     print $writer "annotate\n";      print "</table>";
     # OK, we've sent our command to the server.  Thing to do is to    } else {
     # close the writer side and get all the responses.  If "cvs server"      print "</pre>";
     # were nicer about buffering, then we could just leave it open, I think.    }
     close ($writer) || die "cannot close: $!";    html_footer();
   }
     # Ready to get the responses from the server.  
     # For example:  ###############################
     #     E Annotations for foo/xx  # make Checkout
     #     E ***************  ###############################
     #     M 1.3          (kingdon  06-Sep-97): hello  sub doCheckout($$$)
     #     ok  {
     my ($lineNr) = 0;    my ($fullname, $rev, $tag) = @_;
     my ($oldLrev, $oldLusr) = ("", "");    $rev = $tag || undef if (!$rev || $rev eq '.');
     my ($revprint, $usrprint);  
     if ($annTable) {    # Start resolving whether we will do a markup view or not.
         print "<table border=0 cellspacing=0 cellpadding=0>\n";    my $do_markup = undef;
     my $want_type = $input{'content-type'};
   
     # No markup if markup disallowed.
     $do_markup = 0 unless $allow_markup;
   
     # No markup if checkout magic cookie in URL.
     $do_markup = 0 if (!defined($do_markup) && $doCheckout);
   
     # Do markup if explicitly asked using cvsweb-markup content type.  If the
     # asked content type is anything else, no markup.
     if (!defined($do_markup) && $want_type) {
       if ($want_type =~ CVSWEBMARKUP) {
         $want_type = undef;
         $do_markup = 1;
       } else {
         $do_markup = 0;
     }      }
     else {    }
         print "<pre>";  
     # Ok, if $do_markup is still undefined, we know that a download has not been
     # explicitly asked.  For the last check further down below we'll need to
     # know if the file is binary, and possibly run a log on it.
     my $needlog = $do_markup || $use_moddate;
   
     my $moddate = undef;
     my $revopt;
     if (defined($rev)) {
       $revopt = "-r$rev";
       if ($needlog) {
         readLog($fullname, $rev);
         $moddate   = $date{$rev};
         # TODO: even this does not work for branch tags, but only normal tags :(
         $moddate ||= $date{$symrev{$rev}} if defined($symrev{$rev});
     }      }
     while (<$reader>) {    } else {
         my @words = split;      $revopt = "-rHEAD";
         # Adding one is for the (single) space which follows $words[0].      if ($needlog) {
         my $rest = substr ($_, length ($words[0]) + 1);        readLog($fullname);
         if ($words[0] eq "E") {        $moddate = $date{$symrev{HEAD}};
             next;  
         }  
         elsif ($words[0] eq "M") {  
             $lineNr++;  
             my $lrev = substr ($_, 2, 13);  
             my $lusr = substr ($_, 16,  9);  
             my $line = substr ($_, 36);  
             # we should parse the date here ..  
             if ($lrev eq $oldLrev) {  
                 $revprint = "             ";  
             }  
             else {  
                 $revprint = $lrev; $oldLusr = "";  
             }  
             if ($lusr eq $oldLusr) {  
                 $usrprint = "         ";  
             }  
             else {  
                 $usrprint = $lusr;  
             }  
             $oldLrev = $lrev;  
             $oldLusr = $lusr;  
             # is there a less timeconsuming way to strip spaces ?  
             ($lrev = $lrev) =~ s/\s+//g;  
             my $isCurrentRev = ($rev eq $lrev);  
   
             print "<b>" if ($isCurrentRev);  
             printf ("%8s%s%8s %4d:", $revprint, ($isCurrentRev ? "|" : " "), $usrprint, $lineNr);  
             print spacedHtmlText($line);  
             print "</b>" if ($isCurrentRev);  
         }  
         elsif ($words[0] eq "ok") {  
             # We could complain about any text received after this, like the  
             # CVS command line client.  But for simplicity, we don't.  
         }  
         elsif ($words[0] eq "error") {  
             fatal ("500 Internal Error", "Error occured during annotate: <b>$_</b>");  
         }  
     }      }
     if ($annTable) {    }
         print "</table>";  
     my $cr = abs_path($cvsroot) || $cvsroot;
     # abs_path() taints when run as a CGI...
     if ($cr =~ VALID_PATH) {
       $cr = $1;
     } else {
       fatal('500 Internal Error', 'Illegal CVS root: <code>%s</code>', $cr);
     }
     # Use abs_path() to work around a bug of cvs -p; expand symlinks if we can.
     my @cmd = ($CMD{cvs}, @cvs_options, '-d', $cr, 'co', '-p', $revopt, $where);
   
     local (*CVS_OUT, *CVS_ERR);
     my ($h, $err) =
       startproc(\@cmd, \"", '>pipe', \*CVS_OUT, '2>pipe', \*CVS_ERR);
     fatal('500 Internal Error',
           'Checkout failure (exit status %s), output: <pre>%s</pre>',
           $? >> 8 || -1, $err)
       unless $h;
   
     if (eof(CVS_ERR)) {
       $h->finish();
       fatal("404 Not Found", '%s is not (any longer) pertinent', $where);
     }
   
     #===================================================================
     #Checking out squid/src/ftp.c
     #RCS:  /usr/src/CVS/squid/src/ftp.c,v
     #VERS: 1.1.1.28.6.2
     #***************
   
     # Parse CVS header
     my ($revision, $filename, $cvsheader);
     $filename = "";
     while (<CVS_ERR>) {
       last if (/^\*\*\*\*/);
       $revision = $1 if (/^VERS: (.*)$/);
   
       if (/^Checking out (.*)$/) {
         ($filename = $1) =~ s|^\./+||;
     }      }
     else {      $cvsheader .= $_;
         print "</pre>";    }
     close(CVS_ERR);
   
     if ($filename ne $where) {
       $h->finish();
       fatal("500 Internal Error",
             'Unexpected output from cvs co: <pre>%s</pre> ' .
             '(expected "<code>%s</code>" but got "<code>%s</code>")',
             $cvsheader, $where, $filename);
     }
   
     # Last checks whether we'll do markup or not.
     my $isbin = $keywordsubstitution && $keywordsubstitution =~ /b/;
     my $mimetype = getMimeType($fullname, $isbin);
   
     # If we still are not sure whether to do markup or not:
     # if the MIME type is "viewable" or this is not a binary file, do.
     $do_markup = !$isbin || viewable($mimetype) unless defined($do_markup);
   
     if ($do_markup) {
   
       # If this is something we'll be linking to in the markup view, we are
       # done with this particular output from "cvs co" and must discard it.
       my $linked = $mimetype =~ m{^image/|application/pdf$}i;
       if ($linked) {
         close(CVS_OUT);
         $h->finish();
     }      }
     close ($reader) || warn "cannot close: $!";  
     wait;      # Here we know the last modified date, but don't know if tags have been
       # added afterwards (those are shown in the markup view): no last-modified.
       cvswebMarkup(\*CVS_OUT, $fullname, $revision, $isbin, $mimetype, $needlog);
   
       $h->finish() unless $linked;
   
     } else {
       http_header($want_type || $mimetype, $moddate);
       local $/ = undef;
       print <CVS_OUT>;
       $h->finish();
     }
 }  }
   
   
   sub cvswebMarkup($$$$$$;$)
   {
     my ($filehandle, $fullname, $rev, $isbin, $mimetype, $logged, $mod) = @_;
   
     (my $pathname = $where) =~ s|((?<=/)Attic/)?[^/]*$||;
     (my $filename = $where) =~ s|^.*/||;
   
     navigateHeader($scriptwhere, $pathname, $filename, $rev, 'view', $mod);
   
     print <<EOF;
   <hr />
   <div class="log-markup">
   File:&nbsp;
   EOF
     print &clickablePath($where, 1), "<br />\n";
   
     if ($show_log_in_markup) {
       readLog($fullname) unless $logged; #,$rev);
       printLog($rev, $mimetype, $isbin);
     } else {
       print "Revision: <b>$rev</b><br />\n";
       print 'Tag: ', htmlquote($input{only_with_tag}), "<br />\n"
         if $input{only_with_tag};
     }
     print "</div>\n<hr />";
     my $url = download_url(uri_escape($filename), $rev, $mimetype);
   
     if ($mimetype =~ m|^image/|i) {
       printf '<img src="%s" alt="%s" /><br />',
         $url . $barequery, htmlquote($filename);
     } elsif (lc($mimetype) eq 'application/pdf') {
       printf '<embed src="%s" width="100%%" height="100%%" /><br />',
         $url . $barequery;
     } else {
   
       print "<pre>\n";
       my $linenumbers = $input{ln} || 0;
   
       if (my $enscript_hl = getEnscriptHL($filename)) {
         doEnscript($filehandle, $enscript_hl, $linenumbers);
   
       } else {
         my $ln  = 0;
         my @buf = ();
         my $ts  = undef;
   
         if ($preformat_in_markup) {
           # prefetch several lines
           @buf = head($filehandle);
           my %d = scan_directives(@buf);
           $ts = $d{tabstop};
         }
   
         while (@buf || !eof($filehandle)) {
           $_ = @buf ? shift @buf : <$filehandle>;
           if ($linenumbers) {
             $ln++;
             printf '<a id="l%d" class="src">%5d: </a>', ($ln) x 2;
           }
           print $preformat_in_markup ? spacedHtmlText($_, $ts) : htmlquote($_);
         }
       }
   
       print "</pre>\n";
     }
     html_footer();
   }
   
   
   sub viewable($)
   {
     return shift =~ m{^((text|image)/|application/pdf)}i;
   }
   
   
 ###############################  ###############################
 # make Checkout  # Show Colored Diff
 ###############################  ###############################
 sub doCheckout {  sub doDiff($$$$$$)
     my ($fullname, $rev) = @_;  {
     my ($mimetype,$revopt);    my ($fullname, $r1, $tr1, $r2, $tr2, $f) = @_;
     my $fh = do {local(*FH);};  
   
     # make sure the revisions a wellformed, for security    if (forbidden($fullname)) {
     # reasons ..      fatal('403 Forbidden', 'Access to %s forbidden.', $where);
     if (defined($rev) && !($rev =~ /^[\d\.]+$/)) {    }
         &fatal("404 Not Found",  
                 "Malformed query \"$ENV{QUERY_STRING}\"");    my ($rev1, $sym1);
     if ($r1 =~ /([^:]+)(:(.+))?/) {
       $rev1 = $1;
       $sym1 = $3;
     }
     if ($r1 eq 'text') {
       $rev1 = $tr1;
       $sym1 = "";
     }
   
     my ($rev2, $sym2);
     if ($r2 =~ /([^:]+)(:(.+))?/) {
       $rev2 = $1;
       $sym2 = $3;
     }
     if ($r2 eq 'text') {
       $rev2 = $tr2;
       $sym2 = "";
     }
   
     #
     # rev1 and rev2 are now both numeric revisions.
     # Thus we do a DWIM here and swap them if rev1 is after rev2.
     # XXX should we warn about the fact that we do this?
     if (&revcmp($rev1, $rev2) > 0) {
       my ($tmp1, $tmp2) = ($rev1, $sym1);
       ($rev1, $sym1) = ($rev2, $sym2);
       ($rev2, $sym2) = ($tmp1, $tmp2);
     }
   
     my $mimetype = getMimeType($fullname);
   
     #
     #  Check for per-MIME type diff commands.
     #
     my $diffcmd = undef;
     if (my $diffcmds = $DIFF_COMMANDS{lc($mimetype)}) {
       if ($f =~ /^ext(\d*)$/) {
         my $n = $1 || 0;
         $diffcmd = $diffcmds->[$n];
     }      }
     }
     if ($diffcmd && $diffcmd->{cmd} && $diffcmd->{name}) {
   
     # get mimetype      if ($diffcmd->{args} && ref($diffcmd->{args}) ne 'ARRAY') {
     if (defined($input{"content-type"}) && ($input{"content-type"} =~ /\S\/\S/)) {        fatal('500 Internal Error',
         $mimetype = $input{"content-type"}              'Configuration error: arguments to external diff tools must ' .
               'be given as array refs.  See "<code>%s</code>" in ' .
               '<code>%%DIFF_COMMANDS</code>.',
               $diffcmd->{name});
     }      }
     else {  
         $mimetype = &getMimeTypeFromSuffix($fullname);      (my $cvsname = $where) =~ s/\.diff$//;
   
       # Create two temporary files with the two revisions
       my $temp_fn1 = checkout_to_temp($cvsroot, $cvsname, $rev1);
       my $temp_fn2 = checkout_to_temp($cvsroot, $cvsname, $rev2);
   
       # Execute chosen diff binary.
       local (*DIFF_OUT);
       my @cmd = ($diffcmd->{cmd});
       push(@cmd, @{$diffcmd->{args}}) if $diffcmd->{args};
       push(@cmd, $temp_fn1, $temp_fn2);
       my ($h, $err) = startproc(\@cmd, \"", '>pipe', \*DIFF_OUT);
       if (!$h) {
         unlink($temp_fn1);
         unlink($temp_fn2);
         fatal('500 Internal Error',
               'Diff failure (exit status %s), output: <pre>%s</pre>',
               $? >> 8 || -1, $err);
     }      }
   
     if (defined($rev)) {      http_header($diffcmd->{type} || 'text/plain');
         $revopt = "-r$rev";      local $/ = undef;
         if ($use_moddate) {      print <DIFF_OUT>;
             readLog($fullname,$rev);      $h->finish();
             $moddate=$date{$rev};      unlink($temp_fn1);
         }      unlink($temp_fn2);
   
       exit;
     }
   
     #
     # Normal CVS diff.
     #
   
     $f = $DEFAULTVALUE{f} || 'u' if ($f =~ /^ext\d*$/);
     my $difftype = $DIFFTYPES{$f};
     if (!$difftype) {
       fatal("400 Bad arguments", 'Diff format %s not understood', $f);
     }
   
     my @difftype       = @{$difftype->{opts}};
     my $human_readable = $difftype->{colored};
   
     # Apply special diff options.
     push @difftype, '-p' if $showfunc;
   
     if ($human_readable) {
       push(@difftype, '-w')  if $hr_ignwhite;
       push(@difftype, '-kk') if $hr_ignkeysubst;
     }
   
     my $fh = do { local (*FH); };
     if (!open($fh, "-|")) {    # child
       open(STDERR, ">&STDOUT");    # Redirect stderr to stdout
       openOutputFilter();
       exec($CMD{rcsdiff}, @rcsdiff_options, @difftype, "-r$rev1", "-r$rev2",
            $fullname) or exit -1;
     }
   
     if ($human_readable) {
       #
       # Human readable diff.
       #
       human_readable_diff($fh, $rev2);
       html_footer();
       gzipclose();
       exit;
   
     } elsif ($f =~ /^([ucs])c$/) {
       #
       # Enscript colored diff.
       #
       my $hl = 'diff';
       $hl .= $1 if ($1 eq 'u' || $1 eq 's');
       (my $where_nd = $where)       =~ s/\.diff$//;
       (my $pathname = $where_nd)    =~ s|((?<=/)Attic/)?[^/]*$||;
       (my $filename = $where_nd)    =~ s|^.*/||;
       (my $swhere   = $scriptwhere) =~ s|\.diff$||;
       navigateHeader($swhere, $pathname, $filename, $rev2, 'diff');
       printf(<<EOF, $where_nd, $rev1, $rev2);
   <h3 style="text-align: center">Diff for /%s between versions %s and %s</h3>
   <pre>
   EOF
       doEnscript(\$fh, $hl, 0, 'cvsweb_diff');
       print <<EOF;
   </pre>
   <hr style="width: 100%" />
   <form method="get" action="$scriptwhere">
   EOF
       printDiffSelectStickyVars();
       print 'Diff format: ';
       printDiffSelect($use_java_script);
       print "<input type=\"submit\" value=\"Show\" />\n</form>\n";
       html_footer();
       gzipclose();
       exit;
   
     } else {
       #
       # Plain diff.
       #
       http_header("text/plain");
     }
   
     #
     #===================================================================
     #RCS file: /home/ncvs/src/sys/netinet/tcp_output.c,v
     #retrieving revision 1.16
     #retrieving revision 1.17
     #diff -c -r1.16 -r1.17
     #*** /home/ncvs/src/sys/netinet/tcp_output.c     1995/11/03 22:08:08     1.16
     #--- /home/ncvs/src/sys/netinet/tcp_output.c     1995/12/05 17:46:35     1.17
     #
     # Ideas:
     # - nuke the stderr output if it's what we expect it to be
     # - Add "no differences found" if the diff command supplied no output.
     #
     #*** src/sys/netinet/tcp_output.c     1995/11/03 22:08:08     1.16
     #--- src/sys/netinet/tcp_output.c     1995/12/05 17:46:35     1.17 RELENG_2_1_0
     # (bogus example, but...)
     #
     my ($f1, $f2);
     if (grep { $_ eq '-u' } @difftype) {
       $f1 = '---';
       $f2 = '\+\+\+';
     } else {
       $f1 = '\*\*\*';
       $f2 = '---';
     }
   
     while (<$fh>) {
       if (m|^$f1 $cvsroot|o) {
         s|$cvsroot/||o;
         if ($sym1) {
           chop;
           $_ .= " $sym1\n";
         }
       } elsif (m|^$f2 $cvsroot|o) {
         s|$cvsroot/||o;
   
         if ($sym2) {
           chop;
           $_ .= " $sym2\n";
         }
     }      }
     else {      print $_;
         $revopt = "-rHEAD";    }
         if ($use_moddate) {    close($fh);
             readLog($fullname);  }
             $moddate=$date{$symrev{HEAD}};  
         }  
   ###############################
   # Show Logs ..
   ###############################
   sub getDirLogs($$@)
   {
     my ($cvsroot, $dirname, @otherFiles) = @_;
     my $tag = $input{only_with_tag};
     my $DirName = catdir($cvsroot, $where);
   
     my @files = &safeglob("$DirName/*,v");
     push (@files, &safeglob("$DirName/Attic/*,v")) unless $input{hideattic};
     foreach my $file (@otherFiles) {
       push(@files, catfile($DirName, $file));
     }
   
     # Weed out unreadable files.
     my $i = 0;
     my @unreadable = ();
     while ($i < scalar(@files)) {
       # Note: last modified files from subdirs returned by
       # findLastModifiedSubdirs() come without the ,v suffix so they're not
       # found here, but have already been checked for readability.  *cough*
       if (-r $files[$i] || !-e _) {
         $i++;
       } else {
         push(@unreadable, splice(@files, $i, 1));
     }      }
     }
     ### just for the record:  
     ### 'cvs co' seems to have a bug regarding single checkout of  
     ### directories/files having spaces in it;  
     ### this is an issue that should be resolved on cvs's side  
     #  
     # Safely for a child process to read from.  
     if (! open($fh, "-|")) { # child  
       open(STDERR, ">&STDOUT"); # Redirect stderr to stdout  
       exec("cvs", "-d", $cvsroot, "co", "-p", $revopt, $where);  
     }  
 #===================================================================  
 #Checking out squid/src/ftp.c  
 #RCS:  /usr/src/CVS/squid/src/ftp.c,v  
 #VERS: 1.1.1.28.6.2  
 #***************  
   
     # Parse CVS header    # If there are no files, we're done.
     my ($revision, $filename, $cvsheader);    return @unreadable unless @files;
     while(<$fh>) {  
         last if (/^\*\*\*\*/);    my @cmd = ($CMD{rlog});
         $revision = $1 if (/^VERS: (.*)$/);    # Can't use -r<tag> as '-' is allowed in tagnames,
         if (/^Checking out (.*)$/) {    # but misinterpreted by rlog.
                 $filename = $1;    push(@cmd, '-r') unless defined($tag);
                 $filename =~ s/^\.\/*//;  
         }    my $fh = do { local (*FH); };
         $cvsheader .= $_;    if (!open($fh, '-|')) {                       # Child
       open(STDERR, '>', devnull()) unless $DEBUG; # Ignore rlog's complaints.
       openOutputFilter();
       if ($file_list_len && $file_list_len > 1) {
         while (scalar(@files) > $file_list_len) {  # Process files in chunks.
           system(@cmd, splice(@files, 0, $file_list_len)) == 0 or exit -1;
         }
     }      }
     if ($filename ne $where) {      exec(@cmd, @files) or exit -1;
         &fatal("500 Internal Error",    }
                "Unexpected output from cvs co: $cvsheader"    undef @cmd;
                . "<p><b>Check whether the directory $cvsroot/CVSROOT exists "  
                . "and the script has write-access to the CVSROOT/history "    my $state = 'start';
                . "file if it exists."    my ($date, $branchpoint, $branch, $log, @filetags);
                . "<br>The script needs to place lock files in the "    my ($rev, $revision, $revwanted, $filename, $head, $author, $keywordsubst);
                . "directory the file is in as well.</b>");  
     while (<$fh>) {
       if ($state eq "start") {
   
         #Next file. Initialize file variables
         $rev         = '';
         $revwanted   = '';
         $branch      = '';
         $branchpoint = '';
         $filename    = '';
         $log         = '';
         $revision    = '';
         %symrev      = ();
         @filetags    = ();
         $keywordsubst= '';
   
         #jump to head state
         $state = "head";
     }      }
     $| = 1;  
   
     if ($mimetype eq "text/x-cvsweb-markup") {      again:
         &cvswebMarkup($fh,$fullname,$revision);  
       if ($state eq "head") {
   
         #$rcsfile = $1 if (/^RCS file: (.+)$/); #not used (yet)
   
         if (/^Working file: (.+)$/) {
           $filename = $1;
         } elsif (/^head: (.+)$/) {
           $head = $1;
         } elsif (/^branch: (.+)$/) {
           $branch = $1;
         } elsif (/^keyword substitution: (.+)$/) {
           $keywordsubst = $1;
         } elsif (/^symbolic names:/) {
           $state = "tags";
           ($branch = $head) =~ s/\.\d+$//
             if $branch eq '';
           $branch =~ s/(\d+)$/0.$1/;
           $symrev{MAIN}  = $branch;
           $symrev{HEAD}  = $branch;
           $alltags{MAIN} = 1;
           $alltags{HEAD} = 1;
           push (@filetags, "MAIN", "HEAD");
         } elsif ($_ =~ LOG_REVSEPR) {
           $state = "log";
           $rev   = '';
           $date  = '';
           $log   = '';
   
           # Try to reconstruct the relative filename if RCS spits out a full path
           $filename =~ s%^\Q$DirName\E/%%;
         }
         next;
     }      }
     else {  
         http_header($mimetype);      if ($state eq "tags") {
         print <$fh>;        if (/^\s+([^:]+):\s+([\d\.]+)\s*$/) {
           push (@filetags, $1);
           $symrev{$1}  = $2;
           $alltags{$1} = 1;
           next;
         } elsif (/^\S/) {
   
           if (defined($tag)) {
             if (defined($symrev{$tag}) || $tag eq "HEAD") {
               $revwanted    = $symrev{$tag eq "HEAD" ? "MAIN" : $tag};
               ($branch      = $revwanted) =~ s/\b0\.//;
               ($branchpoint = $branch)    =~ s/\.?\d+$//;
               $revwanted    = '' if ($revwanted ne $branch);
             } elsif ($tag ne "HEAD") {
               $state = "skip";
               next;
             }
           }
   
           foreach my $tagfound (@filetags) {
             $tags{$tagfound} = 1;
           }
           $state = "head";
           goto again;
         }
     }      }
     close($fh);  
       if ($state eq "log") {
         if ($_ =~ LOG_REVSEPR || $_ =~ LOG_FILESEPR) {
   
           # End of a log entry.
           my $revbranch = $rev;
           $revbranch =~ s/\.\d+$//;
   
           if ($revwanted eq '' && $branch ne '' && $branch eq $revbranch
               || !defined($tag))
           {
             $revwanted = $rev;
           }
   
           if ($revwanted ne ''
               ? $rev eq $revwanted
               : $branchpoint ne ''
                 ? $rev eq $branchpoint
                 : 0
               && ($rev eq $head))
           {    # Don't think head is needed here..
             my @finfo = ($rev, $date, $log, $author, $filename, $keywordsubst);
             (my $name = $filename) =~ s%/.*%%;
             $fileinfo{$name} = [@finfo];
             $state = "done" if ($rev eq $revwanted);
           }
           $rev  = '';
           $date = '';
           $log  = '';
         } elsif ($date eq ''
                  && m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);|)
         {
           my $yr    = $1;
           $yr      -= 1900 if ($yr > 100); # Damn 2-digit year routines :-)
           $date     = timegm($6, $5, $4, $3, $2 - 1, $yr);
           ($author) = /author: ([^;]+)/;
           $state    = 'log';
           $log      = '';
           next;
         } elsif ($rev eq '' && /^revision (\d+(?:\.\d+)+).*$/) {
           $rev = $1;    # .*$ eats up the locker(lockers?) info, if any
           next;
         } else {
           $log .= $_;
         }
       }
   
       if ($_ =~ LOG_FILESEPR) {
         $state = "start";
         next;
       }
     }
   
     my $linesread = $. || 0;
     close($fh);
   
     if ($linesread == 0) {
       fatal('500 Internal Error',
             'Failed to spawn GNU rlog on <em>"%s"</em>.<br /><br />Did you set the <b><code>@command_path</code></b> in your configuration file correctly? (Currently: "<code>%s</code>")',
             htmlquote(join(', ', @files)), join(':', @command_path));
     }
   
     return @unreadable;
 }  }
   
 sub cvswebMarkup {  
     my ($filehandle,$fullname,$revision) = @_;  
     my ($pathname, $filename);  
   
     ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;  sub readLog($;$)
     ($filename = $where) =~ s/^.*\///;  {
     my ($fileurl) = urlencode($filename);    my ($fullname, $revision) = @_;
     my ($symnames, $head, $rev, $br, $brp, $branch, $branchrev);
   
     http_header();    undef %symrev;
     undef %revsym;
     undef @allrevisions;
     undef %date;
     undef %author;
     undef %state;
     undef %difflines;
     undef %log;
     $keywordsubstitution = '';
   
     navigateHeader ($scriptwhere, $pathname, $filename, $revision, "view");    my $fh = do { local (*FH); };
     print "<HR noshade>";    if (!open($fh, "-|")) {    # child
     print "<table width=\"100%\"><tr><td bgcolor=\"$markupLogColor\">";      openOutputFilter();
     print "File: ", &clickablePath($where, 1);      $revision = defined($revision) ? "-r$revision" : '';
     print "&nbsp;";      if ($revision =~ /\./) {
     &download_link(urlencode($fileurl), $revision, "(download)");        # Normal revision, not a branch/tag name.
     if (!$defaultTextPlain) {        exec($CMD{rlog}, $revision, $fullname) or exit -1;
         print "&nbsp;";      } else {
         &download_link(urlencode($fileurl), $revision, "(as text)",        exec($CMD{rlog}, $fullname) or exit -1;
                "text/plain");  
     }      }
     print "<BR>\n";    }
     if ($show_log_in_markup) {  
         readLog($fullname); #,$revision);    my $curbranch = undef;
         printLog($revision,0);    while (<$fh>) {
       if ($symnames) {
         if (/^\s+([^:]+):\s+([\d\.]+)/) {
           $symrev{$1} = $2;
           next;
         } else {
           $symnames = 0;
         }
     }      }
     else {      if (/^head:\s+([\d\.]+)/) {
         print "Version: <B>$revision</B><BR>\n";        $head = $1;
         print "Tag: <B>", $input{only_with_tag}, "</b><br>\n" if      } elsif (/^branch:\s+([\d\.]+)/) {
             $input{only_with_tag};        $curbranch = $1;
       } elsif (/^symbolic names/) {
         $symnames = 1;
       } elsif (/^keyword substitution: (.+)$/) {
         $keywordsubstitution = $1;
       } elsif (/^-----/) {
         last;
     }      }
     print "</td></tr></table>";    }
     my @content = <$filehandle>;    ($curbranch = $head) =~ s/\.\d+$// if (!defined($curbranch));
     my $url = download_url($fileurl, $revision, $mimetype);  
     print "<HR noshade>";    # each log entry is of the form:
     if ($mimetype =~ /^image/) {    # ----------------------------
         print "<IMG SRC=\"$url$barequery\"><BR>";    # revision 3.7.1.1
     # date: 1995/11/29 22:15:52;  author: fenner;  state: Exp;  lines: +5 -3
     # log info
     # ----------------------------
   
     # For a locked revision, the first line after the separator
     # becomes smth like
     # revision 9.19       locked by: vassilii;
   
     logentry:
   
     while ($_ !~ LOG_FILESEPR) {
       $_ = <$fh>;
       last logentry if (!defined($_));    # EOF
       if (/^revision (\d+(?:\.\d+)+)/) {
         $rev = $1;
         unshift(@allrevisions, $rev);
       } elsif ($_ =~ LOG_FILESEPR || $_ =~ LOG_REVSEPR) {
         next logentry;
       } else {
   
         # The rlog output is syntactically ambiguous.  We must
         # have guessed wrong about where the end of the last log
         # message was.
         # Since this is likely to happen when people put rlog output
         # in their commit messages, don't even bother keeping
         # these lines since we don't know what revision they go with
         # any more.
         next logentry;
     }      }
     else {      $_ = <$fh>;
         print "<PRE>";      if (
         foreach (@content) {        m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);\s+author:\s+(\S+);\s+state:\s+(\S+);\s+(lines:\s+([0-9\s+-]+))?|
             print spacedHtmlText($_);        )
         }      {
         print "</PRE>";        my $yr           = $1;
         $yr             -= 1900 if ($yr > 100); # Damn 2-digit year routines :-)
         $date{$rev}      = timegm($6, $5, $4, $3, $2 - 1, $yr);
         $author{$rev}    = $7;
         $state{$rev}     = $8;
         $difflines{$rev} = $10;
       } else {
         fatal("500 Internal Error", 'Error parsing RCS output: %s', $_);
     }      }
 }  
   
 sub viewable($) {    line:
     my ($mimetype) = @_;      while (<$fh>) {
         next line if (/^branches:\s/);
         last line if ($_ =~ LOG_FILESEPR || $_ =~ LOG_REVSEPR);
         $log{$rev} .= $_;
       }
     }
     close($fh);
   
     $mimetype =~ m%^text/% ||    @revorder = reverse sort { revcmp($a, $b) } @allrevisions;
     $mimetype =~ m%^image/% ||  
     0;  
 }  
   
 ###############################    #
 # Show Colored Diff    # HEAD is an artificial tag which is simply the highest tag number on the main
 ###############################    # branch, unless there is a branch tag in the RCS file in which case it's the
 sub doDiff {    # highest revision on that branch.  Find it by looking through @revorder; it
         my($fullname, $r1, $tr1, $r2, $tr2, $f) = @_;    # is the first commit listed on the appropriate branch.
         my $fh = do {local(*FH);};    # This is not neccesary the same revision as marked as head in the RCS file.
         my ($rev1, $rev2, $sym1, $sym2, @difftype, $diffname, $f1, $f2);    my $headrev = $curbranch || "1";
     ($symrev{MAIN} = $headrev) =~ s/(\d+)$/0.$1/;
   
         if ($r1 =~ /([^:]+)(:(.+))?/) {    foreach $rev (@revorder) {
             $rev1 = $1;      if ($rev =~ /^(\S*)\.\d+$/ && $headrev eq $1) {
             $sym1 = $3;        $symrev{HEAD} = $rev;
         }        last;
         if ($r1 eq 'text') {      }
             $rev1 = $tr1;    }
             $sym1 = "";    ($symrev{HEAD} = $headrev) =~ s/\.\d+$// unless defined($symrev{HEAD});
         }  
         if ($r2 =~ /([^:]+)(:(.+))?/) {  
             $rev2 = $1;  
             $sym2 = $3;  
         }  
         if ($r2 eq 'text') {  
             $rev2 = $tr2;  
             $sym2 = "";  
         }  
         # make sure the revisions a wellformed, for security  
         # reasons ..  
         if (!($rev1 =~ /^[\d\.]+$/) || !($rev2 =~ /^[\d\.]+$/)) {  
             &fatal("404 Not Found",  
                     "Malformed query \"$ENV{QUERY_STRING}\"");  
         }  
 #  
 # rev1 and rev2 are now both numeric revisions.  
 # Thus we do a DWIM here and swap them if rev1 is after rev2.  
 # XXX should we warn about the fact that we do this?  
         if (&revcmp($rev1,$rev2) > 0) {  
             my ($tmp1, $tmp2) = ($rev1, $sym1);  
             ($rev1, $sym1) = ($rev2, $sym2);  
             ($rev2, $sym2) = ($tmp1, $tmp2);  
         }  
         my $human_readable = 0;  
         if ($f eq 'c') {  
             @difftype = qw{-c};  
             $diffname = "Context diff";  
         }  
         elsif ($f eq 's') {  
             @difftype = qw{--side-by-side --width=164};  
             $diffname = "Side by Side";  
         }  
         elsif ($f eq 'H') {  
             $human_readable = 1;  
             @difftype = qw{--unified=15};  
             $diffname = "Long Human readable";  
         }  
         elsif ($f eq 'h') {  
             @difftype =qw{-u};  
             $human_readable = 1;  
             $diffname = "Human readable";  
         }  
         elsif ($f eq 'u') {  
             @difftype = qw{-u};  
             $diffname = "Unidiff";  
         }  
         else {  
             fatal ("400 Bad arguments", "Diff format $f not understood");  
         }  
   
         # apply special options    #
         if ($showfunc) {    # Now that we know all of the revision numbers, we can associate
             push @difftype, '-p';    # absolute revision numbers with all of the symbolic names, and
     # pass them to the form so that the same association doesn't have
     # to be built then.
     #
     undef @branchnames;
     undef %branchpoint;
     undef $sel;
   
             my($re1, $re2);    foreach (reverse sort keys %symrev) {
       $rev = $symrev{$_};
       if ($rev =~ /^((.*)\.)?\b0\.(\d+)$/) {
         push (@branchnames, $_);
   
             while (($re1, $re2) = each %funcline_regexp) {        #
                 if ($fullname =~ /$re1/) {        # A revision number of A.B.0.D really translates into
                     push @difftype, '-F', '$re2';        # "the highest current revision on branch A.B.D".
                     last;        #
                 }        # If there is no branch A.B.D, then it translates into
             }        # the head A.B .
         }        #
         if ($human_readable) {        # This reasoning also applies to the main branch A.B,
             if ($hr_ignwhite) {        # with the branch number 0.A, with the exception that
                 push @difftype, '-w';        # it has no head to translate to if there is nothing on
             }        # the branch, but I guess this can never happen?
             if ($hr_ignkeysubst) {        #
                 push @difftype, '-kk';        # (the code below gracefully forgets about the branch
             }        # if it should happen)
         }        #
         if (! open($fh, "-|")) { # child        $head = defined($2) ? $2 : "";
             open(STDERR, ">&STDOUT"); # Redirect stderr to stdout        $branch = $3;
             exec("rcsdiff",@difftype,"-r$rev1","-r$rev2",$fullname);        $branchrev = $head . ($head ne "" ? "." : "") . $branch;
         }        $rev = $head;
         if ($human_readable) {  
             http_header();        my $regex = '^' . quotemeta($branchrev) . '\b';
             &human_readable_diff($fh, $rev2);        $regex = qr/$regex/;
             exit;  
         }        foreach my $r (@revorder) {
         else {          if ($r =~ $regex) {
             http_header("text/plain");            $rev = $branchrev;
         }            last;
 #          }
 #===================================================================        }
 #RCS file: /home/ncvs/src/sys/netinet/tcp_output.c,v        next if ($rev eq "");
 #retrieving revision 1.16  
 #retrieving revision 1.17        if ($rev ne $head && $head ne "") {
 #diff -c -r1.16 -r1.17          $branchpoint{$head} .= ', ' if ($branchpoint{$head});
 #*** /home/ncvs/src/sys/netinet/tcp_output.c     1995/11/03 22:08:08     1.16          $branchpoint{$head} .= $_;
 #--- /home/ncvs/src/sys/netinet/tcp_output.c     1995/12/05 17:46:35     1.17        }
 #      }
 # Ideas:      $revsym{$rev} .= ", " if ($revsym{$rev});
 # - nuke the stderr output if it's what we expect it to be      $revsym{$rev} .= $_;
 # - Add "no differences found" if the diff command supplied no output.      $sel .= sprintf("<option value=\"%s:%s\">%s</option>\n",
 #                      htmlquote($rev), (htmlquote($_)) x 2);
 #*** src/sys/netinet/tcp_output.c     1995/11/03 22:08:08     1.16    }
 #--- src/sys/netinet/tcp_output.c     1995/12/05 17:46:35     1.17 RELENG_2_1_0  
 # (bogus example, but...)    my ($onlyonbranch, $onlybranchpoint);
 #    if ($onlyonbranch = $input{only_with_tag}) {
         if (grep { $_ eq '-u'} @difftype) {      $onlyonbranch = $symrev{$onlyonbranch};
             $f1 = '---';      if ($onlyonbranch && $onlyonbranch =~ s/\b0\.//) {
             $f2 = '\+\+\+';        ($onlybranchpoint = $onlyonbranch) =~ s/\.\d+$//;
         }      } else {
         else {        $onlybranchpoint = $onlyonbranch;
             $f1 = '\*\*\*';      }
             $f2 = '---';  
         }      if (!defined($onlyonbranch) || $onlybranchpoint eq "") {
         while (<$fh>) {        fatal("404 Tag not found", 'Tag "<code>%s</code>" is not defined.',
             if (m|^$f1 $cvsroot|o) {              $input{only_with_tag});
                 s|$cvsroot/||o;      }
                 if ($sym1) {    }
                     chop;  
                     $_ .= " " . $sym1 . "\n";    undef @revisions;
                 }  
             }    foreach (@allrevisions) {
             elsif (m|^$f2 $cvsroot|o) {      ($br  = $_)  =~ s/\.\d+$//;
                 s|$cvsroot/||o;      ($brp = $br) =~ s/\.\d+$//;
                 if ($sym2) {      next if ($onlyonbranch
                     chop;               && $br ne $onlyonbranch
                     $_ .= " " . $sym2 . "\n";               && $_  ne $onlybranchpoint);
                 }      unshift(@revisions, $_);
             }    }
             print $_;  
         }    if ($logsort eq "date") {
         close($fh);  
       # Sort the revisions in commit order an secondary sort on revision
       # (secondary sort needed for imported sources, or the first main
       # revision gets before the same revision on the 1.1.1 branch)
       @revdisplayorder =
         sort { $date{$b} <=> $date{$a} || -revcmp($a, $b) } @revisions;
     } elsif ($logsort eq "rev") {
   
       # Sort the revisions in revision order, highest first
       @revdisplayorder = reverse sort { revcmp($a, $b) } @revisions;
     } else {
   
       # No sorting. Present in the same order as rlog / cvs log
       @revdisplayorder = @revisions;
     }
   
     return $curbranch;
 }  }
   
 ###############################  
 # Show Logs ..  
 ###############################  
 sub getDirLogs {  
     my ($cvsroot,$dirname,@otherFiles) = @_;  
     my ($state,$otherFiles,$tag, $file, $date, $branchpoint, $branch, $log);  
     my ($rev, $revision, $revwanted, $filename, $head, $author);  
   
     $tag = $input{only_with_tag};  sub getDiffLinks($$$)
   {
     my ($url, $mimetype, $isbin) = @_;
   
     my ($DirName) = "$cvsroot/$where";    my @links = ();
     my (@files, @filetags);    if (!$isbin) { # Offer ordinary diff only for non-binary files.
     my $fh = do {local(*FH);};      push(@links, &link('preferred', $url));
       for my $difftype ($DIFFTYPES{$defaultDiffType}{colored} ? qw(u) : qw(h)) {
         my $f = $difftype eq $defaultDiffType ? '' : $difftype;
         push(@links,
              &link(htmlquote(lc($DIFFTYPES{$difftype}{descr})), "$url;f=$f"));
       }
     }
     if (my $extdiffs = $DIFF_COMMANDS{lc($mimetype)}) {
       for my $i (0 .. scalar(@$extdiffs)-1) {
         my $extdiff = $extdiffs->[$i];
         push(@links, &link(htmlquote($extdiff->{name}), "$url;f=ext$i"))
           if ($extdiff->{cmd} && $extdiff->{name});
       }
     }
     return @links;
   }
   
     push(@files, &safeglob("$DirName/*,v"));  
     push(@files, &safeglob("$DirName/Attic/*,v")) if (!$input{'hideattic'});  sub printLog($$$;$$)
     foreach $file (@otherFiles) {  {
         push(@files, "$DirName/$file");    # inlogview: 1 if in log view, otherwise in markup view.
     ($_, my $mimetype, my $isbin, my $inlogview, my $isSelected) = @_;
     (my $br  = $_)  =~ s/\.\d+$//;
     (my $brp = $br) =~ s/\.?\d+$//;
   
     print "<a name=\"rev$_\"></a>";
     if (defined($revsym{$_})) {
       foreach my $sym (split(", ", $revsym{$_})) {
         print '<a name="', htmlquote($sym), '"></a>';
     }      }
     }
     if ($revsym{$br} && !defined($nameprinted{$br})) {
       foreach my $sym (split(", ", $revsym{$br})) {
         print '<a name="', htmlquote($sym), '"></a>';
       }
       $nameprinted{$br} = 1;
     }
   
     # just execute rlog if there are any files    print "\n Revision <b>$_</b>";
     if ($#files < 0) {    if (/^1\.1\.1\.\d+$/) {
         return;      print " <i>(vendor branch)</i>";
     }
   
     (my $filename = $where) =~ s|^.*/||;
     my $fileurl   = uri_escape($filename);
     undef $filename;
   
     my $isDead = ($state{$_} eq 'dead');
     if (!$isDead) {
   
       print ': ', download_link($fileurl, $_, 'download', $mimetype);
   
       my @vlinks = ();
       push(@vlinks, display_link($fileurl, $_, 'text', 'text/plain'))
         unless $isbin;
       push(@vlinks, display_link($fileurl, $_, 'markup', 'text/x-cvsweb-markup'))
         if ($allow_markup && $inlogview && (!$isbin || viewable($mimetype)));
       if (!$isbin && $allow_annotate) {
         push(@vlinks,
              &link('annotated',
                    sprintf('%s?annotate=%s%s', $fileurl, $_, $barequery)));
     }      }
       print ' - view: ', join(', ', @vlinks) if @vlinks;
       undef @vlinks;
   
     if ($tag) {      if (!$isbin && $allow_version_select) {
         #can't use -r<tag> as - is allowed in tagnames, but misinterpreated by rlog..        print ' - ';
         if (! open($fh, "-|")) {        if ($isSelected) {
                 close(STDERR); # rlog may complain; ignore.          print '<b>[selected&nbsp;for&nbsp;diffs]</b>';
                 exec("rlog",@files);        } else {
         }          print &link('select&nbsp;for&nbsp;diffs',
                       sprintf('%s?r1=%s%s#rev%s',
                               $fileurl, $_, $barequery, $_));
         }
     }      }
     else {      print ' - ', graph_link('', 'revision graph')
         my $kidpid = open($fh, "-|");        if (!$inlogview && $allow_cvsgraph);
         if (! $kidpid) {    }
                 close(STDERR); # rlog may complain; ignore.    print "<br />\n";
                 exec("rlog","-r",@files);  
         }    print '<i>';
     if (@mytz) {
       my ($est) = $mytz[(localtime($date{$_}))[8]];
       print scalar localtime($date{$_}), " $est</i> (";
     } else {
       print scalar gmtime($date{$_}), " UTC</i> (";
     }
     print readableTime(time() - $date{$_}, 1), ' ago)';
     print ' by <i>', htmlquote($author{$_}), "</i><br />\n";
   
     printf("Branches: %s<br />\n", link_tags($revsym{$br})) if $revsym{$br};
     printf("CVS tags: %s<br />\n", link_tags($revsym{$_}))  if $revsym{$_};
     printf("Branch point for: %s<br />\n", link_tags($branchpoint{$_}))
       if $branchpoint{$_};
   
     # Find the previous revision
     my $prev;
     my @prevrev = split(/\./, $_);
     do {
       if (--$prevrev[$#prevrev] <= 0) {
   
         # If it was X.Y.Z.1, just make it X.Y
         pop (@prevrev);
         pop (@prevrev);
     }      }
     $state = "start";      $prev = join (".", @prevrev);
     while (<$fh>) {    } until (defined($date{$prev}) || $prev eq "");
         if ($state eq "start") {  
             #Next file. Initialize file variables    if ($isDead) {
             $rev = undef;      print "<b><i>FILE REMOVED</i></b><br />\n";
             $revwanted = undef;    } else {
             $branch = undef;      my %diffrev = ();
             $branchpoint = undef;      $diffrev{$_} = 1;
             $filename = undef;      $diffrev{""} = 1;
             $log = undef;      my $diff = 'Diff to:';
             $revision = undef;      my $printed = 0;
             $branch = undef;  
             %symrev = ();      #
             @filetags = ();      # Offer diff to previous revision
             #jump to head state      if ($prev) {
             $state = "head";        $diffrev{$prev} = 1;
         }        my $url =
         print "$state:$_" if ($verbose);          sprintf('%s.diff?r1=%s;r2=%s%s', $fileurl, $prev, $_, $barequery);
 again:        if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
         if ($state eq "head") {          print $diff, ' previous ', $prev, ': ', join(', ', @dlinks);
             #$rcsfile = $1 if (/^RCS file: (.+)$/); #not used (yet)          $diff = ';'; $printed = 1;
             $filename = $1 if (/^Working file: (.+)$/);        }
             $head = $1 if (/^head: (.+)$/);  
             $branch = $1 if (/^branch: (.+)$/);  
         }  
         if ($state eq "head" && /^symbolic names/) {  
             $state = "tags";  
             ($branch = $head) =~ s/\.\d+$// if (!defined($branch));  
             $branch =~ s/(\.?)(\d+)$/${1}0.$2/;  
             $symrev{MAIN} = $branch;  
             $symrev{HEAD} = $branch;  
             $alltags{MAIN} = 1;  
             $alltags{HEAD} = 1;  
             push (@filetags, "MAIN", "HEAD");  
             next;  
         }  
         if ($state eq "tags" &&  
                             /^\s+(.+):\s+([\d\.]+)\s+$/) {  
             push (@filetags, $1);  
             $symrev{$1} = $2;  
             $alltags{$1} = 1;  
             next;  
         }  
         if ($state eq "tags" && /^\S/) {  
             if (defined($tag) && (defined($symrev{$tag}) || $tag eq "HEAD")) {  
                 $revwanted = $tag eq "HEAD" ? $symrev{"MAIN"} : $symrev{$tag};  
                 ($branch = $revwanted) =~ s/\b0\.//;  
                 ($branchpoint = $branch) =~ s/\.?\d+$//;  
                 $revwanted = undef if ($revwanted ne $branch);  
             }  
             elsif (defined($tag) && $tag ne "HEAD") {  
                 print "Tag not found, skip this file" if ($verbose);  
                 $state = "skip";  
                 next;  
             }  
             foreach my $tagfound (@filetags) {  
                 $tags{$tagfound} = 1;  
             }  
             $state = "head";  
             goto again;  
         }  
         if ($state eq "head" && /^----------------------------$/) {  
             $state = "log";  
             $rev = undef;  
             $date = undef;  
             $log = "";  
             # Try to reconstruct the relative filename if RCS spits out a full path  
             $filename =~ s%^\Q$DirName\E/%%;  
             next;  
         }  
         if ($state eq "log") {  
             if (/^----------------------------$/  
                 || /^=============================/) {  
                 # End of a log entry.  
                 my $revbranch;  
                 ($revbranch = $rev) =~ s/\.\d+$//;  
                 print "$filename $rev Wanted: $revwanted "  
                     . "Revbranch: $revbranch Branch: $branch "  
                     . "Branchpoint: $branchpoint\n" if ($verbose);  
                 if (!defined($revwanted) && defined($branch)  
                     && $branch eq $revbranch || !defined($tag)) {  
                     print "File revision $rev found for branch $branch\n"  
                         if ($verbose);  
                     $revwanted = $rev;  
                 }  
                 if (defined($revwanted) ? $rev eq $revwanted :  
                     defined($branchpoint) ? $rev eq $branchpoint :  
                     0 && ($rev eq $head)) { # Don't think head is needed here..  
                     print "File info $rev found for $filename\n" if ($verbose);  
                     my @finfo = ($rev,$date,$log,$author,$filename);  
                     my ($name);  
                     ($name = $filename) =~ s%/.*%%;  
                     $fileinfo{$name} = [ @finfo ];  
                     $state = "done" if ($rev eq $revwanted);  
                 }  
                 $rev = undef;  
                 $date = undef;  
                 $log = "";  
             }  
             elsif (!defined($date) && m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);|) {  
                 my $yr = $1;  
                 # damn 2-digit year routines :-)  
                 if ($yr > 100) {  
                     $yr -= 1900;  
                 }  
                 $date = &Time::Local::timegm($6,$5,$4,$3,$2 - 1,$yr);  
                 ($author) = /author: ([^;]+)/;  
                 $state = "log";  
                 $log = '';  
                 next;  
             }  
             elsif (!defined($rev) && m/^revision (.*)$/) {  
                 $rev = $1;  
                 next;  
             }  
             else {  
                 $log = $log . $_;  
             }  
         }  
         if (/^===============/) {  
             $state = "start";  
             next;  
         }  
     }      }
     if ($. == 0) {  
         fatal("500 Internal Error",      #
               "Failed to spawn GNU rlog on <em>'".join(", ", @files)."'</em><p>did you set the <b>\$ENV{PATH}</b> in your configuration file correctly ?");      # Plus, if it's on a branch, and it's not a vendor branch,
       # offer a diff with the branch point.
       if ($revsym{$brp}
         && !/^1\.1\.1\.\d+$/
         && !defined($diffrev{$brp}))
       {
         my $url =
           sprintf('%s.diff?r1=%s;r2=%s%s', $fileurl, $brp, $_, $barequery);
         if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
           print $diff, ' branchpoint ', $brp, ': ', join(', ', @dlinks);
           $diff = ';'; $printed = 1;
         }
     }      }
     close($fh);  
 }  
   
 sub readLog {      #
         my($fullname,$revision) = @_;      # Plus, if it's on a branch, and it's not a vendor branch,
         my ($symnames, $head, $rev, $br, $brp, $branch, $branchrev);      # offer to diff with the next revision of the higher branch.
         my $fh = do {local(*FH);};      # (e.g. change gets committed and then brought
       # over to -stable)
       if (/^\d+\.\d+\.\d+/ && !/^1\.1\.1\.\d+$/) {
         my ($i, $nextmain);
   
         if (defined($revision)) {        for ($i = 0; $i < $#revorder && $revorder[$i] ne $_; $i++) {
             $revision = "-r$revision";        }
         }        my @tmp2 = split(/\./, $_);
         else {        for ($nextmain = ""; $i > 0; $i--) {
             $revision = "";          my $next = $revorder[$i - 1];
         }          my @tmp1 = split(/\./, $next);
   
         undef %symrev;          if (@tmp1 < @tmp2) {
         undef %revsym;            $nextmain = $next;
         undef @allrevisions;            last;
         undef %date;          }
         undef %author;  
         undef %state;  
         undef %difflines;  
         undef %log;  
   
         print("Going to rlog '$fullname'\n") if ($verbose);          # Only the highest version on a branch should have
         if (! open($fh, "-|")) { # child          # a diff for the "next MAIN".
                 if ($revision ne '') {          last
                         exec("rlog",$revision,$fullname);            if (@tmp1 - 1 <= @tmp2
                 }            && join (".", @tmp1[0 .. $#tmp1 - 1]) eq
                 else {            join (".", @tmp2[0 .. $#tmp1 - 1]));
                         exec("rlog",$fullname);        }
                 }  
         }  
         while (<$fh>) {  
             print if ($verbose);  
             if ($symnames) {  
                 if (/^\s+([^:]+):\s+([\d\.]+)/) {  
                     $symrev{$1} = $2;  
                 }  
                 else {  
                     $symnames = 0;  
                 }  
             }  
             elsif (/^head:\s+([\d\.]+)/) {  
                 $head = $1;  
             }  
             elsif (/^branch:\s+([\d\.]+)/) {  
                 $curbranch = $1;  
             }  
             elsif (/^symbolic names/) {  
                 $symnames = 1;  
             }  
             elsif (/^-----/) {  
                 last;  
             }  
         }  
         ($curbranch = $head) =~ s/\.\d+$// if (!defined($curbranch));  
   
 # each log entry is of the form:        if (!defined($diffrev{$nextmain})) {
 # ----------------------------          $diffrev{$nextmain} = 1;
 # revision 3.7.1.1          my $url = sprintf('%s.diff?r1=%s;r2=%s%s',
 # date: 1995/11/29 22:15:52;  author: fenner;  state: Exp;  lines: +5 -3            $fileurl, $nextmain, $_, $barequery);
 # log info          if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
 # ----------------------------            print $diff, ' next MAIN ', $nextmain, ': ', join(', ', @dlinks);
         logentry:            $diff = ';'; $printed = 1;
         while (!/^=========/) {          }
             $_ = <$fh>;        }
             last logentry if (!defined($_));    # EOF      }
             print "R:", $_ if ($verbose);  
             if (/^revision ([\d\.]+)/) {  
                 $rev = $1;  
                 unshift(@allrevisions,$rev);  
             }  
             elsif (/^========/ || /^----------------------------$/) {  
                 next logentry;  
             }  
             else {  
                 # The rlog output is syntactically ambiguous.  We must  
                 # have guessed wrong about where the end of the last log  
                 # message was.  
                 # Since this is likely to happen when people put rlog output  
                 # in their commit messages, don't even bother keeping  
                 # these lines since we don't know what revision they go with  
                 # any more.  
                 next logentry;  
 #               &fatal("500 Internal Error","Error parsing RCS output: $_");  
             }  
             $_ = <$fh>;  
             print "D:", $_ if ($verbose);  
             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+-]+))?|) {  
                 my $yr = $1;  
                 # damn 2-digit year routines :-)  
                 if ($yr > 100) {  
                     $yr -= 1900;  
                 }  
                 $date{$rev} = &Time::Local::timegm($6,$5,$4,$3,$2 - 1,$yr);  
                 $author{$rev} = $7;  
                 $state{$rev} = $8;  
                 $difflines{$rev} = $10;  
             }  
             else {  
                 &fatal("500 Internal Error", "Error parsing RCS output: $_");  
             }  
             line:  
             while (<$fh>) {  
                 print "L:", $_ if ($verbose);  
                 next line if (/^branches:\s/);  
                 last line if (/^----------------------------$/ || /^=========/);  
                 $log{$rev} .= $_;  
             }  
             print "E:", $_ if ($verbose);  
         }  
         close($fh);  
         print "Done reading RCS file\n" if ($verbose);  
   
         @revorder = reverse sort {revcmp($a,$b)} @allrevisions;      # Plus if user has selected only r1, then present a link
         print "Done sorting revisions",join(" ",@revorder),"\n" if ($verbose);      # to make a diff to that revision
       if (defined($input{r1}) && !defined($diffrev{$input{r1}})) {
         $diffrev{$input{r1}} = 1;
         my $url = sprintf('%s.diff?r1=%s;r2=%s%s',
           $fileurl, $input{r1}, $_, $barequery);
         if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
           print $diff, ' selected ', $input{r1}, ': ', join(', ', @dlinks);
           $diff = ';'; $printed = 1;
         }
       }
   
       print "<br />\n" if $printed;
     }
   
     if ($prev ne "" && $difflines{$_}) {
       printf "Changes since revision %s: %s lines<br />\n",
         htmlquote($prev), htmlquote($difflines{$_});
     }
   
     print "<pre class=\"log\">\n";
     print &htmlify($log{$_}, $allow_log_extra);
     print "</pre>\n";
   }
   
   
 #  #
 # HEAD is an artificial tag which is simply the highest tag number on the main  # Generates the HTML view for CvsGraph.
 # branch, unless there is a branch tag in the RCS file in which case it's the  
 # highest revision on that branch.  Find it by looking through @revorder; it  
 # is the first commit listed on the appropriate branch.  
 # This is not neccesary the same revision as marked as head in the RCS file.  
         my $headrev = $curbranch || "1";  
         ($symrev{"MAIN"} = $headrev) =~ s/(\.?)(\d+)$/${1}0.$2/;  
         revision:  
         foreach $rev (@revorder) {  
             if ($rev =~ /^(\S*)\.\d+$/ && $headrev eq $1) {  
                 $symrev{"HEAD"} = $rev;  
                 last revision;  
             }  
         }  
         ($symrev{"HEAD"} = $headrev) =~ s/\.\d+$//  
             if (!defined($symrev{"HEAD"}));  
         print "Done finding HEAD\n" if ($verbose);  
 #  #
 # Now that we know all of the revision numbers, we can associate  sub doGraphView()
 # absolute revision numbers with all of the symbolic names, and  {
 # pass them to the form so that the same association doesn't have    (my $pathname = $where) =~ s|[^/]*$||;
 # to be built then.    (my $filename = $where) =~ s|^.*/||;
 #  
         undef @branchnames;  
         undef %branchpoint;  
         undef $sel;  
   
         foreach (reverse sort keys %symrev) {    navigateHeader($scriptwhere, $pathname, $filename, undef, 'graph');
             $rev = $symrev{$_};  
             if ($rev =~ /^((.*)\.)?\b0\.(\d+)$/) {  
                 push(@branchnames, $_);  
                 #  
                 # A revision number of A.B.0.D really translates into  
                 # "the highest current revision on branch A.B.D".  
                 #  
                 # If there is no branch A.B.D, then it translates into  
                 # the head A.B .  
                 #  
                 # This reasoning also applies to the main branch A.B,  
                 # with the branch number 0.A, with the exception that  
                 # it has no head to translate to if there is nothing on  
                 # the branch, but I guess this can never happen?  
                 # (the code below gracefully forgets about the branch  
                 # if it should happen)  
                 #  
                 $head = defined($2) ? $2 : "";  
                 $branch = $3;  
                 $branchrev = $head . ($head ne "" ? "." : "") . $branch;  
                 my $regex;  
                 ($regex = $branchrev) =~ s/\./\\./g;  
                 $rev = $head;  
   
                 revision:    my $title = 'Revision graph of ' . htmlquote($pathname . $filename);
                 foreach my $r (@revorder) {    my $mapname = 'CvsGraphMap';
                     if ($r =~ /^${regex}\b/) {  
                         $rev = $branchrev;  
                         last revision;  
                     }  
                 }  
                 next if ($rev eq "");  
                 if ($rev ne $head && $head ne "") {  
                     $branchpoint{$head} .= ", " if ($branchpoint{$head});  
                     $branchpoint{$head} .= $_;  
                 }  
             }  
             $revsym{$rev} .= ", " if ($revsym{$rev});  
             $revsym{$rev} .= $_;  
             $sel .= "<OPTION VALUE=\"${rev}:${_}\">$_\n";  
         }  
         print "Done associating revisions with branches\n" if ($verbose);  
   
         my ($onlyonbranch, $onlybranchpoint);    printf(<<EOF, $title, $mapname, $cvstree, $title);
         if ($onlyonbranch = $input{'only_with_tag'}) {  <h3 style="text-align: center">%s</h3>
             $onlyonbranch = $symrev{$onlyonbranch};  <div style="text-align: center"><img border="0" usemap="#%s" src="?cvsroot=%s;graph=1;makeimage=1" alt="%s" />
             if ($onlyonbranch =~ s/\b0\.//) {  EOF
                 ($onlybranchpoint = $onlyonbranch) =~ s/\.\d+$//;  
             }  
             else {  
                 $onlybranchpoint = $onlyonbranch;  
             }  
             if (!defined($onlyonbranch) || $onlybranchpoint eq "") {  
                 fatal("404 Tag not found","Tag $input{'only_with_tag'} not defined");  
             }  
         }  
   
         undef @revisions;    # Remove any pre-existing tag/branch names from branch links.
     (my $notag_query = $barequery) =~ s/;+only_with_tag=.*?(?=;|$)//g;
   
         foreach (@allrevisions) {    my @graph_cmd =
             ($br = $_) =~ s/\.\d+$//;      ($CMD{cvsgraph},
             ($brp = $br) =~ s/\.\d+$//;       '-r', $cvsroot,
             next if ($onlyonbranch && $br ne $onlyonbranch &&       '-m', $pathname,
                                         $_ ne $onlybranchpoint);       '-i',
             unshift(@revisions,$_);       '-M', $mapname,
         }       '-x', 'x',
        "-Omap_branch_href=\"href=\\\"./?only_with_tag=%(%t%)$notag_query\\\"\"",
        "-Omap_rev_href=\"href=\\\"?rev=%(%R%)$barequery\\\"\"",
        "-Omap_diff_href=\"href=\\\"%(%F%).diff" .
        "?r1=%(%P%);r2=%(%R%)$barequery\\\"\"",
        );
     push(@graph_cmd, '-c', $cvsgraph_config) if $cvsgraph_config;
     push(@graph_cmd, $filename . ',v');
   
         if ($logsort eq "date") {    local *CVSGRAPH_OUT;
             # Sort the revisions in commit order an secondary sort on revision    my ($h, $err) =
             # (secondary sort needed for imported sources, or the first main      startproc(\@graph_cmd, \"", '>pipe', \*CVSGRAPH_OUT);
             # revision gets before the same revision on the 1.1.1 branch)    fatal('500 Internal Error', $err) unless $h;
             @revdisplayorder = sort {$date{$b} <=> $date{$a} || -revcmp($a, $b)} @revisions;  
         }  
         elsif ($logsort eq "rev") {  
             # Sort the revisions in revision order, highest first  
             @revdisplayorder = reverse sort {revcmp($a,$b)} @revisions;  
         }  
         else {  
             # No sorting. Present in the same order as rlog / cvs log  
             @revdisplayorder = @revisions;  
         }  
   
     # Browser compatibility kludge: many browsers do not support client side
     # image maps where the <map> element contains only the id attribute.  Let's
     # add the corresponding name attribute to it on the fly.
     while (<CVSGRAPH_OUT>) {
       s/(<map\s+id="([^"]+)")\s*>/$1 name="$2">/;
       print;
     }
   
     $h->finish();
     print "</div>\n";
   
     html_footer();
 }  }
   
 sub printLog($;$) {  
         my ($link, $br, $brp);  
         ($_,$link) = @_;  
         ($br = $_) =~ s/\.\d+$//;  
         ($brp = $br) =~ s/\.?\d+$//;  
         my ($isDead, $prev);  
   
         $link = 1 if (!defined($link));  #
         $isDead = ($state{$_} eq "dead");  # Generates a graph using CvsGraph.
   #
   sub doGraph()
   {
     (my $pathname = $where) =~ s|[^/]*$||;
     (my $filename = $where) =~ s|^.*/||;
   
         if ($link && !$isDead) {    http_header('image/png');
             my ($filename);  
             ($filename = $where) =~ s/^.*\///;  
             my ($fileurl) = urlencode($filename);  
             print "<a NAME=\"rev$_\"></a>";  
             if (defined($revsym{$_})) {  
                 foreach my $sym (split(", ", $revsym{$_})) {  
                     print "<a NAME=\"$sym\"></a>";  
                 }  
             }  
             if (defined($revsym{$br}) && $revsym{$br} && !defined($nameprinted{$br})) {  
                 foreach my $sym (split(", ", $revsym{$br})) {  
                     print "<a NAME=\"$sym\"></a>";  
                 }  
                 $nameprinted{$br} = 1;  
             }  
             print "\n Revision ";  
             &download_link($fileurl, $_, $_,  
                 $defaultViewable ? "text/x-cvsweb-markup" : undef);  
             if ($defaultViewable) {  
                 print " / ";  
                 &download_link($fileurl, $_, "(download)", $mimetype);  
             }  
             if (not $defaultTextPlain) {  
                 print " / ";  
                 &download_link($fileurl, $_, "(as text)",  
                            "text/plain");  
             }  
             if (!$defaultViewable) {  
                 print " / ";  
                 &download_link($fileurl, $_, "(view)", "text/x-cvsweb-markup");  
             }  
             if ($allow_annotate) {  
                 print " - <a href=\"" . $scriptname . "/" . urlencode($where) . "?annotate=$_$barequery\">";  
                 print "annotate</a>";  
             }  
             # Plus a select link if enabled, and this version isn't selected  
             if ($allow_version_select) {  
                 if ((!defined($input{"r1"}) || $input{"r1"} ne $_)) {  
                     print " - <A HREF=\"${scriptwhere}?r1=$_$barequery" .  
                         "\">[select for diffs]</A>\n";  
                 }  
                 else {  
                     print " - <b>[selected]</b>";  
                 }  
             }  
         }  
         else {  
             print "Revision <B>$_</B>";  
         }  
         if (/^1\.1\.1\.\d+$/) {  
             print " <i>(vendor branch)</i>";  
         }  
         if (defined @mytz) {  
             my ($est) = $mytz[(localtime($date{$_}))[8]];  
             print ", <i>" . scalar localtime($date{$_}) . " $est</i> (";  
         } else {  
             print ", <i>" . scalar gmtime($date{$_}) . " UTC</i> (";  
         }  
         print readableTime(time() - $date{$_},1) . " ago)";  
         print " by ";  
         print "<i>" . $author{$_} . "</i>\n";  
         print "<BR>Branch: <b>",$link?link_tags($revsym{$br}):$revsym{$br},"</b>\n"  
             if ($revsym{$br});  
         print "<BR>CVS Tags: <b>",$link?link_tags($revsym{$_}):$revsym{$_},"</b>"  
             if ($revsym{$_});  
         print "<BR>Branch point for: <b>",$link?link_tags($branchpoint{$_}):$branchpoint{$_},"</b>\n"  
             if ($branchpoint{$_});  
         # Find the previous revision  
         my @prevrev = split(/\./, $_);  
         do {  
             if (--$prevrev[$#prevrev] <= 0) {  
                 # If it was X.Y.Z.1, just make it X.Y  
                 pop(@prevrev);  
                 pop(@prevrev);  
             }  
             $prev = join(".", @prevrev);  
         } until (defined($date{$prev}) || $prev eq "");  
         if ($prev ne "") {  
             if ($difflines{$_}) {  
                 print "<BR>Changes since <b>$prev: $difflines{$_} lines</b>";  
             }  
         }  
         if ($isDead) {  
             print "<BR><B><I>FILE REMOVED</I></B>\n";  
         }  
         elsif ($link) {  
             my %diffrev = ();  
             $diffrev{$_} = 1;  
             $diffrev{""} = 1;  
             print "<BR>Diff";  
             #  
             # Offer diff to previous revision  
             if ($prev) {  
                 $diffrev{$prev} = 1;  
                 print " to previous <A HREF=\"${scriptwhere}.diff?r1=$prev";  
                 print "&amp;r2=$_" . $barequery . "\">$prev</A>\n";  
                 if (!$hr_default) { # offer a human readable version if not default  
                     print "(<A HREF=\"${scriptwhere}.diff?r1=$prev";  
                     print "&amp;r2=$_" . $barequery . "&amp;f=h\">colored</A>)\n";  
                 }  
             }  
             #  
             # Plus, if it's on a branch, and it's not a vendor branch,  
             # offer a diff with the branch point.  
             if ($revsym{$brp} && !/^1\.1\.1\.\d+$/ && !defined($diffrev{$brp})) {  
                 print " to branchpoint <A HREF=\"${scriptwhere}.diff?r1=$brp";  
                 print "&amp;r2=$_" . $barequery . "\">$brp</A>\n";  
                 if (!$hr_default) { # offer a human readable version if not default  
                 print "(<A HREF=\"${scriptwhere}.diff?r1=$brp";  
                 print "&amp;r2=$_" . $barequery . "&amp;f=h\">colored</A>)\n";  
                 }  
             }  
             #  
             # Plus, if it's on a branch, and it's not a vendor branch,  
             # offer to diff with the next revision of the higher branch.  
             # (e.g. change gets committed and then brought  
             # over to -stable)  
             if (/^\d+\.\d+\.\d+/ && !/^1\.1\.1\.\d+$/) {  
                 my ($i,$nextmain);  
                 for ($i = 0; $i < $#revorder && $revorder[$i] ne $_; $i++){}  
                 my (@tmp2) = split(/\./, $_);  
                 for ($nextmain = ""; $i > 0; $i--) {  
                     my ($next) = $revorder[$i-1];  
                     my (@tmp1) = split(/\./, $next);  
                     if ($#tmp1 < $#tmp2) {  
                         $nextmain = $next;  
                         last;  
                     }  
                     # Only the highest version on a branch should have  
                     # a diff for the "next main".  
                     last if (join(".",@tmp1[0..$#tmp1-1])  
                              eq join(".",@tmp2[0..$#tmp1-1]));  
                 }  
                 if (!defined($diffrev{$nextmain})) {  
                     $diffrev{$nextmain} = 1;  
                     print " next main <A HREF=\"${scriptwhere}.diff?r1=$nextmain";  
                     print "&amp;r2=$_" . $barequery .  
                         "\">$nextmain</A>\n";  
                     if (!$hr_default) { # offer a human readable version if not default  
                         print "(<A HREF=\"${scriptwhere}.diff?r1=$nextmain";  
                         print "&amp;r2=$_" . $barequery .  
                             "&amp;f=h\">colored</A>)\n";  
                     }  
                 }  
             }  
             # Plus if user has selected only r1, then present a link  
             # to make a diff to that revision  
             if (defined($input{"r1"}) && !defined($diffrev{$input{"r1"}})) {  
                 $diffrev{$input{"r1"}} = 1;  
                 print " to selected <A HREF=\"${scriptwhere}.diff?"  
                         . "r1=$input{'r1'}&amp;r2=$_" . $barequery  
                         . "\">$input{'r1'}</A>\n";  
                 if (!$hr_default) { # offer a human readable version if not default  
                     print "(<A HREF=\"${scriptwhere}.diff?r1=$input{'r1'}";  
                     print "&amp;r2=$_" . $barequery .  
                         "&amp;f=h\">colored</A>)\n";  
   
                 }    my @graph_cmd = ($CMD{cvsgraph}, '-r', $cvsroot, '-m', $pathname);
             }    push(@graph_cmd, '-c', $cvsgraph_config) if $cvsgraph_config;
         }    push(@graph_cmd, $filename . ',v');
         print "<PRE>\n";  
         print &htmlify($log{$_}, 1);    local *CVSGRAPH_OUT;
         print "</PRE>\n";    my ($h, $err) =
       startproc(\@graph_cmd, \"", '>pipe', \*CVSGRAPH_OUT);
     fatal('500 Internal Error', $err) unless $h;
     {
       local $/ = undef;
       binmode(\*STDOUT);
       print <CVSGRAPH_OUT>;
     }
     $h->finish();
 }  }
   
 sub doLog {  
         my($fullname) = @_;  
         my ($diffrev, $upwhere, $filename, $backurl);  
   
         readLog($fullname);  
   
         html_header("CVS log for $where");  sub doLog($)
         ($upwhere = $where) =~ s|(Attic/)?[^/]+$||;  {
         ($filename = $where) =~ s|^.*/||;    my ($fullname) = @_;
         $backurl = $scriptname . "/" . urlencode($upwhere) . $query;  
         print &link($backicon, "$backurl#$filename"),    my $curbranch = readLog($fullname);
               " <b>Up to ", &clickablePath($upwhere, 1), "</b><p>\n";  
         print <<EOF;    html_header("CVS log for $where");
 <A HREF="#diff">Request diff between arbitrary revisions</A>  
 <HR NOSHADE>    my $upwhere = $where;
     (my $filename = $where) =~ s|^.*/||;
     my $backurl = "./$query#" . uri_escape($filename);
     if ($where =~ m|^(.*?)((?<=/)Attic/)?[^/]+$|) {
       $upwhere = $1;
       $backurl = ".$backurl" if $2; # skip over Attic
     }
   
     my $isbin = $keywordsubstitution =~ /b/;
     my $mimetype = getMimeType($filename, $isbin);
   
     print "<p>\n ";
     print &link($backicon, $backurl), " <b>Up to ",
       &clickablePath($upwhere, 1), "</b>\n</p>\n";
     print "<p>\n ";
     print &link('Request diff between arbitrary revisions', '#diff');
     print ' - ', &graph_link('', 'Display revisions graphically')
       if $allow_cvsgraph;
     if ($cvshistory_url) {
       (my $d = $upwhere) =~ s|/+$||;
       print ' - ', history_link($d, $filename);
     }
     print "\n</p>\n<hr />\n";
   
     print "<p>\n";
   
     my $explain = $isbin ? ' (i.e.: CVS considers this a binary file)' : '';
     print "Keyword substitution: $keywordsubstitution$explain<br />\n";
     if ($curbranch) {
       print "Default branch: ", ($revsym{$curbranch} || $curbranch);
     } else {
       print "No default branch";
     }
     print "<br />\n";
   
     print 'Current tag: ', htmlquote($input{only_with_tag}), "<br />\n"
       if $input{only_with_tag};
     print "</p>\n";
   
     undef %nameprinted;
   
     for my $r (@revdisplayorder) {
       print "<hr />\n";
       my $sel = (defined($input{r1}) && $input{r1} eq $r);
       print "<div class=\"diff-selected\">\n" if $sel;
       printLog($r, $mimetype, $isbin, 1, $sel);
       print "</div>\n" if $sel;
     }
   
     printf(<<EOF, $scriptwhere);
   <hr />
   <form method="get" action="%s.diff" id="diff_select">
   <fieldset>
   <legend>Diff request</legend>
   <p>
    <a name="diff">
     This form allows you to request diffs between any two revisions of a file.
     You may select a symbolic revision name using the selection box or you may
     type in a numeric name using the type-in text box.
    </a>
   </p>
 EOF  EOF
         if ($curbranch) {  
             print "Default branch: ", ($revsym{$curbranch} || $curbranch);  
         }  
         else {  
             print "No default branch";  
         }  
         print "<BR>\n";  
         if ($input{only_with_tag}) {  
             print "Current tag: $input{only_with_tag}<BR>\n";  
         }  
   
         undef %nameprinted;    foreach (@stickyvars) {
       printf("<input type=\"hidden\" name=\"%s\" value=\"%s\" />\n",
              $_, htmlquote($input{$_}))
         if (defined($input{$_}) &&
             (!defined($DEFAULTVALUE{$_}) || $input{$_} ne $DEFAULTVALUE{$_}));
     }
   
         for (my $i = 0; $i <= $#revdisplayorder; $i++) {    print <<EOF;
             print "<HR size=1 NOSHADE>";  <table summary="Diff between arbitrary revisions">
             printLog($revdisplayorder[$i]);  <tr>
         }  <td class="opt-label">
   <label for="r1" accesskey="1">Diffs between</label>
   </td>
   <td class="opt-value">
   <select id="r1" name="r1">
   <option value="text" selected="selected">Use Text Field</option>
   EOF
     print $sel, "</select>\n";
   
         print "<HR NOSHADE>";    my $diffrev = defined($input{r1}) ?
         print "<A NAME=diff>\n";      $input{r1} : $revdisplayorder[$#revdisplayorder];
         print "This form allows you to request diff's between any two\n";  
         print "revisions of a file.  You may select a symbolic revision\n";    printf(<<EOF, $inputTextSize, $diffrev);
         print "name using the selection box or you may type in a numeric\n";  <input type="text" size="%s" name="tr1" value="%s" onchange="this.form.r1.selectedIndex=0" />
         print "name using the type-in text box.\n";  </td>
         print "</A><P>\n";  <td></td>
         print "<FORM METHOD=\"GET\" ACTION=\"${scriptwhere}.diff\" NAME=\"diff_select\">\n";  </tr>
         foreach (@stickyvars) {  <tr>
             print "<INPUT TYPE=HIDDEN NAME=\"$_\" VALUE=\"$input{$_}\">\n"  <td class="opt-label">
                 if (defined($input{$_})  <label for="r2" accesskey="2">and</label>
                     && ($input{$_} ne $DEFAULTVALUE{$_} && $input{$_} ne ""));  </td>
         }  <td class="opt-value">
         print "Diffs between \n";  <select id="r2" name="r2">
         print "<SELECT NAME=\"r1\">\n";  <option value="text" selected="selected">Use Text Field</option>
         print "<OPTION VALUE=\"text\" SELECTED>Use Text Field\n";  EOF
         print $sel;    print $sel, "</select>\n";
         print "</SELECT>\n";  
         $diffrev = $revdisplayorder[$#revdisplayorder];    $diffrev = defined($input{r2}) ? $input{r2} : $revdisplayorder[0];
         $diffrev = $input{"r1"} if (defined($input{"r1"}));  
         print "<INPUT TYPE=\"TEXT\" SIZE=\"$inputTextSize\" NAME=\"tr1\" VALUE=\"$diffrev\" onChange='document.diff_select.r1.selectedIndex=0'>\n";    printf(<<EOF, $inputTextSize, $diffrev, $scriptwhere);
         print " and \n";  <input type="text" size="%s" name="tr2" value="%s" onchange="this.form.r2.selectedIndex=0" />
         print "<SELECT NAME=\"r2\">\n";  </td>
         print "<OPTION VALUE=\"text\" SELECTED>Use Text Field\n";  <td><input type="submit" value="Get Diffs" accesskey="G" /></td>
         print $sel;  </tr>
         print "</SELECT>\n";  </table>
         $diffrev = $revdisplayorder[0];  </fieldset>
         $diffrev = $input{"r2"} if (defined($input{"r2"}));  </form>
         print "<INPUT TYPE=\"TEXT\" SIZE=\"$inputTextSize\" NAME=\"tr2\" VALUE=\"$diffrev\" onChange='docuement.diff_select.r2.selectedIndex=0'>\n";  <form method="get" action="%s">
         print "<BR>Type of Diff should be a&nbsp;";  <fieldset>
         printDiffSelect();  <legend>Log view options</legend>
         print "<INPUT TYPE=SUBMIT VALUE=\"  Get Diffs  \">\n";  <table summary="Log view options">
         print "</FORM>\n";  <tr>
         print "<HR noshade>\n";  <td class="opt-label">
         if (@branchnames) {  <label for="f" accesskey="D">Preferred diff type:</label>
             print "<A name=branch></A>\n";  </td>
             print "<FORM METHOD=\"GET\" ACTION=\"$scriptwhere\">\n";  <td class="opt-value">
             foreach (@stickyvars) {  EOF
                 next if ($_ eq "only_with_tag");    printDiffSelect($use_java_script);
                 next if ($_ eq "logsort");    print <<EOF;
                 print "<INPUT TYPE=HIDDEN NAME=\"$_\" VALUE=\"$input{$_}\">\n"  </td>
                     if (defined($input{$_}) && $input{$_} ne $DEFAULTVALUE{$_}  <td></td>
                         && $input{$_} ne "");  </tr>
             }  EOF
             print "View only Branch: \n";  
             print "<SELECT NAME=\"only_with_tag\"";    if (@branchnames) {
             print " onchange=\"submit()\"" if ($use_java_script);  
             print ">\n";      printf(<<EOF, $use_java_script ? ' onchange="this.form.submit()"' : '');
             print "<OPTION VALUE=\"\"";  <tr>
             print " SELECTED" if (defined($input{"only_with_tag"}) &&  <td class="opt-label">
                 $input{"only_with_tag"} eq "");  <label for="only_with_tag" accesskey="B">View only branch:</label>
             print ">Show all branches\n";  </td>
             foreach (reverse sort @branchnames) {  <td class="opt-value">
                 print "<OPTION";  <a name="branch">
                 print " SELECTED" if (defined($input{"only_with_tag"})  <select id="only_with_tag" name="only_with_tag"%s>
                         && $input{"only_with_tag"} eq $_);  EOF
                 print ">${_}\n";  
             }      my @tmp = ();
             print "</SELECT>\n";      my $selfound = 0;
             print "<INPUT TYPE=SUBMIT VALUE=\"  View Branch  \">\n";      foreach (reverse sort @branchnames) {
             print "</FORM>\n";        my $selected =
         }          (defined($input{only_with_tag}) && $input{only_with_tag} eq $_);
         print "<A name=logsort></A>\n";        $selfound ||= $selected;
         print "<FORM METHOD=\"GET\" ACTION=\"$scriptwhere\">\n";        push(@tmp, sprintf('<option%s>%s</option>',
         foreach (@stickyvars) {                           $selected ? ' selected="selected"' : '',
             next if ($_ eq "only_with_tag");                           htmlquote($_)));
             next if ($_ eq "logsort");      }
             print "<INPUT TYPE=HIDDEN NAME=\"$_\" VALUE=\"$input{$_}\">\n"      printf("<option value=\"\"%s>Show all branches</option>\n",
                 if (defined($input{$_}) && $input{$_} ne $DEFAULTVALUE{$_}             $selfound ? '' : ' selected="selected"');
                     && $input{$_} ne "");      print join("\n", @tmp);
         }  
         print "Sort log by: \n";      print <<EOF
         print "<SELECT NAME=\"logsort\"";  </select>
         print " onchange=\"submit()\"" if ($use_java_script);  </a>
         print ">\n";  </td>
         print "<OPTION VALUE=cvs",$logsort eq "cvs" ? " SELECTED" : "", ">Not sorted";  <td></td>
         print "<OPTION VALUE=date",$logsort eq "date" ? " SELECTED" : "", ">Commit date";  </tr>
         print "<OPTION VALUE=rev",$logsort eq "rev" ? " SELECTED" : "", ">Revision";  EOF
         print "</SELECT>\n";    }
         print "<INPUT TYPE=SUBMIT VALUE=\"  Sort  \">\n";  
         print "</FORM>\n";    print <<EOF;
         print &html_footer;  <tr>
         print "</BODY></HTML>\n";  <td class="opt-label">
   <label for="logsort" accesskey="L">Sort log by:</label>
   </td>
   <td>
   EOF
     printLogSortSelect($use_java_script);
     print <<EOF;
   </td>
   <td><input type="submit" value="Set" accesskey="S" /></td>
   </tr>
   </table>
   EOF
     foreach (@stickyvars) {
       next if ($_ eq "f");
       next if ($_ eq "only_with_tag");
       next if ($_ eq "logsort");
       printf("<input type=\"hidden\" name=\"%s\" value=\"%s\" />\n",
              $_, htmlquote($input{$_}))
         if (defined($input{$_})
             && (!defined($DEFAULTVALUE{$_}) || $input{$_} ne $DEFAULTVALUE{$_}));
     }
     print "</fieldset>\n</form>\n";
     html_footer();
 }  }
   
 sub flush_diff_rows ($$$$)  
   sub flush_diff_rows($$$$)
 {  {
     my $j;    my ($leftColRef, $rightColRef, $leftRow, $rightRow) = @_;
     my ($leftColRef,$rightColRef,$leftRow,$rightRow) = @_;  
     if ($state eq "PreChangeRemove") {          # we just got remove-lines before    return unless defined($state);
       for ($j = 0 ; $j < $leftRow; $j++) {  
           print  "<tr><td bgcolor=\"$diffcolorRemove\">@$leftColRef[$j]</td>";    if ($state eq "PreChangeRemove") {    # we just got remove-lines before
           print  "<td bgcolor=\"$diffcolorEmpty\">&nbsp;</td></tr>\n";      for (my $j = 0; $j < $leftRow; $j++) {
       }        printf(<<EOF, spacedHtmlText(@$leftColRef[$j]));
   <tr>
    <td class="diff diff-removed">&nbsp;%s</td>
    <td class="diff diff-empty">&nbsp;</td>
   </tr>
   EOF
     }      }
     elsif ($state eq "PreChange") {             # state eq "PreChange"    } elsif ($state eq "PreChange") {     # state eq "PreChange"
       # we got removes with subsequent adds                                          # we got removes with subsequent adds
       for ($j = 0; $j < $leftRow || $j < $rightRow ; $j++) {  # dump out both cols      if (HAS_EDIFF) {
           print  "<tr>";        # construct the suffix tree
           if ($j < $leftRow) {        my $left_diff = join("\n", @$leftColRef[0..$leftRow-1]);
               print  "<td bgcolor=\"$diffcolorChange\">@$leftColRef[$j]</td>";        my $right_diff = join("\n", @$rightColRef[0..$rightRow-1]);
           }        my $diff_str = String::Ediff::ediff($left_diff, $right_diff);
           else {  
               print  "<td bgcolor=\"$diffcolorDarkChange\">&nbsp;</td>";        my @diff_str = split(/ /, $diff_str);
           }        my $INFINITY = 10000000;
           if ($j < $rightRow) {        push(@diff_str, ($INFINITY) x 8);
               print  "<td bgcolor=\"$diffcolorChange\">@$rightColRef[$j]</td>";        my ($idx, $b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
           }          (0, @diff_str[0..7]);
           else {        my ($l_cul, $r_cul) = (0, 0);
               print  "<td bgcolor=\"$diffcolorDarkChange\">&nbsp;</td>";        my ($ldx, $rdx) = (0, 0);
           }        my (@left_html, @right_html);
           print  "</tr>\n";        for (my $j = 0; $j < $leftRow; $j++) {
           my $line_len = length(@$leftColRef[$j]);
           my $line = @$leftColRef[$j];
           $l_cul += length($line) + 1; # includes "\n"
           my $l_culx = $l_cul - 1; # not includes "\n"
           if ($j < $lb1) {
             $line = spacedHtmlText($line);
             push(@left_html, "<td class=\"diff diff-changed\">$line</td>");
           } elsif ($lb1 == $j) {
             my $html_line;
             while ($lb1 == $j) {
               my $begin_char = $l_culx - $b1;
   
               $line =~ /^(.*)(.{$begin_char})$/;
               $html_line .= spacedHtmlText($1) .
                 '</span><span class="diff diff-unchanged">';
               $line = $2;
               last if ($j != $le1);
   
               my $end_char = $l_culx - $e1;
               $line =~ /^(.*)(.{$end_char})$/;
               $html_line .= spacedHtmlText($1) .
                 '</span><span class="diff diff-changed">';
               $line = $2;
   
               $idx++;
               my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) =
                 ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2);
               ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
                 @diff_str[$idx*8..($idx+1)*8-1];
               $lb1 = $INFINITY if ($lb1 < 0);
               $lb2 = $INFINITY if ($lb2 < 0);
               $le1 = $INFINITY if ($le1 < 0);
               $le2 = $INFINITY if ($le2 < 0);
               if ($te1 > $b1) {
                 ($b1, $lb1) = ($te1, $tle1);
               }
               if ($te2 > $b2) {
                 ($b2, $lb2) = ($te2, $tle2);
               }
             }
             push(@left_html,
                  sprintf('<td><span class="diff diff-changed">%s%s</span></td>',
                          $html_line, spacedHtmlText($line)));
           } elsif ($le1 == $j) {
             my $html_line;
             while ($le1 == $j) {
               my $end_char = $l_culx - $e1;
               $line =~ /^(.*)(.{$end_char})$/;
               $html_line .= spacedHtmlText($1) .
                 '</span><span class="diff diff-changed">';
               $line = $2;
   
               $idx++;
               my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) =
                 ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2);
               ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
                 @diff_str[$idx*8..($idx+1)*8-1];
               $lb1 = $INFINITY if ($lb1 < 0);
               $lb2 = $INFINITY if ($lb2 < 0);
               $le1 = $INFINITY if ($le1 < 0);
               $le2 = $INFINITY if ($le2 < 0);
               if ($te1 > $b1) {
                 ($b1, $lb1) = ($te1, $tle1);
               }
               if ($te2 > $b2) {
                 ($b2, $lb2) = ($te2, $tle2);
               }
   
               last if ($lb1 != $j);
   
               my $begin_char = $l_culx - $b1;
   
               $line =~ /^(.*)(.{$begin_char})$/;
               $html_line .= spacedHtmlText($1) .
                 '</span><span class="diff diff-unchanged">';
               $line = $2;
             }
             push(@left_html,
                 sprintf('<td><span class="diff diff-unchanged">%s%s</span></td>',
                         $html_line, spacedHtmlText($line)));
           } else {
             $line = spacedHtmlText($line);
             push(@left_html, "<td class=\"diff diff-unchanged\">$line</td>");
           }
       }        }
         ($idx, $b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
           (0, @diff_str[0..7]);
         $lb1 = $INFINITY if ($lb1 < 0);
         $lb2 = $INFINITY if ($lb2 < 0);
         $le1 = $INFINITY if ($le1 < 0);
         $le2 = $INFINITY if ($le2 < 0);
         for (my $j = 0; $j < $rightRow; $j++) {
           my $line_len = length(@$rightColRef[$j]);
           my $line = @$rightColRef[$j];
           $r_cul += length($line) + 1; # includes "\n"
           my $r_culx = $r_cul - 1; # not includes "\n"
           if ($j < $lb2) {
             $line = spacedHtmlText($line);
             push(@right_html, "<td class=\"diff diff-changed\">$line</td>");
           } elsif ($lb2 == $j) {
             my $html_line;
             while ($lb2 == $j) {
               my $begin_char = $r_culx - $b2;
   
               $line =~ /^(.*)(.{$begin_char})$/;
               $html_line .= spacedHtmlText($1) .
                 '</span><span class="diff diff-unchanged">';
               $line = $2;
   
               last if ($j != $le2);
   
               my $end_char = $r_culx - $e2;
               $line =~ /^(.*)(.{$end_char})$/;
               $html_line .= spacedHtmlText($1) .
                 '</span><span class="diff diff-changed">';
               $line = $2;
   
               $idx++;
               my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) =
                 ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2);
               ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
                 @diff_str[$idx*8..($idx+1)*8-1];
               $lb1 = $INFINITY if ($lb1 < 0);
               $lb2 = $INFINITY if ($lb2 < 0);
               $le1 = $INFINITY if ($le1 < 0);
               $le2 = $INFINITY if ($le2 < 0);
               if ($te1 > $b1) {
                 ($b1, $lb1) = ($te1, $tle1);
               }
               if ($te2 > $b2) {
                 ($b2, $lb2) = ($te2, $tle2);
               }
             }
             push(@right_html,
                  sprintf('<td><span class="diff diff-changed">%s%s</span></td>',
                          $html_line, spacedHtmlText($line)));
           } elsif ($le2 == $j) {
             my $html_line;
             while ($le2 == $j) {
               my $end_char = $r_culx - $e2;
               $line =~ /^(.*)(.{$end_char})$/;
               $html_line .= spacedHtmlText($1) .
                 '</span><span class="diff diff-changed">';
               $line = $2;
   
               $idx++;
               my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) =
                 ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2);
               ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
                 @diff_str[$idx*8..($idx+1)*8-1];
               $lb1 = $INFINITY if ($lb1 < 0);
               $lb2 = $INFINITY if ($lb2 < 0);
               $le1 = $INFINITY if ($le1 < 0);
               $le2 = $INFINITY if ($le2 < 0);
               if ($te1 > $b1) {
                 ($b1, $lb1) = ($te1, $tle1);
               }
               if ($te2 > $b2) {
                 ($b2, $lb2) = ($te2, $tle2);
               }
   
               last if ($lb2 != $j);
   
               my $begin_char = $r_culx - $b2;
               $line =~ /^(.*)(.{$begin_char})$/;
               $html_line .= spacedHtmlText($1) .
                 '</span><span class="diff diff-unchanged">';
               $line = $2;
             }
             push(@right_html,
                  sprintf('<td nowrap="nowrap"><span class="diff diff-unchanged"'.
                          '>%s%s</span></td>',
                          $html_line, spacedHtmlText($line)));
           } else {
             $line = spacedHtmlText ($line);
             push @right_html, "<td class=\"diff diff-unchanged\">$line</td>";
           }
         }
         for (my $j = 0; $j < $leftRow || $j < $rightRow ; $j++) { # dump out both cols
           print  '<tr>';
           if ($j < $leftRow) {
             print $left_html[$j];
           } else {
             print '<td class="diff diff-changed-missing">&nbsp;</td>';
           }
           if ($j < $rightRow) {
             print $right_html[$j];
           } else {
             print '<td class="diff diff-changed-missing">&nbsp;</td>';
           }
           print "</tr>\n";
         }
       } else {
         for (my $j = 0; $j < $leftRow || $j < $rightRow; $j++) { # dump both cols
           print "<tr>\n";
           if ($j < $leftRow) {
             print '<td class="diff diff-changed">&nbsp;' .
               spacedHtmlText(@$leftColRef[$j]) . '</td>';
           } else {
             print '<td class="diff diff-changed-missing">&nbsp;</td>';
           }
           print "\n";
   
           if ($j < $rightRow) {
             print '<td class="diff diff-changed">&nbsp;' .
               spacedHtmlText(@$rightColRef[$j]) . '</td>';
           } else {
             print '<td class="diff diff-changed-missing">&nbsp;</td>';
           }
           print "\n</tr>\n";
         }
     }      }
     }
 }  }
   
 ##  
 # Function to generate Human readable diff-files  #
 # human_readable_diff(String revision_to_return_to);  # Generates "human readable", HTMLified diffs.
 ##  #
 sub human_readable_diff($){  sub human_readable_diff($$)
   my ($i,$difftxt, $where_nd, $filename, $pathname, $scriptwhere_nd);  {
   my ($fh, $rev) = @_;    my ($fh, $rev) = @_;
   my ($date1, $date2, $r1d, $r2d, $r1r, $r2r, $rev1, $rev2, $sym1, $sym2);  
   my (@rightCol, @leftCol);  
   
   ($where_nd = $where) =~ s/.diff$//;    (my $where_nd       = $where)       =~ s|\.diff$||;
   ($filename = $where_nd) =~ s/^.*\///;    (my $filename       = $where_nd)    =~ s|^.*/||;
   ($pathname = $where_nd) =~ s/(Attic\/)?[^\/]*$//;    (my $pathname       = $where_nd)    =~ s|((?<=/)Attic/)?[^/]*$||;
   ($scriptwhere_nd = $scriptwhere) =~ s/.diff$//;    (my $scriptwhere_nd = $scriptwhere) =~ s|\.diff$||;
   
   navigateHeader ($scriptwhere_nd, $pathname, $filename, $rev, "diff");    navigateHeader($scriptwhere_nd, $pathname, $filename, $rev, 'diff');
   
   # Read header to pick up read revision and date, if possible    # Read header to pick up read revision and date, if possible.
   
     my ($r1d, $r1r, $r2d, $r2r);
   while (<$fh>) {    while (<$fh>) {
       ($r1d,$r1r) = /\t(.*)\t(.*)$/ if (/^--- /);      ($r1d, $r1r) = /\t(.*)\t(.*)$/ if (/^--- /);
       ($r2d,$r2r) = /\t(.*)\t(.*)$/ if (/^\+\+\+ /);      ($r2d, $r2r) = /\t(.*)\t(.*)$/ if (/^\+\+\+ /);
       last if (/^\+\+\+ /);      last if (/^\+\+\+ /);
   }    }
   
     my ($rev1, $date1);
   if (defined($r1r) && $r1r =~ /^(\d+\.)+\d+$/) {    if (defined($r1r) && $r1r =~ /^(\d+\.)+\d+$/) {
     $rev1 = $r1r;      $rev1  = $r1r;
     $date1 = $r1d;      $date1 = $r1d;
   }    }
     my ($rev2, $date2);
   if (defined($r2r) && $r2r =~ /^(\d+\.)+\d+$/) {    if (defined($r2r) && $r2r =~ /^(\d+\.)+\d+$/) {
     $rev2 = $r2r;      $rev2  = $r2r;
     $date2 = $r2d;      $date2 = $r2d;
   }    }
     $rev1  = $input{r1}      unless defined($rev1);
   print "<h3 align=center>Diff for /$where_nd between version $rev1 and $rev2</h3>\n";    $rev1  = $input{tr1}     if (defined($rev1) && $rev1 eq 'text');
     $rev1  = 'unknown-left'  unless defined($rev1);
     $rev2  = $input{r2}      unless defined($rev2);
     $rev2  = $input{tr2}     if (defined($rev2) && $rev2 eq 'text');
     $rev2  = 'unknown-right' unless defined($rev2);
     $date1 = defined($date1) ? ', ' . htmlquote($date1) : '';
     $date2 = defined($date2) ? ', ' . htmlquote($date2) : '';
   
   print "<table border=0 cellspacing=0 cellpadding=0 width=\"100%\">\n";    my $link = uri_escape($filename) . ($query ? "$query;" : '?');
   print "<tr bgcolor=\"#ffffff\">\n";  
   print "<th width=\"50%\" valign=TOP>";  
   print "version $rev1";  
   print ", $date1" if (defined($date1));  
   print "<br>Tag: $sym1\n" if ($sym1);  
   print "</th>\n";  
   print "<th width=\"50%\" valign=TOP>";  
   print "version $rev2";  
   print ", $date2" if (defined($date2));  
   print "<br>Tag: $sym2\n" if ($sym1);  
   print "</th>\n";  
   
   my $fs = "<font face=\"$difffontface\" size=\"$difffontsize\">";    # Using <table style=\"border: none\" here breaks NS 4.x badly...
   my $fe = "</font>";    print <<EOF;
   <h3 style="text-align: center">Diff for /$where_nd between versions $rev1 and $rev2</h3>
   <table border="0" cellspacing="0" cellpadding="0" width="100%" summary="Diff output">
   <tr style="background-color: #ffffff">
   <th style="text-align: center; vertical-align: top" width="50%">
   <a href="${link}rev=$rev1">version $rev1</a>$date1
   </th>
   <th style="text-align: center; vertical-align: top" width="50%">
   <a href="${link}rev=$rev2">version $rev2</a>$date2
   </th>
   </tr>
   EOF
   
   my $leftRow = 0;    # Process diff text
     # prefetch several lines
     my @buf = head($fh);
     my %d = scan_directives(@buf);
   
     my $leftRow  = 0;
   my $rightRow = 0;    my $rightRow = 0;
   my ($oldline, $newline, $funname, $diffcode, $rest);    my ($difftxt, @rightCol, @leftCol, $oldline, $newline, $funname);
   
   # Process diff text    $link .= 'content-type=text%2Fx-cvsweb-markup;';
   # The diffrows are could make excellent use of    $link .= 'ln=1;' unless ($link =~ /\?.*\bln=1\b/);
   # cascading style sheets because we've to set the  
   # font and color for each row. anyone ...?  
   ####  
   while (<$fh>) {  
       $difftxt = $_;  
   
       if ($difftxt =~ /^@@/) {  
           ($oldline,$newline,$funname) = $difftxt =~ /@@ \-([0-9]+).*\+([0-9]+).*@@(.*)/;  
           print  "<tr bgcolor=\"$diffcolorHeading\"><td width=\"50%\">";  
           print  "<table width=\"100%\" border=1 cellpadding=5><tr><td><b>Line $oldline</b>";  
           print  "&nbsp;<font size=-1>$funname</font></td></tr></table>";  
           print  "</td><td width=\"50%\">";  
           print  "<table width=\"100%\" border=1 cellpadding=5><tr><td><b>Line $newline</b>";  
           print  "&nbsp;<font size=-1>$funname</font></td></tr></table>";  
           print  "</td>\n";  
           $state = "dump";  
           $leftRow = 0;  
           $rightRow = 0;  
       }  
       else {  
           ($diffcode,$rest) = $difftxt =~ /^([-+ ])(.*)/;  
           $_ = spacedHtmlText ($rest);  
   
           # Add fontface, size    while (@buf || !eof($fh)) {
           $_ = "$fs&nbsp;$_$fe";      $difftxt = @buf ? shift @buf : <$fh>;
   
           #########  
           # little state machine to parse unified-diff output (Hen, zeller@think.de)  
           # in order to get some nice 'ediff'-mode output  
           # states:  
           #  "dump"             - just dump the value  
           #  "PreChangeRemove"  - we began with '-' .. so this could be the start of a 'change' area or just remove  
           #  "PreChange"        - okey, we got several '-' lines and moved to '+' lines -> this is a change block  
           ##########  
   
           if ($diffcode eq '+') {      if ($difftxt =~ /^@@/) {
               if ($state eq "dump") {  # 'change' never begins with '+': just dump out value        ($oldline, $newline, $funname) =
                   print  "<tr><td bgcolor=\"$diffcolorEmpty\">&nbsp;</td><td bgcolor=\"$diffcolorAdd\">$_</td></tr>\n";          $difftxt =~ /@@ \-([0-9]+).*\+([0-9]+).*@@(.*)/;
               }        $funname = htmlquote($funname);
               else {                   # we got minus before        $funname =~ s/\s/&nbsp;/go;
                   $state = "PreChange";        $funname &&= "&nbsp;<span style=\"font-size: smaller\">$funname</span>";
                   $rightCol[$rightRow++] = $_;        my $ol = $oldline || 1;
               }        my $nl = $newline || 1;
           }  
           elsif ($diffcode eq '-') {        print <<EOF;
               $state = "PreChangeRemove";  <tr>
               $leftCol[$leftRow++] = $_;  <td width="50%" class="diff-heading">
    <b><a href="${link}rev=$rev1#l$ol">Line&nbsp;$oldline</a></b>$funname
   </td>
   <td width="50%" class="diff-heading">
    <b><a href="${link}rev=$rev2#l$nl">Line&nbsp;$newline</a></b>$funname
   </td>
   </tr>
   EOF
   
         $state    = "dump";
         $leftRow  = 0;
         $rightRow = 0;
       } else {
         my ($diffcode, $rest) = $difftxt =~ /^([-+ ])(.*)/;
         $diffcode = '' unless defined($diffcode);
         $_ = $rest;
   
         #########
         # little state machine to parse unified-diff output (Hen, zeller@think.de)
         # in order to get some nice 'ediff'-mode output
         # states:
         #  "dump"             - just dump the value
         #  "PreChangeRemove"  - we began with '-' .. so this could be the start of a 'change' area or just remove
         #  "PreChange"        - okey, we got several '-' lines and moved to '+' lines -> this is a change block
         ##########
   
         if ($diffcode eq '+') {
           if ($state eq "dump")
           {    # 'change' never begins with '+': just dump out value
             $_ = spacedHtmlText($rest, $d{tabstop});
             printf(<<EOF, $_);
   <tr>
    <td class="diff diff-empty">&nbsp;</td>
    <td class="diff diff-added">&nbsp;%s</td>
   </tr>
   EOF
           } else {    # we got minus before
             $state = "PreChange";
             $rightCol[$rightRow++] = $_;
         }          }
         else {  # empty diffcode        } elsif ($diffcode eq '-') {
             flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;          $state = "PreChangeRemove";
               print  "<tr><td>$_</td><td>$_</td></tr>\n";          $leftCol[$leftRow++] = $_;
               $state = "dump";        } else {    # empty diffcode
               $leftRow = 0;          flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;
               $rightRow = 0;          $_ = spacedHtmlText($rest, $d{tabstop});
           }          printf(<<EOF, $_, $_);
   <tr>
    <td class="diff diff-same">&nbsp;%s</td>
    <td class="diff diff-same">&nbsp;%s</td>
   </tr>
   EOF
           $state    = "dump";
           $leftRow  = 0;
           $rightRow = 0;
       }        }
       }
   }    }
     close($fh);
   
   flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;    flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;
   
   # state is empty if we didn't have any change    # state is empty if we didn't have any change
   if (!$state) {    if (!$state) {
       print "<tr><td colspan=2>&nbsp;</td></tr>";      print <<EOF;
       print "<tr bgcolor=\"$diffcolorEmpty\" >";  <tr>
       print "<td colspan=2 align=center><b>- No viewable Change -</b></td></tr>";   <td colspan="2">&nbsp;</td>
   </tr>
   <tr class="diff diff-empty">
    <td colspan="2" align="center"><b>- No viewable change -</b></td>
   </tr>
   EOF
   }    }
   print  "</table>";  
   close($fh);  
   
   print "<br><hr noshade width=\"100%\">\n";    printf(<<EOF, $scriptwhere);
   </table>
   <hr style="width: 100%%" />
   <form method="get" action="%s">
   <div style="float: left">
   <label for="f">Diff format:<br />
   EOF
     printDiffSelectStickyVars();
     printDiffSelect($use_java_script);
     printf(<<EOF, $rev1, $rev2);
   </label>
   <input type="submit" value="Show" />
   </div>
   <table style="float: right; border: thin outset" cellspacing="0" cellpadding="1" title="Legend" summary="Legend">
    <tr>
     <td align="center" class="diff diff-removed">Removed from v.%s</td>
     <td class="diff diff-empty">&nbsp;</td>
    </tr><tr class="diff diff-changed">
     <td align="center" colspan="2">changed lines</td>
    </tr><tr>
     <td class="diff diff-empty">&nbsp;</td>
     <td align="center" class="diff diff-added">Added in v.%s</td>
    </tr>
   </table>
   </form>
   <br clear="all" />
   EOF
   }
   
   print "<table border=0>";  
   
   print "<tr><td>";  sub doEnscript($$$;$)
   # print legend  {
   print "<table border=1><tr><td>";    my ($filehandle, $highlight, $linenumbers, $lang) = @_;
   print  "Legend:<br><table border=0 cellspacing=0 cellpadding=1>\n";    $lang ||= 'cvsweb';
   print  "<tr><td align=center bgcolor=\"$diffcolorRemove\">Removed from v.$rev1</td><td bgcolor=\"$diffcolorEmpty\">&nbsp;</td></tr>";  
   print  "<tr bgcolor=\"$diffcolorChange\"><td align=center colspan=2>changed lines</td></tr>";  
   print  "<tr><td bgcolor=\"$diffcolorEmpty\">&nbsp;</td><td align=center bgcolor=\"$diffcolorAdd\">Added in v.$rev2</td></tr>";  
   print  "</table></td></tr></table>\n";  
   
   print "<td>";    my @cmd = ($CMD{enscript},
   # Print format selector               @enscript_options,
   print "<FORM METHOD=\"GET\" ACTION=\"${scriptwhere}\">\n";               '-q', "--language=$lang", '-o', '-', "--highlight=$highlight");
   foreach my $var (keys %input) {  
     next if ($var eq "f");  
     next if (defined($DEFAULTVALUE{$var})  
              && $DEFAULTVALUE{$var} eq $input{$var});  
     print "<INPUT TYPE=HIDDEN NAME=\"",urlencode($var),"\" VALUE=\"",  
             urlencode($input{$var}),"\">\n";  
   }  
   printDiffSelect($use_java_script);  
   print "<INPUT TYPE=SUBMIT VALUE=\"Show\">\n";  
   print "</FORM>\n";  
   print "</td>";  
   
   print "</tr></table>";    local *ENSCRIPT_OUT;
     my ($h, $err) =
       startproc(\@cmd, $filehandle, '>pipe', \*ENSCRIPT_OUT);
     fatal('500 Internal Error', $err) unless $h;
   
     # We could short-circuit and have enscript output directly to STDOUT above,
     # but that doesn't work with mod_perl (at least some 1.99 versions).
     if ($linenumbers) {
       my $ln = 0;
       while (<ENSCRIPT_OUT>) {
         printf '<a id="l%d" class="src">%5d: </a>', (++$ln) x 2;
         print $_;
       }
     } else {
       local $/ = undef;
       print <ENSCRIPT_OUT>;
     }
     $h->finish();
 }  }
   
 sub navigateHeader ($$$$$) {  
     my ($swhere,$path,$filename,$rev,$title) = @_;  #
     $swhere = "" if ($swhere eq $scriptwhere);  # The passed in $path and $filename should not be URI escaped, and $swhere
     $swhere = urlencode($filename) if ($swhere eq "");  # *should* be.
     print "<\!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\">";  #
     print "<HTML>\n<HEAD>\n";  sub navigateHeader($$$$$;$)
     print '<!-- CVSweb $Revision$ -->';  {
     print "\n<TITLE>$path$filename - $title - $rev</TITLE></HEAD>\n";    my ($swhere, $path, $filename, $rev, $title, $moddate) = @_;
     print  "<BODY BGCOLOR=\"$backcolor\">\n";    $swhere = "" if ($swhere eq $scriptwhere);
     print "<table width=\"100%\" border=0 cellspacing=0 cellpadding=1 bgcolor=\"$navigationHeaderColor\">";    $swhere = './' . uri_escape($filename) if ($swhere eq "");
     print "<tr valign=bottom><td>";  
     print  "<a href=\"$swhere$query#rev$rev\">$backicon";    my $qfile = htmlquote($filename);
     print "</a> <b>Return to ", &link("$filename","$swhere$query#rev$rev")," CVS log";    my $qpath = htmlquote($path);
     print "</b> $fileicon</td>";    my $trev  = $rev ? " - " . htmlquote($rev) : '';
   
     print "<td align=right>$diricon <b>Up to ", &clickablePath($path, 1), "</b></td>";    http_header('text/html', $moddate);
     print "</tr></table>";  
     print <<EOF;
   $HTML_DOCTYPE
   <html>
   <head>
   <title>$qpath$qfile - $title$trev</title>
   $HTML_META$CSS</head>
   <body class="src">
   <table class="navigate-header" width="100%" summary="Navigation">
    <tr>
     <td>
   EOF
   
     my $frag = '';
     if ($rev) {
       $frag  = '#';
       $frag .= 'rev' if ($rev =~ /\./);  # Normal revision: prefix with "rev".
       $frag .= $rev;                     # Append revision/branch/tag.
     }
     my $backurl = "$swhere$query$frag";
   
     print &link($backicon, $backurl);
     printf '<b>Return to %s CVS log', &link($qfile, $backurl);
     print "</b> $fileicon</td>";
   
     printf(<<EOF, $diricon, &clickablePath($path, 1));
     <td style="text-align: right">%s <b>Up to %s</b></td>
    </tr>
   </table>
   EOF
 }  }
   
 sub plural_write ($$)  
   sub plural_write($$)
 {  {
     my ($num,$text) = @_;    my ($num, $text) = @_;
     if ($num != 1) {    if ($num != 1) {
         $text = $text . "s";      $text .= "s";
     }    }
     if ($num > 0) {  
         return $num . " " . $text;    if ($num > 0) {
     }      return join (' ', $num, $text);
     else {    } else {
         return "";      return "";
     }    }
 }  }
   
   
 ##  ##
 # print readable timestamp in terms of  # print readable timestamp in terms of
 # '..time ago'  # '..time ago'
 # H. Zeller <zeller@think.de>  # H. Zeller <zeller@think.de>
 ##  ##
 sub readableTime ($$)  sub readableTime($$)
 {  {
     my ($i, $break, $retval);    my ($secs, $long) = @_;
     my ($secs,$long) = @_;  
   
     # this function works correct for time >= 2 seconds    # This function works correctly for time >= 2 seconds.
     if ($secs < 2) {    return 'very little time' if ($secs < 2);
         return "very little time";  
     }  
   
     my %desc = (1 , 'second',    my %desc = (
                    60, 'minute',                1        => 'second',
                    3600, 'hour',                60       => 'minute',
                    86400, 'day',                3600     => 'hour',
                    604800, 'week',                86400    => 'day',
                    2628000, 'month',                604800   => 'week',
                    31536000, 'year');                2628000  => 'month',
     my @breaks = sort {$a <=> $b} keys %desc;                31536000 => 'year'
     $i = 0;               );
     while ($i <= $#breaks && $secs >= 2 * $breaks[$i]) {  
         $i++;    my @breaks = sort { $a <=> $b } keys %desc;
     }    my $i = 0;
   
     while ($i <= $#breaks && $secs >= 2 * $breaks[$i]) {
       $i++;
     }
     $i--;
     my $break  = $breaks[$i];
     my $retval = plural_write(int($secs / $break), $desc{$break});
   
     if ($long == 1 && $i > 0) {
       my $rest = $secs % $break;
     $i--;      $i--;
     $break = $breaks[$i];      $break = $breaks[$i];
     $retval = plural_write(int ($secs / $break), $desc{$break});      my $resttime = plural_write(int($rest / $break), $desc{$break});
       if ($resttime) {
     if ($long == 1 && $i > 0) {        $retval .= ", $resttime";
         my $rest = $secs % $break;  
         $i--;  
         $break = $breaks[$i];  
         my $resttime = plural_write(int ($rest / $break),  
                                 $desc{$break});  
         if ($resttime) {  
             $retval = $retval . ", " . $resttime;  
         }  
     }      }
     }
   
     return $retval;    return $retval;
 }  }
   
 ##  
 # clickablePath(String pathname, boolean last_item_clickable)  
 #  #
 # returns a html-ified path whereas each directory is a link for  # Returns a htmlified path where each directory is a link for faster
 # faster navigation. last_item_clickable controls whether the  # navigation.  $clickLast controls whether the basename
 # basename (last directory/file) is a link as well  # (last directory/file) is a link as well.  The passed in $pathname should
 ##  # *not* be URI escaped.
 sub clickablePath($$) {  #
     my ($pathname,$clickLast) = @_;  sub clickablePath($$)
     my $retval = '';  {
     my ($pathname, $clickLast) = @_;
     if ($pathname eq '/') {  
         # this should never happen - chooseCVSRoot() is    my $root = '[' . htmlquote($CVSROOTdescr{$cvstree} || $cvstree) . ']';
         # intended to do this  
         $retval = "[$cvstree]";    # This should never happen (see chooseCVSRoot()), but let's be sure...
     return $root if ($pathname eq '/');
   
     my $retval =
       ' ' . &link($root, sprintf('%s/%s#dirlist', $scriptname, $query));
     my $wherepath = '';
     my ($lastslash) = $pathname =~ m|/$|;
   
     foreach (split(m|/|, $pathname)) {
       $retval .= ' / ';
       $wherepath .= "/$_";
       my $last = "$wherepath/" eq "/$pathname" || $wherepath eq "/$pathname";
   
       if ($clickLast || !$last) {
         $retval .= &link(htmlquote($_),
                          join ('',
                                $scriptname, uri_escape_path($wherepath),
                                (!$last || $lastslash ? '/' : ''), $query,
                                (!$last || $lastslash ? "#dirlist" : "")));
       } else {    # do not make a link to the current dir
         $retval .= htmlquote($_);
     }      }
     else {    }
         $retval = $retval . " <a href=\"${scriptname}/${query}#dirlist\">[$cvstree]</a>";    return $retval;
         my $wherepath = '';  
         my ($lastslash) = $pathname =~ m|/$|;  
         foreach (split(/\//, $pathname)) {  
             $retval = $retval . " / ";  
             $wherepath = $wherepath . '/' . $_;  
             my ($last) = "$wherepath/" eq "/$pathname"  
                 || $wherepath eq "/$pathname";  
             if ($clickLast || !$last) {  
                 $retval = $retval . "<a href=\"${scriptname}"  
                     . urlencode($wherepath)  
                     . (!$last || $lastslash ? '/' : '')  
                     . ${query}  
                     . (!$last || $lastslash ? "#dirlist" : "")  
                     . "\">$_</a>";  
             }  
             else { # do not make a link to the current dir  
                 $retval = $retval .  $_;  
             }  
         }  
     }  
     return $retval;  
 }  }
   
 sub chooseCVSRoot() {  
     my @foo;  sub chooseCVSRoot()
     foreach (sort keys %CVSROOT) {  {
         if (-d $CVSROOT{$_}) {    print "<form method=\"get\" action=\"$scriptwhere\">\n<p>\n";
             push(@foo, $_);    if (2 <= @CVSROOT) {
         }      foreach my $k (keys %input) {
         printf("<input type=\"hidden\" name=\"%s\" value=\"%s\" />\n",
                htmlquote($k), htmlquote($input{$k}))
           if ($input{$k} && $k ne 'cvsroot');
     }      }
     if (@foo > 1) {  
         my ($k);      printf(<<EOF, $use_java_script ? ' onchange="this.form.submit()"' : '');
         print "<form method=\"GET\" action=\"${scriptwhere}\">\n";  <label for="cvsroot" accesskey="C">CVS Root:
         foreach $k (keys %input) {  <select id="cvsroot" name="cvsroot"%s>
             print "<input type=hidden NAME=$k VALUE=$input{$k}>\n"  EOF
                 if ($input{$k}) && ($k ne "cvsroot");  
         }      foreach my $k (@CVSROOT) {
         # Form-Elements look wierd in Netscape if the background        printf("<option value=\"%s\"%s>%s</option>\n",
         # isn't gray and the form elements are not placed               htmlquote($k),
         # within a table ...               ($k eq $cvstree) ? ' selected="selected"' : '',
         print "<table><tr>";               htmlquote($CVSROOTdescr{$k} || $k));
         print "<td>CVS Root:</td>";  
         print "<td>\n<select name=\"cvsroot\"";  
         print " onchange=\"submit()\"" if ($use_java_script);  
         print ">\n";  
         foreach $k (@foo) {  
             print "<option value=\"$k\"";  
             print " selected" if ($k eq $cvstree);  
             print ">" . ($CVSROOTdescr{$k} ? $CVSROOTdescr{$k} :  
                         $k). "</option>\n";  
         }  
         print "</select>\n</td>";  
         print "<td><input type=submit value=\"Go\"></td>";  
         print "</tr></table></form>";  
     }      }
     else {      print '</select></label>';
         # no choice ..    } else {
         print "CVS Root: <b>[$cvstree]</b>";  
     }      # no choice -- but we need the form to select module/path,
       # at least for Netscape
       printf "CVS Root: <b>[%s]</b>",
         htmlquote($CVSROOTdescr{$cvstree} || $cvstree);
     }
   
     print <<EOF;
   <label for="mpath" accesskey="M">
   Module path or alias:
   <input type="text" id="mpath" name="path" value="" size="15" />
   </label>
   <input type="submit" value="Go" accesskey="O" />
   </p>
   </form>
   EOF
 }  }
   
 sub chooseMirror() {  
     my ($mirror,$moremirrors);  sub chooseMirror()
     $moremirrors = 0;  {
     # This code comes from the original BSD-cvsweb    # This code comes from the original BSD-cvsweb
     # and may not be useful for your site; If you don't    # and may not be useful for your site; If you don't
     # set %MIRRORS this won't show up, anyway    # set %MIRRORS this won't show up, anyway.
     #    scalar(%MIRRORS) or return;
     # Should perhaps exlude the current site somehow..  
     if (keys %MIRRORS) {    # Should perhaps exclude the current site somehow...
         print "\nThis cvsweb is mirrored in:\n";    print "\n<p>\nThis CVSweb is mirrored in\n";
         foreach $mirror (keys %MIRRORS) {  
             print ", " if ($moremirrors);    my @tmp = map(&link(htmlquote($_), $MIRRORS{$_}), sort keys %MIRRORS);
             print qq(<a href="$MIRRORS{$mirror}">$mirror</A>\n);    my $tmp = pop (@tmp);
             $moremirrors = 1;  
         }    if (scalar(@tmp)) {
         print "<p>\n";      print join (', ', @tmp), ' and ';
     }    }
   
     print "$tmp.\n</p>\n";
 }  }
   
 sub fileSortCmp {  
     my ($comp) = 0;  
     my ($c,$d,$af,$bf);  
   
     ($af = $a) =~ s/,v$//;  sub fileSortCmp()
     ($bf = $b) =~ s/,v$//;  {
     my ($rev1,$date1,$log1,$author1,$filename1) = @{$fileinfo{$af}}    (my $af = $a) =~ s/,v$//;
         if (defined($fileinfo{$af}));    (my $bf = $b) =~ s/,v$//;
     my ($rev2,$date2,$log2,$author2,$filename2) = @{$fileinfo{$bf}}    my ($rev1, $date1, $log1, $author1, $filename1) = @{$fileinfo{$af}}
         if (defined($fileinfo{$bf}));      if (defined($fileinfo{$af}));
     my ($rev2, $date2, $log2, $author2, $filename2) = @{$fileinfo{$bf}}
       if (defined($fileinfo{$bf}));
   
     if (defined($filename1) && defined($filename2) && $af eq $filename1 && $bf eq $filename2) {    my $comp = 0;
         # Two files    if (defined($filename1) && defined($filename2) &&
         $comp = -revcmp($rev1, $rev2) if ($byrev && $rev1 && $rev2);        $af eq $filename1   && $bf eq $filename2)
         $comp = ($date2 <=> $date1) if ($bydate && $date1 && $date2);    {
         $comp = ($log1 cmp $log2) if ($bylog && $log1 && $log2);  
         $comp = ($author1 cmp $author2) if ($byauthor && $author1 && $author2);      # Two files
       $comp = -revcmp($rev1, $rev2)             if ($byrev  && $rev1  && $rev2);
       $comp = ($date2   <=> $date1)             if ($bydate && $date1 && $date2);
       if ($input{ignorecase}) {
         $comp = (uc($log1)    cmp uc($log2))    if ($bylog && $log1 && $log2);
         $comp = (uc($author1) cmp uc($author2)) if ($byauthor &&
                                                     $author1 && $author2);
       } else {
         $comp = ($log1    cmp $log2)            if ($bylog && $log1 && $log2);
         $comp = ($author1 cmp $author2)         if ($byauthor &&
                                                     $author1 && $author2);
     }      }
     if ($comp == 0) {    }
         # Directories first, then sorted on name if no other sort critera  
         # available.    if ($comp == 0) {
         my $ad = ((-d "$fullname/$a")?"D":"F");  
         my $bd = ((-d "$fullname/$b")?"D":"F");      # Directories first, then files under version control,
         ($c=$a) =~ s|.*/||;      # then other, "rogue" files.
         ($d=$b) =~ s|.*/||;      # Sort by filename if no other criteria available.
         $comp = ("$ad$c" cmp "$bd$d");  
       my $ad = (
         (-d "$fullname/$a")
         ? 'D'
         : (defined($fileinfo{$af}) ? 'F' : 'R')
       );
       my $bd = (
         (-d "$fullname/$b")
         ? 'D'
         : (defined($fileinfo{$bf}) ? 'F' : 'R')
       );
       (my $c = $a) =~ s|.*/||;
       (my $d = $b) =~ s|.*/||;
   
       my ($l, $r) = ("$ad$c", "$bd$d");
       $comp = $input{ignorecase} ? (uc($l) cmp uc($r)) : ($l cmp $r);
   
       # Parent dir is always first, then Attic.
       if ($comp != 0) {
         if ($l eq 'D..') {
           $comp = -1;
         } elsif ($r eq 'D..') {
           $comp = 1;
         } elsif ($l eq 'DAttic') {
           $comp = -1;
         } elsif ($r eq 'DAttic') {
           $comp = 1;
         }
     }      }
     return $comp;    }
     return $comp;
 }  }
   
 # make A url for downloading  #
 sub download_url {  # Returns a URL to download the selected revision.
     my ($url,$revision,$mimetype) = @_;  # Expects the passed in URL to be URI escaped, relative, and without a query
   # string.
   #
   sub download_url($$;$)
   {
     my ($url, $revision, $mimetype) = @_;
     my @dots = $revision =~ /\./g;
     $revision =~ s/\b0\.(?=\d+$)// if (scalar(@dots) & 1);
   
     $revision =~ s/\b0\.//;    if (!defined($mimetype) || $mimetype !~ CVSWEBMARKUP) {
       my $path = $where;
       $path =~ s|[^/]+$||;
       $url = "$scriptname/$CheckoutMagic/$path$url";
     }
     $url .= '?rev=' . uri_escape($revision);
     $url .= ';content-type=' . uri_escape($mimetype) if $mimetype;
   
     if (defined($checkout_magic)    return $url;
         && (!defined($mimetype) || $mimetype ne "text/x-cvsweb-markup")) {  }
         my ($path);  
         ($path = $where) =~ s|/[^/]*$|/|;  
         $url = "$scriptname/$checkoutMagic/${path}$url";  
     }  
     $url .= "?rev=$revision";  
     $url .= "&amp;content-type=$mimetype" if (defined($mimetype));  
   
     return $url;  #
   # Returns a link to download the selected revision.
   # Expects the passed in URL to be URI escaped, relative,
   # and without a query string.
   #
   sub download_link($$$;$)
   {
     my ($url, $revision, $textlink, $mimetype) = @_;
     return sprintf('<a href="%s" class="download-link">%s</a>',
                    download_url($url, $revision, $mimetype) . $barequery,
                    htmlquote($textlink));
 }  }
   
 # Presents a link to download the  #
 # selected revision  # Returns a URL to display the selected revision.
 sub download_link {  # Expects the passed in URL to be URI escaped, and without a query string.
     my ($url,$revision,$textlink,$mimetype) = @_;  #
     my ($fullurl) = download_url($url,$revision,$mimetype);  sub display_url($$;$)
     my ($paren) = $textlink =~ /^\(/;  {
     $textlink =~ s/^\(// if ($paren);    my ($url, $revision, $mimetype) = @_;
     $textlink =~ s/\)$// if ($paren);    $url .= '?rev=' . uri_escape($revision);
     print "(" if ($paren);    $url .= ';content-type=' . uri_escape($mimetype) if $mimetype;
     print "<A HREF=\"$fullurl";    return $url;
     print $barequery;  
     print "\"";  
     if ($open_extern_window && (!defined($mimetype) || $mimetype ne "text/x-cvsweb-markup")) {  
         print " target=\"cvs_checkout\"";  
         # we should have  
         #   'if (document.cvswin==null) document.cvswin=window.open(...'  
         # in order to allow the user to resize the window; otherwise  
         # the user may resize the window, but on next checkout - zap -  
         # its original (configured s. cvsweb.conf) size is back again  
         # .. annoying (if $extern_window_(width|height) is defined)  
         # but this if (..) solution is far from perfect  
         # what we need to do as well is  
         # 1) save cvswin in an invisible frame that always exists  
         #    (document.cvswin will be void on next load)  
         # 2) on close of the cvs_checkout - window set the cvswin  
         #    variable to 'null' again - so that it will be  
         #    reopenend with the configured size  
         # anyone a JavaScript programmer ?  
         # .. so here without if (..):  
         # currently, the best way is to comment out the size parameters  
         # ($extern_window...) in cvsweb.conf.  
         if ($use_java_script) {  
             print " onClick=\"window.open('$fullurl','cvs_checkout',";  
             print "'resizeable,scrollbars";  
             print ",status,toolbar" if (defined($mimetype)  
                 && $mimetype eq "text/html");  
             print ",width=$extern_window_width" if (defined($extern_window_width));  
             print ",height=$extern_window_height" if (defined($extern_window_height));  
             print"');\"";  
         }  
     }  
     print "><b>$textlink</b></A>";  
     print ")" if ($paren);  
 }  }
   
   #
   # Returns a link to display the selected revision.
   # Expects the passed in URL to be URI escaped, and without a query string.
   #
   sub display_link($$;$$)
   {
     my ($url, $revision, $textlink, $mtype) = @_;
     $textlink = $revision unless defined($textlink);
     return sprintf('<a href="%s" class="display-link">%s</a>',
                    display_url($url, $revision, $mtype) . $barequery,
                    htmlquote($textlink));
   }
   
   #
   # Expects the passed in URL to be URI escaped, and without a query string.
   # The passed in link text should be already HTML escaped as appropriate.
   #
   sub graph_link($;$)
   {
     my ($url, $text) = @_;
     $text ||= $graphicon;
     return sprintf('<a href="%s?graph=1%s">%s</a>', $url, $barequery, $text);
   }
   
   #
   # Returns a link to CVSHistory for the given directory and filename.
   #
   sub history_link($$;$)
   {
     my ($dir, $file, $text) = @_;
     $dir  ||= '';
     $file ||= '';
     $text ||= 'History';
     return &link($text,
                  sprintf('%s?cvsroot=%s;dsearch=%s;fsearch=%s;limit=1',
                          $cvshistory_url, uri_escape($input{cvsroot} || ''),
                          uri_escape($dir), uri_escape($file)));
   }
   
 # Returns a Query string with the  # Returns a Query string with the
 # specified parameter toggled  # specified parameter toggled
 sub toggleQuery($$) {  sub toggleQuery($;$)
     my ($toggle,$value) = @_;  {
     my ($newquery,$var);    my ($toggle, $value) = @_;
     my (%vars);  
     %vars = %input;    my %vars = %input;
     if (defined($value)) {  
         $vars{$toggle} = $value;    if (defined($value)) {
       $vars{$toggle} = $value;
     } else {
       $vars{$toggle} = $vars{$toggle} ? 0 : 1;
     }
   
     # Build a new query of non-default paramenters
     my $newquery = "";
     foreach my $var (@stickyvars) {
       my ($value)   = defined($vars{$var})         ? $vars{$var}         : "";
       my ($default) = defined($DEFAULTVALUE{$var}) ? $DEFAULTVALUE{$var} : "";
   
       if ($value ne $default) {
         $newquery .= ';' if ($newquery ne "");
         $newquery .= uri_escape($var) . '=' . uri_escape($value);
     }      }
     else {    }
         $vars{$toggle} = $vars{$toggle} ? 0 : 1;  
     }    if ($newquery) {
     # Build a new query of non-default paramenters      return '?' . $newquery;
     $newquery = "";    }
     foreach $var (@stickyvars) {    return "";
         my ($value) = defined($vars{$var}) ? $vars{$var} : "";  
         my ($default) = defined($DEFAULTVALUE{$var}) ? $DEFAULTVALUE{$var} : "";  
         if ($value ne $default) {  
             $newquery .= "&amp;" if ($newquery ne "");  
             $newquery .= urlencode($var) . "=" . urlencode($value);  
         }  
     }  
     if ($newquery) {  
         return '?' . $newquery;  
     }  
     return "";  
 }  }
   
 sub urlencode {  sub htmlquote($)
     my ($in) = @_;  {
     my ($out);    local ($_) = @_;
     ($out = $in) =~ s/([\000-+{-\377])/sprintf("%%%02x", ord($1))/ge;    # Special Characters; RFC 1866
     return $out;    s/&/&amp;/g;
     s/\"/&quot;/g;
     s/"/&quot;/g;
     s/</&lt;/g;
     s/>/&gt;/g;
     return $_;
 }  }
   
 sub http_header {  sub htmlunquote($)
     my $content_type = shift || "text/html";  {
     if (defined($moddate)) {    local ($_) = @_;
         if ($is_mod_perl) {    # Special Characters; RFC 1866
             Apache->request->header_out(Last_modified => scalar gmtime($moddate) . " GMT");    s/&quot;/\"/g;
         }    s/&lt;/</g;
         else {    s/&gt;/>/g;
             print "Last-Modified: " . scalar gmtime($moddate) . " GMT\n";    s/&amp;/&/g;
         }    return $_;
   }
   
   sub uri_escape_path($)
   {
     return join('/', map(uri_escape($_), split(m|/+|, shift, -1)));
   }
   
   sub http_header(;$$)
   {
     my ($content_type, $moddate) = @_;
     $content_type ||= 'text/html';
   
     $content_type .= "; charset=$charset"
       if ($charset && $content_type =~ m,^text/,);
   
     # Note that in the following, we explicitly join() and concatenate the
     # headers instead of printing them as an array.  This is because some
     # systems, eg. early versions of mod_perl 2 don't quite get it if the
     # last \r\n\r\n isn't included in the last "payload" header print().
   
     my @headers = ();
     # TODO: ctime(3) from scalar gmtime() isn't HTTP compliant, see HTTP::Date.
     push(@headers, 'Last-Modified: ' . scalar gmtime($moddate) . ' GMT')
       if $moddate;
     push(@headers, 'Content-Type: ' . $content_type);
     push(@headers, "Content-Security-Policy: default-src 'none'; " .
       "img-src 'self'; style-src 'unsafe-inline'");
   
     if ($allow_compress && $maycompress) {
       if (HAS_ZLIB
           || (defined($CMD{gzip}) && open(GZIP, "| $CMD{gzip} -1 -c")))
       {
   
         push(@headers, 'Content-Encoding: gzip');
         push(@headers, 'Vary: Accept-Encoding');     # RFC 2616, 14.44
         print join("\r\n", @headers) . "\r\n\r\n";
   
         $| = 1;
         $| = 0;                                      # Flush header output.
   
         tie(*GZIP, __PACKAGE__, \*STDOUT) if HAS_ZLIB;
         select(GZIP);
         $gzip_open = 1;
   
       } else {
   
         print join("\r\n", @headers) . "\r\n\r\n";
         printf
           '<span style="font-size: smaller">Unable to find gzip binary in the <b>$command_path</b> (<code>%s</code>) to compress output</span><br />',
             htmlquote(join(':', @command_path));
     }      }
     if ($is_mod_perl) {  
         Apache->request->content_type($content_type);    } else {
     }      print join("\r\n", @headers) . "\r\n\r\n";
     else {    }
             print "Content-type: $content_type\n";  
     }  
     if ($allow_compress && $maycompress) {  
         my $fh = do {local(*FH);};  
         if (defined($GZIPBIN) && open($fh, "|$GZIPBIN -1 -c")) {  
             if ($is_mod_perl) {  
                     Apache->request->content_encoding("x-gzip");  
                     Apache->request->header_out(Vary => "Accept-Encoding");  
                     Apache->request->send_http_header;  
             }  
             else {  
                     print "Content-encoding: x-gzip\n";  
                     print "Vary: Accept-Encoding\n";  #RFC 2068, 14.43  
                     print "\n"; # Close headers  
             }  
             $| = 1; $| = 0; # Flush header output  
             select ($fh);  
 #           print "<!-- gzipped -->" if ($content_type eq "text/html");  
         }  
         else {  
             if ($is_mod_perl) {  
                     Apache->request->send_http_header;  
             }  
             else {  
                     print "\n"; # Close headers  
             }  
             print "<font size=-1>Unable to find gzip binary in the \$PATH to compress output</font><br>";  
         }  
     }  
     else {  
             if ($is_mod_perl) {  
                     Apache->request->send_http_header;  
             }  
             else {  
                     print "\n"; # Close headers  
             }  
     }  
 }  }
   
 sub html_header($) {  
     my ($title) = @_;  sub html_header($;$)
     my $version = '$Revision$';  {
     http_header();    my ($title, $moddate) = @_;
     print <<EOH;    $title  = htmlquote($title);
 <!doctype html public "-//W3C//DTD HTML 4.0 Transitional//EN"    my $l   = $logo || '';
  "http://www.w3.org/TR/REC-html40/loose.dtd">    my $css = $CSS || '';
     http_header('text/html', $moddate);
     print <<EOH;
   $HTML_DOCTYPE
 <html>  <html>
   <head>
 <title>$title</title>  <title>$title</title>
 <!-- CVSweb $version -->  $HTML_META$css</head>
 </head>  <body>
 $body_tag  $l <h1>$title</h1>
 $logo <h1 align="center">$title</h1>  
 EOH  EOH
 }  }
   
 sub html_footer {  sub html_footer()
     return "<hr noshade><address>$address</address>\n";  {
     print "<hr />\n<address>$address</address>\n" if $address;
     print "</body>\n</html>\n";
 }  }
   
 sub link_tags  sub link_tags($)
 {  {
     my ($tags) = @_;    my ($tags) = @_;
     my ($ret) = "";  
     my ($fileurl,$filename);  
   
     ($filename = $where) =~ s/^.*\///;    (my $filename = $where) =~ s|^.*/||;
     $fileurl = urlencode($filename);    my $fileurl = './' . uri_escape($filename);
   
     foreach my $sym (split(", ", $tags)) {    my $ret = "";
         $ret .= ",\n" if ($ret ne "");    foreach my $sym (split(", ", $tags)) {
         $ret .= "<A HREF=\"$fileurl"      $ret .= ",\n" if ($ret ne "");
                 . toggleQuery('only_with_tag',$sym) . "\">$sym</A>";      $ret .= &link(htmlquote($sym),
     }                    $fileurl . toggleQuery('only_with_tag', $sym));
     return $ret."\n";    }
     return $ret;
 }  }
   
   
 #  #
 # See if a module is listed in the config file's @HideModule list.  # See if a file/dir is listed in the config file's @ForbiddenFiles list.
   # Takes a full file system path or one relative to $cvsroot, and strips the
   # trailing ",v" if present, then compares.  Returns 1 if forbidden, else 0.
 #  #
 sub forbidden_module {  sub forbidden($)
     my($module) = @_;  {
     (my $path = canonpath(shift)) =~ s/,v$//;
     for (my $i=0; $i < @HideModules; $i++) {    $path =~ s|^$cvsroot/+||;
         return 1 if $module eq $HideModules[$i];    for my $forbidden_re (@ForbiddenFiles) {
     }      return 1 if ($path =~ $forbidden_re);
     }
     return 0;
   }
   
     return 0;  
   #
   # Starts a process using IPC::Run.  All arguments are passed to
   # IPC::Run::start() as-is.  Returns an array ($harness, $error) where
   # $harness is from IPC::Run if start() succeeds, undef otherwise.  In case
   # of an error, $error contains the error message.
   #
   sub startproc(@)
   {
     my $h = my $err = undef;
     eval {
       local $SIG{__DIE__};
       $h = IPC::Run::start(@_) or die("return code: $?");
     };
     if ($@) {
       $h->finish() if $h;
       $h = undef;
       $err = "'@{$_[0]}' failed: $@";
     }
     return ($h, $err);
 }  }
   
   #
   # Runs a process using IPC::Run.  All arguments are passed to
   # IPC::Run::run() as-is.  Returns an array ($exitcode, $errormsg).
   #
   sub runproc(@)
   {
     eval {
       local $SIG{__DIE__};
       IPC::Run::run(@_);
     };
     my $exitcode = $? >> 8;
     my $errormsg  = undef;
     if ($@) {
       $exitcode ||= -1;
       $errormsg = "'@{$_[0]}' failed: $@";
     }
     return ($exitcode, $errormsg);
   }
   
   #
   # Check out a file to a temporary file.
   #
   sub checkout_to_temp($$$)
   {
     my ($cvsroot, $cvsname, $rev) = @_;
   
     # Pipe given cvs file into a temporary place.
     my ($temp_fh, $temp_fn) = tempfile('.cvsweb.XXXXXXXX', DIR => tmpdir());
   
     my @cmd = ($CMD{cvs}, @cvs_options, '-Qd', $cvsroot,
                'co', '-p', "-r$rev", $cvsname);
   
     local (*DIFF_OUT);
     my ($h, $err) = startproc(\@cmd, \"", '>pipe', \*DIFF_OUT);
     if ($h) {
       local $/ = undef;
       print $temp_fh <DIFF_OUT>;
       $h->finish();
       close($temp_fh);
     } else {
       close($temp_fh);
       unlink($temp_fn);
       fatal('500 Internal Error',
             'Checkout failure (exit status %s), output: <pre>%s</pre>',
             $? >> 8 || -1, $err);
     }
   
     return $temp_fn;
   }
   
   #
   # Close the GZIP handle, and remove the tie.
   #
   sub gzipclose
   {
     if ($gzip_open) {
       select(STDOUT);
       close(GZIP);
       untie *GZIP;
       $gzip_open = 0;
     }
   }
   
   # implement a gzipped file handle via the Compress:Zlib compression
   # library.
   
   sub MAGIC1() { 0x1f }
   sub MAGIC2() { 0x8b }
   sub OSCODE() { 3 }
   
   sub TIEHANDLE
   {
     my ($class, $out) = @_;
     my ($d) = Compress::Zlib::deflateInit(
       -Level      => Compress::Zlib::Z_BEST_COMPRESSION(),
       -WindowBits => -Compress::Zlib::MAX_WBITS()
       )
       or return undef;
     my ($o) = { handle => $out,
                 dh     => $d,
                 crc    => 0,
                 len    => 0,
               };
     my ($header) = pack("c10",
                         MAGIC1, MAGIC2, Compress::Zlib::Z_DEFLATED(),
                         0, 0, 0, 0, 0, 0, OSCODE);
     print {$o->{handle}} $header;
     return bless($o, $class);
   }
   
   sub PRINT
   {
     my ($o)   = shift;
     my ($buf) = join (defined($,) ? $, : "", @_);
     my ($len) = length($buf);
     my ($compressed, $status) = $o->{dh}->deflate($buf);
     print {$o->{handle}} $compressed if defined($compressed);
     $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});
     $o->{len} += $len;
     return $len;
   }
   
   sub PRINTF
   {
     my ($o)   = shift;
     my ($fmt) = shift;
     my ($buf) = sprintf($fmt, @_);
     my ($len) = length($buf);
     my ($compressed, $status) = $o->{dh}->deflate($buf);
     print {$o->{handle}} $compressed if defined($compressed);
     $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});
     $o->{len} += $len;
     return $len;
   }
   
   sub WRITE
   {
     my ($o, $buf, $len, $off) = @_;
     my ($compressed, $status) = $o->{dh}->deflate(substr($buf, 0, $len));
     print {$o->{handle}} $compressed if defined($compressed);
     $o->{crc} = Compress::Zlib::crc32(substr($buf, 0, $len), $o->{crc});
     $o->{len} += $len;
     return $len;
   }
   
   sub CLOSE
   {
     my ($o) = @_;
     return if !defined($o->{dh});
     my ($buf) = $o->{dh}->flush();
     $buf .= pack("V V", $o->{crc}, $o->{len});
     print {$o->{handle}} $buf;
     undef $o->{dh};
   }
   
   sub DESTROY
   {
     my ($o) = @_;
     CLOSE($o);
   }
   
   # Local variables:
   # indent-tabs-mode: nil
   # cperl-indent-level: 2
   # End:

Legend:
Removed from v.3.3  
changed lines
  Added in v.4.10

CVSweb