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

Diff for /cvsweb/cvsweb.cgi between version 1.1.1.32 and 4.40

version 1.1.1.32, 2002/07/07 04:31:41 version 4.40, 2019/11/30 13:08:41
Line 1 
Line 1 
 #!/usr/bin/perl -wT  #!/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>  #             Jens-Uwe Mager       <jum@helios.de>
 #             Ville Skyttä     <scop@FreeBSD.org>  #             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:
Line 20 
Line 23 
 #           (c) 1998-1999 Henner Zeller  #           (c) 1998-1999 Henner Zeller
 #           (c) 1999      Henrik Nordstrom  #           (c) 1999      Henrik Nordstrom
 #           (c) 2000-2002 Akinori MUSHA  #           (c) 2000-2002 Akinori MUSHA
 #           (c) 2002      Ville Skyttä  #           (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 43 
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.
 #  
 # $FreeBSD: projects/cvsweb/cvsweb.cgi,v 1.112 2002/07/06 18:15:19 scop Exp $  
 # $zId: cvsweb.cgi,v 1.112 2001/07/24 13:03:16 hzeller Exp $  
 # $Idaemons: /home/cvs/cvsweb/cvsweb.cgi,v 1.84 2001/10/07 20:50:10 knu Exp $  
 #  
 ###  
   
 require 5.000;  require 5.006;
   
 use strict;  use strict;
   use warnings;
   use filetest qw(access);
   
 use vars qw (  use vars qw (
     $cvsweb_revision    $VERSION $CheckoutMagic $MimeTypes $DEBUG
     $mydir $uname $config $allow_version_select $verbose    @CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr %DEFAULTVALUE %MTYPES
     @CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr    @DIFFTYPES %DIFFTYPES @LOGSORTKEYS %LOGSORTKEYS
     %MIRRORS %DEFAULTVALUE %ICONS %MTYPES    %alltags %fileinfo %tags @branchnames %nameprinted
     @DIFFTYPES %DIFFTYPES @LOGSORTKEYS %LOGSORTKEYS    %symrev %revsym @allrevisions %date %author @revdisplayorder
     %alltags @tabcolors %fileinfo %tags @branchnames %nameprinted    @revisions %state %difflines %log %branchpoint @revorder $keywordsubstitution
     %symrev %revsym @allrevisions %date %author @revdisplayorder    $mancgi $doCheckout $scriptname $scriptwhere
     @revisions %state %difflines %log %branchpoint @revorder    $where $Browser $nofilelinks $maycompress @stickyvars
     $prcgi @prcategories $re_prcategories $prkeyword $re_prkeyword $mancgi    $is_links $is_lynx $is_w3m $is_msie $is_mozilla3 $is_textbased
     $checkoutMagic $doCheckout $scriptname $scriptwhere    %input $query $barequery $sortby $bydate $byrev $byauthor
     $where $pathinfo $Browser $nofilelinks $maycompress    $bylog $byfile $defaultDiffType $logsort $cvstree $cvsroot
     @stickyvars @unsafevars    %CMD $allow_compress $backicon $diricon $fileicon
     %funcline_regexp $is_mod_perl    $fullname $logo $defaulttitle $address $binfileicon $iconsdir
     $is_links $is_lynx $is_w3m $is_msie $is_mozilla3 $is_textbased    $shortLogLen $show_author $hr_breakable $hr_ignwhite $hr_ignkeysubst
     %input $query $barequery $sortby $bydate $byrev $byauthor    $mime_types $allow_annotate $allow_markup $allow_mailtos
     $bylog $byfile $defaultDiffType $logsort $cvstree $cvsroot    $allow_log_extra $allow_dir_extra $allow_source_extra
     $mimetype $charset $output_filter $defaultTextPlain $defaultViewable    $edit_option_form
     $command_path %CMD $allow_compress    $show_subdir_lastmod $show_log_in_markup $preformat_in_markup
     $backicon $diricon $fileicon    $tabstop $state $annTable $sel @ForbiddenFiles
     $fullname $newname $cvstreedefault    $use_descriptions %descriptions $dwhere
     $body_tag $body_tag_for_src $logo $defaulttitle $address    $use_moddate $gzip_open $file_list_len
     $long_intro $short_instruction $shortLogLen    $allow_tar @tar_options @cvs_options
     $show_author $dirtable $tablepadding $columnHeaderColorDefault    @annotate_options @rcsdiff_options
     $columnHeaderColorSorted $hr_breakable $showfunc $hr_ignwhite    $HTML_DOCTYPE $HTML_META $cssurl $CSS
     $hr_ignkeysubst $diffcolorHeading $diffcolorEmpty $diffcolorRemove  
     $diffcolorChange $diffcolorAdd $diffcolorDarkChange $difffontface  
     $difffontsize $inputTextSize $mime_types  
     $allow_annotate $allow_markup  
     $allow_log_extra $allow_dir_extra $allow_source_extra  
     $use_java_script $open_extern_window  
     $extern_window_width $extern_window_height $edit_option_form  
     $show_subdir_lastmod $show_log_in_markup $preformat_in_markup $v  
     $navigationHeaderColor $tableBorderColor $markupLogColor  
     $tabstop $state $annTable $sel $curbranch @HideModules @ForbiddenFiles  
     $module $use_descriptions %descriptions @mytz $dwhere $moddate  
     $use_moddate $has_zlib $gzip_open  
     $allow_tar @tar_options @gzip_options @zip_options @cvs_options  
     $LOG_FILESEPARATOR $LOG_REVSEPARATOR  
     $tmpdir $HTML_DOCTYPE $HTML_META  
 );  );
   
 sub printDiffSelect($);  require Compress::Zlib;
 sub printDiffLinks($$);  use Cwd                   qw(abs_path);
 sub printLogSortSelect($);  use File::Path            qw(rmtree);
   use File::Spec::Functions qw(canonpath catdir catfile curdir devnull rootdir
                                tmpdir updir);
   use File::Temp            qw(tempdir);
   use IPC::Run              qw();
   use Time::Local           qw(timegm);
   use URI::Escape           qw(uri_escape uri_unescape);
   
   use constant VALID_PATH   => qr/^([[:^cntrl:]]+)$/o;
   use constant VALID_TAG1   => qr/^([a-zA-Z][[:graph:]]*)$/o;
   use constant VALID_TAG2   => qr/^([^\$,.:;@]+)$/o;
   use constant CVSWEBMARKUP => qr{^text/(x-cvsweb|vnd\.viewcvs)-markup$}io;
   use constant LOG_FILESEPR => qr/^={77}$/o;
   use constant LOG_REVSEPR  => qr/^-{28}$/o;
   
   # -----------------------------------------------------------------------------
   
   # All global initialization that can be done in compile time should go to
   # the BEGIN block.  Persistent environments, such as mod_perl, will benefit
   # from this.
   
   BEGIN
   {
     $VERSION = '3.1';
   
     $HTML_DOCTYPE =
       '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" ' .
       '"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">';
   
     $HTML_META = <<EOM;
   <meta name="robots" content="nofollow" />
   <meta name="generator" content="CVSweb $VERSION" />
   <meta http-equiv="Content-Style-Type" content="text/css" />
   EOM
   
     # Use MIME::Types for MIME type lookups if it's available.
     eval {
       require MIME::Types;
       $MimeTypes = MIME::Types->new(only_complete => 1);
     };
     $MimeTypes = undef if $@;
   
     $CheckoutMagic = '~checkout~';
   }
   
   # -----------------------------------------------------------------------------
   
   sub printDiffSelect();
   sub printDiffSelectStickyVars();
   sub getDiffLinks($$$);
   sub printLogSortSelect();
 sub findLastModifiedSubdirs(@);  sub findLastModifiedSubdirs(@);
 sub htmlify_sub(&$);  sub htmlify_sub(&$);
 sub htmlify($;$);  sub htmlify($;$);
Line 106  sub spacedHtmlText($;$);
Line 140  sub spacedHtmlText($;$);
 sub link($$);  sub link($$);
 sub revcmp($$);  sub revcmp($$);
 sub fatal($$@);  sub fatal($$@);
 sub redirect($);  sub redirect($;$);
 sub safeglob($);  sub safeglob($);
 sub search_path($);  sub search_path($);
 sub getMimeTypeFromSuffix($);  sub getMimeType($;$);
 sub head($;$);  sub head($;$);
 sub scan_directives(@);  sub scan_directives(@);
 sub openOutputFilter();  
 sub doAnnotate($$);  sub doAnnotate($$);
 sub doCheckout($$);  sub doCheckout($$$);
 sub cvswebMarkup($$$);  sub cvswebMarkup($$$$$$;$);
 sub viewable($);  sub viewable($);
 sub doDiff($$$$$$);  sub doDiff($$$$$$);
 sub getDirLogs($$@);  sub getDirLogs($$@);
 sub readLog($;$);  sub readLog($;$);
 sub printLog($;$);  sub printLog($$$;$$);
 sub doLog($);  sub doLog($);
 sub flush_diff_rows($$$$);  sub flush_diff_rows($$$$);
 sub human_readable_diff($);  sub human_readable_diff($$);
 sub navigateHeader($$$$$);  sub navigateHeader($$$$$;$);
 sub plural_write($$);  sub plural_write($$);
 sub readableTime($$);  sub readableTime($$);
 sub clickablePath($$);  sub clickablePath($$);
 sub chooseCVSRoot();  sub chooseCVSRoot();
 sub chooseMirror();  
 sub fileSortCmp();  sub fileSortCmp();
 sub download_url($$;$);  sub download_url($$;$);
 sub download_link($$$;$);  sub download_link($$$;$);
 sub toggleQuery($$);  sub display_url($$;$);
 sub urlencode($);  sub display_link($$;$$);
   sub toggleQuery($;$);
 sub htmlquote($);  sub htmlquote($);
 sub htmlunquote($);  sub htmlunquote($);
 sub hrefquote($);  sub uri_escape_path($);
 sub http_header(;$);  sub http_header(;$$);
 sub html_header($);  sub html_header($;$);
 sub html_footer();  sub html_footer();
 sub link_tags($);  sub link_tags($);
 sub forbidden_file($);  sub forbidden($);
 sub forbidden_module($);  sub startproc(@);
   sub runproc(@);
   
 ##### Start of Configuration Area ########  # Get rid of unsafe environment vars.  Don't do this in the BEGIN block
 delete $ENV{PATH};  # (think mod_perl)...
   delete(@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)});
   
 $cvsweb_revision = '2.0.4';  # Helps to achieve read only access to the repositories
   # with cvs >= 1.12.1 and doesn't hurt other versions.
   $ENV{CVSREADONLYFS} = 1;
   
 use File::Basename ();  ######## configuration defaults #########
   
 ($mydir) = (File::Basename::dirname($0) =~ /(.*)/);    # untaint  %CMD = (
     cvs     => '/usr/bin/cvs',
     rcsdiff => '/usr/bin/rcsdiff',
     rlog    => '/usr/bin/rlog',
     tar     => '/bin/tar',
   );
   
 # == EDIT this ==  %DEFAULTVALUE = (
 # Locations to search for user configuration, in order:    f               => 'u',
 for ("$mydir/cvsweb.conf", '/usr/local/etc/cvsweb/cvsweb.conf') {    hideattic       => 1,
         if (defined($_) && -r $_) {    hidecvsroot     => 0,
                 $config = $_;    hidenonreadable => 1,
                 last;    ignorecase      => 0,
         }    ln              => 0,
 }    logsort         => 'date',
     sortby          => 'file',
   );
   
 # == Configuration defaults ==  @ForbiddenFiles = (
 # Defaults for configuration variables that shouldn't need    qr|^CVSROOT/+passwd$|o, # CVSROOT/passwd should not be 'cvs add'ed though.
 # to be configured..    qr|/\.cvspass$|o,       # Ditto.  Just in case.
 $allow_version_select = 1;  );
   
   %MTYPES = (
     gif  => 'image/gif',
     html => 'text/html',
     jpeg => 'image/jpeg',
     jpg  => 'image/jpeg',
     png  => 'image/png',
   );
   
   $address = 'CVSweb';
   $allow_annotate = 1;
   $allow_compress = 0;
   $allow_dir_extra = 1;
 $allow_log_extra = 1;  $allow_log_extra = 1;
   $allow_mailtos = 1;
   $allow_markup = 1;
   $allow_source_extra = 1;
   $allow_tar = 0;
   @annotate_options = qw(-f -R);
   $cssurl = '/css/cvsweb.css';
   @cvs_options = qw(-f -R);
   @CVSrepositories = ('local', ['Local Repository', '/cvs']);
   $DEBUG = 0;
   $defaulttitle = 'CVS Repository';
   $edit_option_form = 1;
   $file_list_len = 0;
   $hr_breakable = 1;
   $hr_ignkeysubst = 1;
   $hr_ignwhite = 0;
   $iconsdir = '/icons';
   $logo = undef;
   $mancgi = 'https://man.openbsd.org/%s.%s';
   $mime_types = '/conf/mime.types';
   $preformat_in_markup = 0;
   @rcsdiff_options = qw(-q);
   $shortLogLen = 80;
   $show_author = 1;
   $show_log_in_markup = 1;
   $show_subdir_lastmod = 0;
   $tabstop = 8;
   @tar_options = qw();
   $use_descriptions = 0;
   $use_moddate = 1;
   
 ##### End of Configuration Area   ########  ######## load configuration #########
   
 ######## Configuration variables #########  {
 # These are defined to allow checking with perl -cw    my $config = '/conf/cvsweb/cvsweb.conf';
 @CVSrepositories = @CVSROOT = %CVSROOT = %MIRRORS = %DEFAULTVALUE = %ICONS =    last unless -e $config;
     %MTYPES = %tags = %alltags = @tabcolors = %fileinfo = ();    defined do $config and last;
 $cvstreedefault = $body_tag = $body_tag_for_src = $logo = $defaulttitle =    $@ and fatal '500 Internal Error',
     $address = $long_intro = $short_instruction = $shortLogLen = $show_author =      'Error loading configuration file "<code>%s</code>": <pre>%s</pre>',
     $dirtable = $tablepadding = $columnHeaderColorDefault =      $config, $@;
     $columnHeaderColorSorted = $hr_breakable = $showfunc = $hr_ignwhite =    fatal '500 Internal Error',
     $hr_ignkeysubst = $diffcolorHeading = $diffcolorEmpty = $diffcolorRemove =      'Cannot read configuration file "<code>%s</code>": %s',
     $diffcolorChange = $diffcolorAdd  = $diffcolorDarkChange = $difffontface   =      $config, $! || 'unknown error';
     $difffontsize    = $inputTextSize = $mime_types          = $allow_annotate =  }
     $allow_markup        = $use_java_script      = $open_extern_window =  
     $extern_window_width = $extern_window_height = $edit_option_form   =  
     $show_subdir_lastmod = $show_log_in_markup = $v = $navigationHeaderColor =  
     $tableBorderColor = $markupLogColor = $tabstop = $use_moddate = $moddate =  
     $gzip_open = $HTML_DOCTYPE = $HTML_META = undef;  
 $tmpdir = defined($ENV{TMPDIR}) ? $ENV{TMPDIR} : "/var/tmp";  
   
 $LOG_FILESEPARATOR = q/^={77}$/;  ######## other global variables #########
 $LOG_REVSEPARATOR  = q/^-{28}$/;  
   
 @DIFFTYPES = qw(h H u c s);  @DIFFTYPES = qw(h H u c);
 @DIFFTYPES{@DIFFTYPES} = (  @DIFFTYPES{@DIFFTYPES} = (
         {    {
                 'descr'   => 'colored',      'descr'   => 'colored',
                 'opts'    => ['-u'],      'opts'    => ['-u'],
                 'colored' => 1,      'colored' => 1,
         },    },
         {    {
                 'descr'   => 'long colored',      'descr'   => 'long colored',
                 'opts'    => ['--unified=15'],      'opts'    => ['--unified=15'],
                 'colored' => 1,      'colored' => 1,
         },    },
         {    {
                 'descr'   => 'unified',      'descr'   => 'unified',
                 'opts'    => ['-u'],      'opts'    => ['-u'],
                 'colored' => 0,      'colored' => 0,
         },    },
         {    {
                 'descr'   => 'context',      'descr'   => 'context',
                 'opts'    => ['-c'],      'opts'    => ['-c'],
                 'colored' => 0,      'colored' => 0,
         },    },
         {  
                 'descr'   => 'side by side',  
                 'opts'    => ['--side-by-side', '--width=164'],  
                 'colored' => 0,  
         },  
 );  );
   
 @LOGSORTKEYS = qw(cvs date rev);  @LOGSORTKEYS = qw(cvs date rev);
 @LOGSORTKEYS{@LOGSORTKEYS} = (  @LOGSORTKEYS{@LOGSORTKEYS} = (
         {    { descr => 'Not sorted',  },
                 'descr' => 'Not sorted',    { descr => 'Commit date', },
         },    { descr => 'Revision',    },
         {  
                 'descr' => 'Commit date',  
         },  
         {  
                 'descr' => 'Revision',  
         },  
 );  );
   
 $HTML_DOCTYPE =  %alltags = ();
   '<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">';  @CVSROOT = ();
   %CVSROOT = ();
   %CVSROOTdescr = ();
   %fileinfo = ();
   $gzip_open = 0;
   %tags = ();
   
 $HTML_META = <<EOM;  ######## end of global variables #########
 <meta name="robots" content="nofollow">  
 <meta name="generator" content="FreeBSD-CVSweb $cvsweb_revision">  
 <meta http-equiv="Content-Script-Type" content="text/javascript">  
 <meta http-equiv="Content-Style-Type" content="text/css">  
 EOM  
   
 ##### End of configuration variables #####  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});
   }
   
 use Time::Local ();  $scriptname    = '' unless defined($scriptname);
 use IPC::Open2 qw(open2);  
   
 # Check if the zlib C library interface is installed, and if yes  $where         =  $pathinfo;
 # we can avoid using the extra gzip process.  $doCheckout    =  $where =~ s|^/$CheckoutMagic/|/|o;
 eval { require Compress::Zlib; };  $where         =~ s|^/||;
 $has_zlib = !$@;  $scriptname    =~ s|^/+||;
   
 $verbose       = $v;  
 $checkoutMagic = "~checkout~";  
 $pathinfo      = defined($ENV{PATH_INFO}) ? $ENV{PATH_INFO} : '';  
 $where         = $pathinfo;  
 $doCheckout = ($where =~ m|^/$checkoutMagic/|);  
 $where =~ s|^/$checkoutMagic/|/|;  
 $where =~ s|^/||;  
 $scriptname = defined($ENV{SCRIPT_NAME}) ? $ENV{SCRIPT_NAME} : '';  
 $scriptname =~ s|^/*|/|;  
   
 # Let's workaround thttpd's stupidity..  # Let's workaround thttpd's stupidity..
 if ($scriptname =~ m|/$|) {  if ($scriptname =~ m|/$|) {
         $pathinfo .= '/';    $pathinfo .= '/';
         my $re = quotemeta $pathinfo;    my $re = quotemeta $pathinfo;
         $scriptname =~ s/$re$//;    $scriptname =~ s/$re$//;
 }  }
   $scriptname = "/$scriptname" if $scriptname;
   
 $scriptwhere = $scriptname;  # $scriptname : the URI escaped path to this script
 $scriptwhere .= '/' . urlencode($where);  # $where      : the path in the CVS repository (without leading /, or only /)
 $where = '/' if ($where eq '');  # $scriptwhere: the URI escaped $scriptname + '/' + $where
   $scriptname   = uri_escape_path($scriptname);
   $scriptwhere  = join('/', $scriptname, uri_escape_path($where));
   $where        = '/' if ($where eq '');
   
 $is_mod_perl = defined($ENV{MOD_PERL});  # In text-based browsers, it's very annoying to have two links per file;
   # skip linking the image for them.
   
 # in lynx, it it very annoying to have two links  $Browser     = $ENV{HTTP_USER_AGENT} || '';
 # per file, so disable the link at the icon  $is_links    = ($Browser =~ m`^E?Links `);
 # in this case:  
 $Browser = $ENV{HTTP_USER_AGENT} || '';  
 $is_links    = ($Browser =~ m`^Links `);  
 $is_lynx     = ($Browser =~ m`^Lynx/`i);  $is_lynx     = ($Browser =~ m`^Lynx/`i);
 $is_w3m      = ($Browser =~ m`^w3m/`i);  $is_w3m      = ($Browser =~ m`^w3m/`i);
 $is_msie     = ($Browser =~ m`MSIE`);  $is_msie     = ($Browser =~ m`MSIE`);
Line 300  $nofilelinks = $is_textbased;
Line 371  $nofilelinks = $is_textbased;
 # display garbage then :-/  # display garbage then :-/
 # Turn off gzip if running under mod_perl and no zlib is available,  # Turn off gzip if running under mod_perl and no zlib is available,
 # piping does not work as expected inside the server.  # piping does not work as expected inside the server.
 $maycompress =  $maycompress = (
     (((defined($ENV{HTTP_ACCEPT_ENCODING})    ((defined($ENV{HTTP_ACCEPT_ENCODING})
     && $ENV{HTTP_ACCEPT_ENCODING} =~ m`gzip`) || $is_mozilla3) && !$is_msie      && $ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/)
     && !($is_mod_perl && !$has_zlib));     || $is_mozilla3)
     && !$is_msie
     && !(defined($ENV{MOD_PERL}))
   );
   
 # 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 f only_with_tag);  
 @unsafevars = qw(logsort only_with_tag r1 r2 rev sortby tr1 tr2);  
   
 if (-f $config) {  # Try to find a readable dir where we can cd into.  Some abs_path()
         do "$config" or fatal("500 Internal Error",  # implementations as well as various cvs operations require such a dir to
                               'Error in loading configuration file: %s<br><br>%s<br>',  # work properly.
                               $config, $@);  {
 } else {    local $^W = 0;
         fatal("500 Internal Error",    for my $dir (tmpdir(), rootdir()) {
               'Configuration not found.  Set the variable <code>$config</code> in cvsweb.cgi to your <b>cvsweb.conf</b> configuration file first.'      last if (-r $dir && chdir($dir));
              );    }
 }  }
   
 undef %input;  $CSS = $cssurl ?
 $query = $ENV{QUERY_STRING};    sprintf("<link rel=\"stylesheet\" type=\"text/css\" href=\"%s\" />\n",
             htmlquote($cssurl)) : '';
   
 if (defined($query) && $query ne '') {  # --- input parameters
         foreach (split (/&/, $query)) {  
                 y/+/ /;  my %query = ();
                 s/%(..)/sprintf("%c", hex($1))/ge;    # unquote %-quoted  if (defined($ENV{QUERY_STRING})) {
                 if (/(\S+)=(.*)/) {    for my $p (split(/[;&]+/, $ENV{QUERY_STRING})) {
                         $input{$1} = $2 if ($2 ne "");      next unless $p;
                 } else {      $p =~ y/+/ /;
                         $input{$_}++;      my ($key, $val) = split(/=/, $p, 2);
                 }      next unless defined($key);
         }      $key = uri_unescape($key);
       $key =~ /([^a-z_12-])/ and fatal('404 Not Found',
         'Invalid character "%s" in query parameter "%s"', $1, $key);
       if (defined $val) {
         $val = uri_unescape($val);
         $val =~ /([^a-zA-Z_01-9.\/-])/ and fatal('404 Not Found',
           'Invalid character "%s" in the value "%s" of the query parameter "%s"',
           $1, $val, $key);
       } else {
         $val = 1;
       }
       $query{$key} = $val;
     }
 }  }
   
 # For backwards compability, set only_with_tag to only_on_branch if set.  undef %input;
 $input{only_with_tag} = $input{only_on_branch}  
     if (defined($input{only_on_branch}));  
   
 # Prevent cross-site scripting  my $t;
 foreach (@unsafevars) {  for my $p (qw(hideattic hidecvsroot hidenonreadable ignorecase ln copt
         if (defined($input{$_}) && $input{$_} =~ /[^\w\-.]/) {                options tarball)) {
                 fatal("500 Internal Error",    $t = $query{$p};
                       'Malformed query (%s=%s)',    if (defined($t)) {
                       $_, $input{$_});      ($input{$p}) = ($t =~ /^([01]|on)$/)
         }        or fatal('500 Internal Error',
                  '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);
   
 if (defined($input{"content-type"})) {  # --- end input parameters
         fatal("500 Internal Error", "Unsupported content-type")  
             if ($input{"content-type"} !~ /^[-0-9A-Za-z]+\/[-0-9A-Za-z]+$/);  #
   # 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;
     $CVSROOTdescr{$key} = $descr;
     $CVSROOT{$key} = $root;
     push(@CVSROOT, $key);
 }  }
   unless ($rootfound) {
     fatal('500 Internal Error', 'no valid CVS roots found');
   }
   undef $rootfound;
   
 $DEFAULTVALUE{'cvsroot'} = $cvstreedefault;  $DEFAULTVALUE{cvsroot} = $CVSrepositories[0];
   
 foreach (keys %DEFAULTVALUE) {  while (my ($key, $defval) = each %DEFAULTVALUE) {
   
         # replace not given parameters with the default parameters    # Replace not given parameters with defaults.
         if (!defined($input{$_}) || $input{$_} eq "") {    next unless (defined($defval) && $defval =~ /\S/ && !defined($input{$key}));
   
                 # Empty Checkboxes in forms return -- nothing. So we define a helper    # Empty checkboxes in forms return nothing, so we define a helper parameter
                 # variable in these forms (copt) which indicates that we just set    # in these forms (copt) which indicates that we just set parameters with a
                 # parameters with a checkbox    # checkbox.
                 if (!defined($input{"copt"})) {    if ($input{copt}) {
   
                         # 'copt' isn't defined --> empty input is not the result      # 'copt' is set -> the result of empty input checkbox
                         # of empty input checkbox --> set default      # -> set to zero (disable) if default is a boolean (0|1).
                         $input{$_} = $DEFAULTVALUE{$_}      $input{$key} = 0 if ($defval eq '0' || $defval eq '1');
                             if (defined($DEFAULTVALUE{$_}));  
                 } else {  
   
                         # 'copt' is defined -> the result of empty input checkbox    } else {
                         # -> set to zero (disable) if default is a boolean (0|1).  
                         $input{$_} = 0      # 'copt' isn't set --> empty input is not the result
                             if (defined($DEFAULTVALUE{$_})      # of empty input checkbox --> set default.
                             && ($DEFAULTVALUE{$_} eq "0"      $input{$key} = $defval;
                             || $DEFAULTVALUE{$_} eq "1"));    }
                 }  
         }  
 }  }
   
 $barequery = "";  $barequery = "";
 my @barequery;  my @barequery;
 foreach (@stickyvars) {  foreach (@stickyvars) {
   
         # construct a query string with the sticky non default parameters set    # construct a query string with the sticky non default parameters set
         if (defined($input{$_}) && $input{$_} ne ''    if (defined($input{$_})
             && !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_}))        && !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_}))
         {    {
                 push @barequery,      push(@barequery, join('=', uri_escape($_), uri_escape($input{$_})));
                     join ('=', urlencode($_), urlencode($input{$_}));    }
         }  
 }  }
   
 # is there any query ?  # is there any query ?
 if (@barequery) {  if (@barequery) {
         $barequery = join ('&', @barequery);    $barequery = join (';', @barequery);
         $query     = "?$barequery";    $query     = "?$barequery";
         $barequery = "&$barequery";    $barequery = ";$barequery";
 } else {  } else {
         $query = "";    $query = "";
 }  }
 undef @barequery;  undef @barequery;
   
 if (defined($input{path})) {  if (defined($input{path})) {
         redirect("$scriptname/$input{path}$query");    redirect("$scriptname/$input{path}$query");
 }  }
   
 # get actual parameters  # get actual parameters
 $sortby   = $input{"sortby"};  
 $bydate   = 0;  
 $byrev    = 0;  
 $byauthor = 0;  
 $bylog    = 0;  
 $byfile   = 0;  
 if ($sortby eq "date") {  
         $bydate = 1;  
 } elsif ($sortby eq "rev") {  
         $byrev = 1;  
 } elsif ($sortby eq "author") {  
         $byauthor = 1;  
 } elsif ($sortby eq "log") {  
         $bylog = 1;  
 } else {  
         $byfile = 1;  
 }  
   
 $defaultDiffType = $input{'f'};  
   
 $logsort = $input{'logsort'};  
   
 {  {
         my @tmp = @CVSrepositories;    my $sortby = $input{sortby} || 'file';
         my @pair;    $bydate    = 0;
     $byrev     = 0;
         while (@pair = splice(@tmp, 0, 2)) {    $byauthor  = 0;
                 my ($key,   $val)     = @pair;    $bylog     = 0;
                 my ($descr, $cvsroot) = @$val;    $byfile    = 0;
     if ($sortby eq 'date') {
                 next if !-d $cvsroot;      $bydate = 1;
     } elsif ($sortby eq 'rev') {
                 $CVSROOTdescr{$key} = $descr;      $byrev = 1;
                 $CVSROOT{$key}      = $cvsroot;    } elsif ($sortby eq 'author') {
                 push @CVSROOT, $key;      $byauthor = 1;
         }    } elsif ($sortby eq 'log') {
       $bylog = 1;
     } else {
       $byfile = 1;
     }
 }  }
   
 ## Default CVS-Tree  $defaultDiffType = $input{f};
 if (!defined($CVSROOT{$cvstreedefault})) {  
         fatal("500 Internal Error",  
               '<code>$cvstreedefault</code> points to a repository (%s) not defined in <code>%%CVSROOT</code> (edit your configuration file %s)',  
               $cvstreedefault, $config);  
 }  
   
   $logsort = $input{logsort};
   
 # 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 = $CVSrepositories[0];
 }  }
   
 $cvsroot = $CVSROOT{$cvstree};  $cvsroot = $CVSROOT{$cvstree};
   
 # create icons out of description  if ($iconsdir) {
 my $k;    $backicon = '<img src="' . $iconsdir . '/back.gif" alt="[BACK]"' .
 foreach $k (keys %ICONS) {      ' border="0" width="20" height="22"/>';
         no strict 'refs';    $diricon = '<img src="' . $iconsdir . '/dir.gif" alt="[DIR]"' .
         my ($itxt, $ipath, $iwidth, $iheight) = @{$ICONS{$k}};      ' border="0" width="20" height="22"/>';
         if ($ipath) {    $fileicon = '<img src="' . $iconsdir . '/text.gif" alt="[TXT]"' .
                 ${"${k}icon"} =      ' border="0" width="20" height="22"/>';
                     sprintf(    $binfileicon = '<img src="' . $iconsdir . '/binary.gif" alt="[BIN]"' .
                         '<img src="%s" alt="%s" border="0" width="%d" height="%d">',      ' border="0" width="20" height="22"/>';
                         hrefquote($ipath), htmlquote($itxt), $iwidth, $iheight)  } else {
         } else {    $backicon = 'back';
                 ${"${k}icon"} = $itxt;    $diricon = 'dir';
         }    $fileicon = 'file';
     $binfileicon = 'binfile';
 }  }
 undef $k;  
   
 my $config_cvstree = "$config-$cvstree";  $fullname         = catfile($cvsroot, $where);
   
 # Do some special configuration for cvstrees  
 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;  
   
 $re_prcategories = '(?:' . join ('|', @prcategories) . ')' if @prcategories;  
 $re_prkeyword = quotemeta($prkeyword) if defined($prkeyword);  
 $prcgi .= '%s' if defined($prcgi) && $prcgi !~ /%s/;  
   
 $fullname         = "$cvsroot/$where";  
 $mimetype         = &getMimeTypeFromSuffix($fullname);  
 $defaultTextPlain = ($mimetype eq "text/plain");  
 $defaultViewable  = $allow_markup && viewable($mimetype);  
   
 my $rewrite = 0;  my $rewrite = 0;
   
 if ($pathinfo =~ m|//|) {  if ($pathinfo =~ m|//|) {
         $pathinfo =~ y|/|/|s;    $pathinfo =~ y|/|/|s;
         $rewrite = 1;    $rewrite = 1;
 }  }
   if (-d $fullname) {
 if (-d $fullname && $pathinfo !~ m|/$|) {    if ($pathinfo !~ m|/$|) {
         $pathinfo .= '/';      $pathinfo .= '/';
         $rewrite = 1;      $rewrite   = 1;
     }
   } elsif ($pathinfo =~ m|/$|) {
     chop $pathinfo;
     $rewrite = 1;
 }  }
   
 if (!-d $fullname && $pathinfo =~ m|/$|) {  
         chop $pathinfo;  
         $rewrite = 1;  
 }  
   
 if ($rewrite) {  if ($rewrite) {
         redirect($scriptname . urlencode($pathinfo) . $query);    redirect($scriptname . uri_escape_path($pathinfo) . $query, 1);
 }  }
   
 undef $rewrite;  undef $rewrite;
   
   undef $pathinfo;
   
 if (!-d $cvsroot) {  if (!-d $cvsroot) {
         fatal("500 Internal Error",    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.');          '$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 %s forbidden.',  
               $where);  
 }  
   
 #  #
 # Handle tarball downloads before any headers are output.  # Handle tarball downloads before any headers are output.
 #  #
 if ($input{tarball}) {  if ($input{tarball}) {
         fatal("403 Forbidden",    fatal('403 Forbidden', 'Downloading tarballs is prohibited.')
               'Downloading tarballs is prohibited.')      unless $allow_tar;
             unless $allow_tar;  
         my ($module) = ($where =~ m,^/?(.*),);    # untaint  
         $module =~ s,/([^/]*)$,,;  
         my ($ext)     = ($1      =~ /(\.tar\.gz|\.zip)$/);  
         my ($basedir) = ($module =~ m,([^/]+)$,);  
   
         if ($basedir eq '' || $module eq '') {    my ($module)  =  ($where =~ m,^/?(.*),);    # untaint
                 fatal("500 Internal Error",    $module       =~ s,/([^/]*)$,,;
                       'You cannot download the top level directory.');    my ($ext)     =  ($1 =~ /(\.t(?:ar\.)?gz)$/);
         }    my ($basedir) =  ($module =~ m,([^/]+)$,);
   
         my $tmpexportdir = "$tmpdir/.cvsweb.$$." . int(time);    if ($basedir eq '' || $module eq '') {
       fatal('500 Internal Error',
             'You cannot download the top level directory.');
     }
   
         mkdir($tmpexportdir, 0700)    unless ($ext eq '.tar.gz' || $ext eq '.tgz') {
             or fatal("500 Internal Error",      fatal('404 Not Found', 'Unsupported archive type.');
                      'Unable to make temporary directory: %s',    }
                      $!);  
   
         my @fatal;    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 $tag =    my @fatal;
             (exists $input{only_with_tag} && length $input{only_with_tag}) ?    my $tag = $input{only_with_tag} || 'HEAD';
             $input{only_with_tag} : "HEAD";    $tag = 'HEAD' if ($tag eq 'MAIN');
   
         if ($tag eq 'MAIN') {    my @cmd =
             $tag = 'HEAD';      ($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 ($h, $err) = startproc($CMD{tar}, @tar_options, '-czf', '-',
         $basedir, '>pipe', \*TAR_OUT);
       if ($h) {
         print "Content-Type: application/x-gzip\r\n\r\n";
         local $/ = undef;
         print <TAR_OUT>;
         $h->finish();
       } else {
         @fatal = ('500 Internal Error',
                   'tar failure (exit status %s), output: <pre>%s</pre>',
                   $? >> 8 || -1, $err);
       }
     }
   
         if (system $CMD{cvs}, @cvs_options, '-Qd', $cvsroot, 'export', '-r',    # Clean up.
             $tag, '-d', "$tmpexportdir/$basedir", $module)    chdir("..");
         {    rmtree($tmpexportdir);
                 @fatal = ("500 Internal Error",  
                           'cvs co failure: %s: %s',  
                           $!, $module);  
         } else {  
                 $| = 1;    # Essential to get the buffering right.  
   
                 if ($ext eq '.tar.gz') {    &fatal(@fatal) if @fatal;
                         print "Content-Type: application/x-gzip\r\n\r\n";  
   
                         system    exit;
                             "$CMD{tar} @tar_options -cf - -C $tmpexportdir $basedir | $CMD{gzip} @gzip_options -c"  
                             and @fatal =  
                                 ("500 Internal Error",  
                                  'tar zc failure: %s: %s',  
                              $!, $basedir);  
                 } elsif ($ext eq '.zip' && $CMD{zip}) {  
                         print "Content-Type: application/zip\r\n\r\n";  
   
                         system  
                             "cd $tmpexportdir && $CMD{zip} @zip_options -r - $basedir"  
                             and @fatal =  
                                 ("500 Internal Error",  
                                  'zip failure: %s: %s',  
                                  $!, $basedir);  
                 } else {  
                         @fatal =  
                             ("500 Internal Error",  
                              'unsupported file type');  
                 }  
         }  
   
         system $CMD{rm}, '-rf', $tmpexportdir if -d $tmpexportdir;  
   
         &fatal(@fatal) if @fatal;  
   
         exit;  
 }  }
   
 ##############################  ##############################
 # View a directory  # View a directory
 ###############################  ###############################
 if (-d $fullname) {  if (-d $fullname) {
         my $dh = do { local (*DH); };  
         opendir($dh, $fullname) or fatal("404 Not Found",  
                                          '%s: %s',  
                                          $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);
         } else {    my @subLevelFiles = findLastModifiedSubdirs(@dir) if $show_subdir_lastmod;
                 html_header($where);    my @unreadable = getDirLogs($cvsroot, $where, @subLevelFiles);
                 print $short_instruction;  
         }  
   
         if ($use_descriptions && open(DESC, "<$cvsroot/CVSROOT/descriptions"))    if ($where eq '/') {
         {      html_header($defaulttitle);
                 while (<DESC>) {    } else {
                         chomp;      html_header($where);
                         my ($dir, $description) = /(\S+)\s+(.*)/;      my $html = (-f catfile($fullname, 'README.cvs.html,v') ||
                         $descriptions{$dir} = $description;                  -f catfile($fullname, 'Attic', 'README.cvs.html,v'));
                 }      my $text = (!$html &&
                 close(DESC);                  (-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 "<p><a name=\"dirlist\"></a></p>\n";    if ($use_descriptions &&
         open(DESC, catfile($cvsroot, 'CVSROOT', 'descriptions'))) {
       while (<DESC>) {
         chomp;
         my ($dir, $description) = /(\S+)\s+(.*)/;
         $descriptions{$dir} = $description;
       }
       close(DESC);
     }
   
         # give direct access to dirs    print "<p><a name=\"dirlist\"></a></p>\n";
         if ($where eq '/') {  
                 chooseMirror ();  
                 chooseCVSRoot ();  
         } else {  
                 print "<p>Current directory: <b>", &clickablePath($where, 0),  
                     "</b></p>\n";  
   
                 print "<p>Current tag: <b>", $input{only_with_tag},"</b></p>\n"    # give direct access to dirs
                     if $input{only_with_tag};    if ($where eq '/') {
       chooseCVSRoot();
     } else {
       print '<p>Current directory: <b>', clickablePath($where, 0), '</b>';
       print "</p>\n";
       print "<p>Current tag: <b>", htmlquote($input{only_with_tag}), "</b></p>\n"
         if $input{only_with_tag};
     }
   
         }    print "<hr />\n";
   
         print "<hr noshade>\n";    my $infocols = 1;
   
         # Using <menu> in this manner violates the HTML2.0 spec but    printf(<<EOF, 'Directory index of ' . htmlquote($where));
         # provides the results that I want in most browsers.  Another  <table class="dir" width="100%%" cellspacing="0" cellpadding="2" summary="%s">
         # case of layout spooging up HTML.  <tr>
   EOF
     printf('<th colspan="2"%s>', ($byfile ? ' class="sorted"' : ''));
   
         my $infocols = 0;    if ($byfile) {
         if ($dirtable) {      print 'File';
                 print "<table style=\"border-width: 0";    } else {
                 print "; background-color: $tableBorderColor"      print &link('File',
                     if (defined $tableBorderColor);                  sprintf('./%s#dirlist', toggleQuery('sortby', 'file')));
                 print "\" width=\"100%\" cellspacing=\"1\" cellpadding=\"$tablepadding\">\n";    }
                 $infocols++;    print "</th>\n";
                 printf "<tr>\n<th style=\"text-align: left; background-color: %s\">",  
                     $byfile ? $columnHeaderColorSorted :  
                     $columnHeaderColorDefault;  
   
                 if ($byfile) {    # Do not display the other column headers if we do not have any files
                         print 'File';    # with revision information.
                 } else {    if (scalar(%fileinfo)) {
                         print &link(      $infocols++;
                                 'File',      printf('<th%s>', ($byrev ? ' class="sorted"' : ''));
                                 sprintf(  
                                         './%s#dirlist',  
                                         &toggleQuery("sortby", "file")  
                                 )  
                         );  
                 }  
                 print "</th>\n";  
   
                 # do not display the other column-headers, if we do not have any files      if ($byrev) {
                 # with revision information:        print 'Rev.';
                 if (scalar(%fileinfo)) {      } else {
                         $infocols++;        print &link('Rev.',
                         printf '<th style="text-align: left; background-color: %s">',                    sprintf('./%s#dirlist', toggleQuery('sortby', 'rev')));
                             $byrev ? $columnHeaderColorSorted :      }
                             $columnHeaderColorDefault;      print "</th>\n";
       $infocols++;
       printf('<th%s>', ($bydate ? ' class="sorted"' : ''));
   
                         if ($byrev) {      if ($bydate) {
                                 print 'Rev.';        print 'Age';
                         } else {      } else {
                                 print &link(        print &link('Age',
                                         'Rev.',                    sprintf('./%s#dirlist', toggleQuery('sortby', 'date')));
                                         sprintf(      }
                                                 './%s#dirlist',      print "</th>\n";
                                                 &toggleQuery("sortby", "rev")  
                                         )  
                                 );  
                         }  
                         print "</th>\n";  
                         $infocols++;  
                         printf '<th style="text-align: left; background-color: %s">',  
                             $bydate ? $columnHeaderColorSorted :  
                             $columnHeaderColorDefault;  
   
                         if ($bydate) {      if ($show_author) {
                                 print 'Age';        $infocols++;
                         } else {        printf('<th%s>', ($byauthor ? ' class="sorted"' : ''));
                                 print &link(  
                                         'Age',  
                                         sprintf(  
                                                 './%s#dirlist',  
                                                 &toggleQuery("sortby", "date")  
                                         )  
                                 );  
                         }  
                         print "</th>\n";  
   
                         if ($show_author) {        if ($byauthor) {
                                 $infocols++;          print 'Author';
                                 printf '<th style="text-align: left; background-color: %s">',        } else {
                                     $byauthor ? $columnHeaderColorSorted :          print
                                     $columnHeaderColorDefault;            &link('Author',
                   sprintf('./%s#dirlist', toggleQuery('sortby', 'author')));
         }
         print "</th>\n";
       }
       $infocols++;
       printf('<th%s>', ($bylog ? ' class="sorted"' : ''));
   
                                 if ($byauthor) {      if ($bylog) {
                                         print 'Author';        print 'Last log entry';
                                 } else {      } else {
                                         print &link(        print &link('Last log entry',
                                                 'Author',                    sprintf('./%s#dirlist', toggleQuery('sortby', 'log')));
                                                 sprintf(      }
                                                         './%s#dirlist',      print "</th>\n";
                                                         &toggleQuery(    } elsif ($use_descriptions) {
                                                                 "sortby",      print "<th>Description</th>\n";
                                                                 "author"      $infocols++;
                                                         )    }
                                                 )    print "</tr>\n";
                                         );  
                                 }  
                                 print "</th>\n";  
                         }  
                         $infocols++;  
                         printf '<th style="text-align: left; background-color: %s">',  
                             $bylog ? $columnHeaderColorSorted :  
                             $columnHeaderColorDefault;  
   
                         if ($bylog) {    my $dirrow = 0;
                                 print 'Last log entry';  
                         } else {  
                                 print &link(  
                                         'Last log entry',  
                                         sprintf(  
                                                 './%s#dirlist',  
                                                 &toggleQuery("sortby", "log")  
                                         )  
                                 );  
                         }  
                         print "</th>\n";  
                 } elsif ($use_descriptions) {  
                         printf '<th style="text-align: left; background-color: s">',  
                             $columnHeaderColorDefault;  
                         print "Description</th>\n";  
                         $infocols++;  
                 }  
                 print "</tr>\n";  
         } else {  
                 print "<menu>\n";  
         }  
         my $dirrow = 0;  
   
         my $i;    my $i;
         lookingforattic:    lookingforattic:
         for ($i = 0 ; $i <= $#dir ; $i++) {    for ($i = 0; $i <= $#dir; $i++) {
                 if ($dir[$i] eq "Attic") {      if ($dir[$i] eq "Attic") {
                         last lookingforattic;        last lookingforattic;
                 }      }
         }    }
   
         if (!$input{'hideattic'} && ($i <= $#dir)    if (!$input{hideattic}
             && opendir($dh, $fullname . "/Attic"))        && ($i <= $#dir)
         {        && opendir($dh, $fullname . '/Attic'))
                 splice(@dir, $i, 1, grep((s|^|Attic/|, !m|/\.|), readdir($dh)));    {
                 closedir($dh);      splice(@dir, $i, 1, grep((s|^|Attic/|, !m|/\.|), readdir($dh)));
         }      closedir($dh);
     }
   
         my $hideAtticToggleLink =    my $hideAtticToggleLink =
             $input{'hideattic'} ? '' :      $input{hideattic}
             &link('[Hide]', sprintf('./%s#dirlist', &toggleQuery("hideattic")));      ? ''
       : &link('[hide]', sprintf('./%s#dirlist', &toggleQuery('hideattic')));
   
         # Sort without the Attic/ pathname.    # Sort without the Attic/ pathname.
         # place directories first    # place directories first
   
         my $attic;    my $filesexists;
         my $url;    my $filesfound;
         my $fileurl;  
         my $filesexists;  
         my $filesfound;  
   
         foreach (sort { &fileSortCmp } @dir) {    foreach my $file (sort { &fileSortCmp } @dir) {
                 if ($_ eq '.') {  
                         next;  
                 }  
   
                 # ignore CVS lock and stale NFS files      next if ($file eq curdir());
                 next if (/^#cvs\.|^,|^\.nfs/);  
   
                 # Check whether to show the CVSROOT path      # ignore CVS lock and stale NFS files
                 next if ($input{'hidecvsroot'} && ($_ eq 'CVSROOT'));      next if ($file =~ /^\#cvs\.|^,|^\.nfs/); # \# for XEmacs cperl-mode...
   
                 # Check whether the module is in the restricted list      # Check whether to show the CVSROOT path
                 next if ($_ && &forbidden_module($_));      next if ($input{hidecvsroot} && $where eq '/' && $file eq 'CVSROOT');
   
                 # Ignore non-readable files      # Is it a directory?
                 next if ($input{'hidenonreadable'} && !(-r "$fullname/$_"));      my $isdir = -d catdir($fullname, $file);
   
                 if (s|^Attic/||) {      # Ignore non-readable files and directories?
                         $attic = " (in the Attic)&nbsp;" . $hideAtticToggleLink;      next if ($input{hidenonreadable} && (! -r _ || ($isdir && ! -x _)));
                 } else {  
                         $attic = "";  
                 }  
   
                 if ($_ eq '..' || -d "$fullname/$_") {      my $attic = '';
                         next if ($_ eq '..' && $where eq '/');      if ($file =~ s|^Attic/||) {
                         my ($rev, $date, $log, $author, $filename);        $attic = ' <span class="attic">(in the Attic) ' .
                         ($rev, $date, $log, $author, $filename) =          $hideAtticToggleLink . '</span>';
                             @{$fileinfo{$_}}      }
                             if (defined($fileinfo{$_}));  
                         printf "<tr style=\"background-color: %s\">\n<td>",  
                              $tabcolors[$dirrow % 2] if $dirtable;  
   
                         if ($_ eq '..') {      if ($file eq updir() || $isdir) {
                                 $url = "../$query";        next if ($file eq updir() && $where eq '/');
                                 if ($nofilelinks) {        my ($rev, $date, $log, $author, $filename, $keywordsubst) =
                                         print $backicon;          @{$fileinfo{$file}} if (defined($fileinfo{$file}));
                                 } else {        printf "<tr class=\"%s\">\n<td class=\"dir\" colspan=\"2\">",
                                         print &link($backicon, $url);          ($dirrow % 2) ? 'even' : 'odd';
                                 }  
                                 print '&nbsp;', &link("Parent Directory", $url);  
                         } else {  
                                 $url = './' . urlencode($_) . "/$query";  
                                 print "<a name=\"$_\"></a>";  
   
                                 if ($nofilelinks) {        if ($file eq updir()) {
                                         print $diricon;          my $url = "../$query";
                                 } else {          print $nofilelinks ? $backicon : &link($backicon, $url);
                                         print &link($diricon, $url);          print '&nbsp;', &link("Parent Directory", $url);
                                 }  
                                 print '&nbsp;', &link("$_/", $url), $attic;  
   
                                 if ($_ eq "Attic") {        } else {
                                         print "&nbsp; ";          my $url = './' . uri_escape_path($file) . "/$query";
                                         print &link(          print '<a name="', htmlquote($file), '"></a>';
                                                 "[Don't hide]",          print $nofilelinks ? $diricon : &link($diricon, $url);
                                                 sprintf(          print '&nbsp;', &link(htmlquote("$file/"), $url), $attic;
                                                         './%s#dirlist',          if ($file eq "Attic") {
                                                         &toggleQuery(            print ' <span class="attic">',
                                                                 "hideattic")              &link('[show]',
                                                 )                    sprintf('./%s#dirlist', &toggleQuery('hideattic'))),
                                         );                      '</span>';
                                 }          }
                         }        }
   
                         # Show last change in dir        # Show last change in dir
                         if ($filename) {        if ($filename) {
                                 print "</td>\n<td>&nbsp;</td>\n<td>&nbsp;"          my $ageclass = 'age';
                                     if ($dirtable);          my $age      = '';
                                 if ($date) {          if ($date) {
                                         print " <i>",            $age       = readableTime(time() - $date, 0);
                                             readableTime(time() - $date, 0),            $ageclass .= " $1" if ($age =~ /^\d+ ([a-z]+)/);
                                             "</i>";          }
                                 }          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);
           }
   
                                 if ($show_author) {        } else {
                                         print "</td>\n<td>&nbsp;" if ($dirtable);          my $dwhere = ($where ne '/' ? $where : '') . $file;
                                         print $author;  
                                 }  
                                 print "</td>\n<td>&nbsp;" if ($dirtable);  
                                 $filename =~ s%^[^/]+/%%;  
                                 print "$filename/$rev";  
                                 print "<br>" if ($dirtable);  
   
                                 if ($log) {          if ($use_descriptions && defined $descriptions{$dwhere}) {
                                         print "&nbsp;<span style=\"font-size: smaller\">",            print '<td colspan="', ($infocols - 1), '">';
                                           &htmlify(            print $descriptions{$dwhere};
                                                 substr($log, 0, $shortLogLen), $allow_dir_extra);  
                                         if (length $log > 80) {  
                                                 print "...";  
                                         }  
                                         print "</span>";  
                                 }  
                         } else {  
                                 my ($dwhere) =  
                                     ($where ne "/" ? $where : "") . $_;  
   
                                 if ($use_descriptions          } elsif ($infocols > 1) {
                                     && 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            # close the row with the appropriate number of
                                         # columns, so that the vertical seperators are visible            # columns, so that the vertical seperators are visible
                                         my ($cols) = $infocols;            my ($cols) = $infocols;
                                         while ($cols > 1) {            while ($cols > 1) {
                                                 print "</td>\n<td>&nbsp;";              print "</td>\n<td>&nbsp;";
                                                 $cols--;              $cols--;
                                         }            }
                                 }          }
                         }        }
   
                         if ($dirtable) {        print "</td>\n</tr>\n";
                                 print "</td>\n</tr>\n";        $dirrow++;
                         } 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++;  
                         printf "<tr style=\"background-color: %s\">\n<td>",  
                             $tabcolors[$dirrow % 2] if $dirtable;  
                         print "<a name=\"$_\"></a>";  
   
                         if ($nofilelinks) {      } elsif ($file =~ s/,v$//) {
                                 print $fileicon;  
                         } else {  
                                 print &link($fileicon, $url);  
                         }  
                         print '&nbsp;', &link($_, $url), $attic;  
                         print "</td>\n<td>&nbsp;" if ($dirtable);  
                         download_link($fileurl, $rev, $rev,  
                                 $defaultViewable ? "text/x-cvsweb-markup" :  
                                 undef);  
                         print "</td>\n<td>&nbsp;" if ($dirtable);  
   
                         if ($date) {        my $fileurl = ($attic ? 'Attic/' : '') . uri_escape_path($file);
                                 print " <i>", readableTime(time() - $date, 0),        my $url     = './' . $fileurl . $query;
                                     "</i>";        $filesexists++;
                         }        next if (!defined($fileinfo{$file}));
                         if ($show_author) {        my ($rev, $date, $log, $author, $filename, $keywordsubst) =
                                 print "</td>\n<td>&nbsp;" if ($dirtable);          @{$fileinfo{$file}};
                                 print $author;        my $isbinary = $keywordsubst eq 'b' ? 1 : 0;
                         }        $filesfound++;
                         print "</td>\n<td>&nbsp;" if ($dirtable);  
   
                         if ($log) {        printf "<tr class=\"%s\">\n", ($dirrow % 2) ? 'even' : 'odd';
                                 print " <span style=\"font-size: smaller\">",        printf '<td class="file" colspan="2">';
                                     &htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra);  
                                 if (length $log > 80) {  
                                         print "...";  
                                 }  
                                 print "</span>";  
                         }  
                         print "</td>\n" if ($dirtable);  
                         print(($dirtable) ? "</tr>" : "<br>");  
                         $dirrow++;  
                 }  
                 print "\n";  
         }  
   
         print($dirtable ? "</table>\n" : "</menu>\n");        my $icon = $isbinary ? $binfileicon : $fileicon;
         print $nofilelinks ? $icon : &link($icon, $url);
         print '&nbsp;', &link(htmlquote($file), $url), $attic;
         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 ($filesexists && !$filesfound) {        if ($log) {
                 print          print htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra);
                     "<p><b>NOTE:</b> There are $filesexists files, but none matches the current tag ($input{only_with_tag}).</p>\n";          print '...' if (length $log > 80);
         }        }
         if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}}))        print "</td>\n</tr>";
         {        $dirrow++;
                 %tags = %alltags      }
         }      print "\n";
     }
   
         if (scalar %tags || $input{only_with_tag} || $edit_option_form    print "</table>\n";
             || defined($input{"options"}))  
         {  
                 print "<hr size=\"1\" noshade>\n";  
         }  
   
         if (scalar %tags || $input{only_with_tag}) {    if ((my $num = scalar(@unreadable)) && ! $input{hidenonreadable}) {
                 print "<form method=\"get\" action=\"./\">\n";      printf(<<EOF, $num, htmlquote(join(', ', @unreadable)));
                 foreach my $var (@stickyvars) {  <p>
                         print   <b>NOTE:</b> The following %d unreadable files were ignored:<br />
                             "<input type=\"hidden\" name=\"$var\" value=\"$input{$var}\">\n"   <em>%s</em>
                             if (defined($input{$var})  </p>
                             && (!defined($DEFAULTVALUE{$var})  EOF
                             || $input{$var} ne $DEFAULTVALUE{$var})    }
                             && $input{$var} ne "" && $var ne "only_with_tag");  
                 }  
                 print "<p><label for=\"only_with_tag\" accesskey=\"T\">";  
                 print "Show only files with tag:</label>\n";  
                 print "<select id=\"only_with_tag\" name=\"only_with_tag\"";  
                 print " onchange=\"this.form.submit()\"" if $use_java_script;  
                 print ">";  
                 print "<option value=\"\">All tags / default branch</option>\n";  
   
                 foreach my $tag (reverse sort { lc $a cmp lc $b } keys %tags) {    if ($filesexists && !$filesfound) {
                         print "<option",      my $currtag = defined($input{only_with_tag}) ?
                             defined($input{only_with_tag})        sprintf(' (%s)', htmlquote($input{only_with_tag})) : '';
                             && $input{only_with_tag} eq $tag ? " selected" : "",      printf(<<EOF, $filesexists, $currtag);
                             ">$tag</option>\n";  <p>
                 }   <b>NOTE:</b> There are %d files, but none matches the current tag%s.
                 print "</select>\n";  </p>
                 print " <label for=\"path\" accesskey=\"P\">";  EOF
                 print "Module path or alias:</label>\n";    }
                 printf "<input type=\"text\" id=\"path\" name=\"path\" value=\"%s\" size=\"15\">\n",  
                     htmlquote($where);  
                 print "<input type=\"submit\" value=\"Go\" accesskey=\"G\"></p>\n";  
                 print "</form>\n";  
         }  
   
         if ($allow_tar) {    if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}})) {
                 my ($basefile) = ($where =~ m,(?:.*/)?([^/]+),);      %tags = %alltags;
     }
   
                 if (defined($basefile) && $basefile ne '') {    if (scalar %tags
                         print "<hr noshade>\n",        || $input{only_with_tag}
                             "<div align=\"center\">Download this directory in ";        || $edit_option_form
         || defined($input{options}))
     {
       print "<hr />\n";
     }
   
                         # Mangle the filename so browsers show a reasonable    if (scalar %tags || $input{only_with_tag}) {
                         # filename to download.      print "<form method=\"get\" action=\"./\">\n<p>\n";
                         print &link("tarball", "./$basefile.tar.gz$query"      foreach my $var (@stickyvars) {
                                 . ($query ? "&" : "?") . "tarball=1");        printf("<input type=\"hidden\" name=\"%s\" value=\"%s\" />\n",
                         if ($CMD{zip}) {               $var, htmlquote($input{$var}))
                                 print " or ",          if (defined($input{$var})
                                     &link("zip archive", "./$basefile.zip$query"              && (!defined($DEFAULTVALUE{$var})
                                         . ($query ? "&" : "?") . "tarball=1");                  || $input{$var} ne $DEFAULTVALUE{$var})
                         }              && $var ne 'only_with_tag');
                         print "</div>\n";      }
                 }      print <<EOF;
         }  <span class="nowrap">
   <label for="only_with_tag" accesskey="T">Show only files with tag:
   <select id="only_with_tag" name="only_with_tag">
   <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 ($edit_option_form || defined($input{"options"})) {    if ($allow_tar && $filesfound) {
       my ($basefile) = ($where =~ m,(?:.*/)?([^/]+),);
       if (defined($basefile) && $basefile ne '') {
         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.
         $basefile = uri_escape($basefile);
         print &link('tarball', "$basefile.tar.gz$q");
         print "</div>\n";
       }
     }
   
                 my $formwhere = $scriptwhere;    if ($edit_option_form || defined($input{options})) {
                 $formwhere =~ s|Attic/?$|| if ($input{'hideattic'});  
   
                 print "<form method=\"get\" action=\"${formwhere}\">\n";      print <<EOF;
                 print "<input type=\"hidden\" name=\"copt\" value=\"1\">\n";  <form method="get" action="./">
                 if ($cvstree ne $cvstreedefault) {  <fieldset>
                         print  <legend>General options</legend>
                             "<input type=\"hidden\" name=\"cvsroot\" value=\"$cvstree\">\n";  <input type="hidden" name="copt" value="1" />
                 }  EOF
                 print "<center>\n<table cellpadding=\"0\" cellspacing=\"0\">";      for my $v (qw(hidecvsroot hidenonreadable)) {
                 print "\n<tr style=\"background-color: $columnHeaderColorDefault\">\n";        printf(qq{<input type="hidden" name="%s" value="%s" />\n},
                 print "<th colspan=\"2\">Preferences</th>\n</tr>\n";               $v, $input{$v} || 0);
                 print "<tr>\n<td>";      }
                 print "<label for=\"sortby\" accesskey=\"F\">Sort files by ";      if ($cvstree ne $CVSrepositories[0]) {
                 print "</label><select id=\"sortby\" name=\"sortby\">\n";        print "<input type=\"hidden\" name=\"cvsroot\" value=\"$cvstree\" />\n";
                 print "<option value=\"\">File</option>\n";      }
                 print "<option", $bydate ? " selected" : "",      print <<EOF;
                     " value=\"date\">Age</option>\n";  <table summary="General options">
                 print "<option", $byauthor ? " selected" : "",  <tr>
                     " value=\"author\">Author</option>\n"  <td class="opt-label">
                     if ($show_author);  <label for="sortby" accesskey="F">Sort files by:</label>
                 print "<option", $byrev ? " selected" : "",  </td>
                     " value=\"rev\">Revision</option>\n";  <td class="opt-value">
                 print "<option", $bylog ? " selected" : "",  <select id="sortby" name="sortby">
                     " value=\"log\">Log message</option>\n";  <option value="">File</option>
                 print "</select>\n</td>\n";  EOF
                 print "<td><label for=\"logsort\" accesskey=\"L\">";      print "<option", $bydate ? ' selected="selected"' : '',
                 print "Sort log by: </label>";        " value=\"date\">Age</option>\n";
                 printLogSortSelect(0);      print "<option", $byauthor ? ' selected="selected"' : '',
                 print "</td>\n</tr>\n";        " value=\"author\">Author</option>\n"
                 print "<tr>\n<td><label for=\"f\" accesskey=\"D\">";          if $show_author;
                 print "Diff format: </label>";      print "<option", $byrev ? ' selected="selected"' : '',
                 printDiffSelect(0);        " value=\"rev\">Revision</option>\n";
                 print "</td>\n";      print "<option", $bylog ? ' selected="selected"' : '',
                 print "<td><label for=\"hideattic\" accesskey=\"A\">";        " value=\"log\">Log message</option>\n";
                 print "Show Attic files: </label>";      print <<EOF;
                 print "<input id=\"hideattic\" name=\"hideattic\" type=\"checkbox\"",  </select>,
                     $input{'hideattic'} ? " checked" : "",  <label for="ignorecase" accesskey="I">case-insensitive:
                      "></td>\n</tr>\n";  EOF
                 print "<tr>\n<td align=\"center\" colspan=\"2\">";      print '<input id="ignorecase" name="ignorecase" type="checkbox"',
                 print "<input type=\"submit\" value=\"Change Options\" accesskey=\"C\">";        $input{ignorecase} ? ' checked="checked"' : '',
                 print "</td>\n</tr>\n</table>\n</center>\n</form>\n";          " value=\"1\" /></label>\n";
         }      print <<EOF;
         html_footer();  </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();
       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();
       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'});  
                 gzipclose();  
                 exit;  
         }  
   
         if (defined($input{'annotate'}) && $allow_annotate) {    if (defined($input{rev}) || $doCheckout) {
                 &doAnnotate($input{'annotate'});      &doCheckout($fullname, $input{rev}, $input{only_with_tag});
                 gzipclose();      gzipclose();
                 exit;      exit;
         }    }
   
         if (defined($input{'r1'}) && defined($input{'r2'})) {    if (defined($input{annotate}) && $allow_annotate) {
                 &doDiff(      &doAnnotate($input{annotate}, $input{only_with_tag});
                         $fullname,     $input{'r1'},      gzipclose();
                         $input{'tr1'}, $input{'r2'},      exit;
                         $input{'tr2'}, $input{'f'}    }
                 );  
                 gzipclose();  
                 exit;  
         }  
         print("going to dolog($fullname)\n") if ($verbose);  
         &doLog($fullname);  
   
         ##############################    if (defined($input{r1}) && defined($input{r2})) {
         # View Diff      &doDiff($fullname,  $input{r1},  $input{tr1},
         ##############################              $input{r2}, $input{tr2}, $input{f});
 } elsif ($fullname =~ s/\.diff$// && -f $fullname . ",v" && $input{'r1'}      gzipclose();
     && $input{'r2'})      exit;
 {    }
   
         # $where-diff-removal if 'cvs rdiff' is used    &doLog($fullname);
         # .. but 'cvs rdiff'doesn't support some options  }
         # rcsdiff does (-w and -p), so it is disabled  
         # $where =~ s/\.diff$//;  
   
         # Allow diffs using the ".diff" extension  ##############################
         # so that browsers that default to the URL  # View Diff
         # for a save filename don't save diff's as  ##############################
         # e.g. foo.c  elsif ($fullname =~ s/\.diff$//
         &doDiff(         && -f $fullname . ',v' && $input{r1} && $input{r2})
                 $fullname,     $input{'r1'}, $input{'tr1'}, $input{'r2'},  
                 $input{'tr2'}, $input{'f'}  
         );  
         gzipclose();  
         exit;  
 } elsif (($newname = $fullname) =~ s|/([^/]+)$|/Attic/$1| && -f $newname . ",v")  
 {  {
   
         # The file has been removed and is in the Attic.    # $where-diff-removal if 'cvs rdiff' is used
         # Send a redirect pointing to the file in the Attic.    # .. but 'cvs rdiff'doesn't support some options
         (my $newplace = $scriptwhere) =~ s|/([^/]+)$|/Attic/$1|;    # rcsdiff does (-w and -p), so it is disabled
         if ($ENV{QUERY_STRING} ne "") {    # $where =~ s/\.diff$//;
                 redirect("${newplace}?$ENV{QUERY_STRING}");  
         } else {  
                 redirect($newplace);  
         }  
         exit;  
 } elsif (0 && (my @files = &safeglob($fullname . ",v"))) {  
         http_header("text/plain");  
         print "You matched the following files:\n";  
         print join ("\n", @files);  
   
         # Find the tags from each file    # Allow diffs using the ".diff" extension so that browsers that default
         # Display a form offering diffs between said tags    # to the filename in the URL when saving don't save diffs as eg. foo.c.
 } else {    &doDiff($fullname,  $input{r1},  $input{tr1},
         my $fh = do { local (*FH); };            $input{r2}, $input{tr2}, $input{f});
         my ($xtra, $module);    gzipclose();
     exit;
   
         # Assume it's a module name with a potential path following it.  }
         $xtra = (($module = $where) =~ s|/.*||) ? $& : '';  
   
         # Is there an indexed version of modules?  elsif (do { (my $tmp = $fullname) =~ s|/([^/]+)$|/Attic/$1|; -f "$tmp,v" }) {
         if (open($fh, "< $cvsroot/CVSROOT/modules")) {    # The file has been removed and is in the Attic.
                 while (<$fh>) {    # Send a redirect pointing to the file in the Attic.
                         if (/^(\S+)\s+(\S+)/o && $module eq $1    (my $newplace = $scriptwhere) =~ s|/([^/]+)$|/Attic/$1|;
                             && -d "$cvsroot/$2" && $module ne $2)    if ($ENV{QUERY_STRING} ne "") {
                         {      redirect("$newplace?$ENV{QUERY_STRING}");
                                 redirect("$scriptname/$2$xtra$query");    } else {
                         }      redirect($newplace);
                 }    }
         }    exit;
         fatal("404 Not Found",  
               '%s: no such file or directory',  
               $where);  
 }  }
   
   else {
     # Assume it's a module name with a potential path following it.
     my $module;
     my $xtra = (($module = $where) =~ s|(/.*)||) ? $1 : '';
   
     # Is there an indexed version of modules?
     my $fh = do { local (*FH); };
     if (open($fh, catfile($cvsroot, 'CVSROOT', 'modules'))) {
       while (<$fh>) {
         if (/^(\S+)\s+(\S+)/o
             && $module eq $1
             && $module ne $2
             && -d "$cvsroot/$2")
         {
           close($fh);
           redirect("$scriptname/$2$xtra$query");
         }
       }
       close($fh);
     }
     fatal("404 Not Found", '%s: no such file or directory', $where);
   }
   
 gzipclose();  gzipclose();
   
 ## End MAIN  ## End MAIN
   
 sub printDiffSelect($) {  
         my ($use_java_script) = @_;  
         my $f = $input{'f'};  
   
         print '<select id="f" name="f"';  sub printDiffSelect()
         print ' onchange="this.form.submit()"' if $use_java_script;  {
         print ">\n";    print '<select id="f" name="f"';
     print ">\n";
   
         local $_;    for my $difftype (@DIFFTYPES) {
         for (@DIFFTYPES) {      printf("<option value=\"%s\"%s>%s</option>\n",
                 printf("<option value=\"%s\"%s>%s</option>\n", $_,             $difftype, $input{f} eq $difftype ? ' selected="selected"' : '',
                     $f eq $_ ? ' selected' : '', "\u$DIFFTYPES{$_}{'descr'}");             "\u$DIFFTYPES{$difftype}{descr}");
         }    }
   
         print "</select>";    print "</select>";
 }  }
   
 sub printLogSortSelect($) {  
         my ($use_java_script) = @_;  
   
         print '<select id="logsort" name="logsort"';  sub printDiffSelectStickyVars()
         print ' onchange="this.form.submit()"' if $use_java_script;  {
         print ">\n";    while (my ($key, $val) = each %input) {
       next if ($key eq 'f');
         local $_;      next if (defined($DEFAULTVALUE{$key}) && $DEFAULTVALUE{$key} eq $val);
         for (@LOGSORTKEYS) {      print "<input type=\"hidden\" name=\"", htmlquote($key), "\" value=\"",
                 printf("<option value=\"%s\"%s>%s</option>\n", $_,        htmlquote($val), "\" />\n";
                     $logsort eq $_ ? ' selected' : '',    }
                     "\u$LOGSORTKEYS{$_}{'descr'}");  
         }  
   
         print "</select>";  
 }  }
   
 sub findLastModifiedSubdirs(@) {  
         my (@dirs) = @_;  
         my ($dirname, @files);  
   
         foreach $dirname (@dirs) {  sub printLogSortSelect()
                 next if ($dirname eq ".");  {
                 next if ($dirname eq "..");    print '<select id="logsort" name="logsort"';
                 my ($dir) = "$fullname/$dirname";    print ">\n";
                 next if (!-d $dir);  
   
                 my ($lastmod)     = undef;    for my $sortkey (@LOGSORTKEYS) {
                 my ($lastmodtime) = undef;      printf("<option value=\"%s\"%s>%s</option>\n",
                 my $dh = do { local (*DH); };             $sortkey, $logsort eq $sortkey ? ' selected="selected"' : '',
              "\u$LOGSORTKEYS{$sortkey}{descr}");
     }
   
                 opendir($dh, $dir) or next;    print "</select>";
                 my (@filenames) = readdir($dh);  }
                 closedir($dh);  
   
                 foreach my $filename (@filenames) {  
                         $filename = "$dirname/$filename";  
                         my ($file) = "$fullname/$filename";  
                         next if ($filename !~ /,v$/ || !-f $file);  
                         $filename =~ s/,v$//;  
                         my $modtime = -M $file;  
   
                         if (!defined($lastmod) || $modtime < $lastmodtime) {  #
                                 $lastmod     = $filename;  # Find the last modified, version controlled files in the given directories.
                                 $lastmodtime = $modtime;  # Compares solely based on modification timestamps.  Files in the returned list
                         }  # are without the ,v suffix, and unreadable files have been filtered out.
                 }  #
                 push (@files, $lastmod) if (defined($lastmod));  sub findLastModifiedSubdirs(@)
         }  {
         return @files;    my (@dirs) = @_;
 }  
   
 sub htmlify_sub(&$) {    my @files;
         (my $proc, local $_) = @_;    foreach my $dirname (@dirs) {
         my @a = split (m`(<a [^>]+>[^<]*</a>)`i);      next if ($dirname eq curdir() || $dirname eq updir());
         my $linked;      my $dir = catdir($fullname, $dirname);
         my $result = '';      next if (!-d $dir);
   
         while (($_, $linked) = splice(@a, 0, 2)) {      my $dh = do { local (*DH); };
                 &$proc();      opendir($dh, $dir) or next;
                 $result .= $_      if defined($_);      my (@filenames) = grep(!forbidden(catfile($dir, $_)), readdir($dh));
                 $result .= $linked if defined($linked);      closedir($dh);
         }  
   
         $result;      my $lastmod     = undef;
       my $lastmodtime = undef;
       foreach my $filename (@filenames) {
         ($filename) =
           (catfile($dirname, $filename) =~ VALID_PATH) or next; # untaint
         my ($file) = catfile($fullname, $filename);
         next if ($filename !~ /,v$/o || !-f $file || !-r _);
         my $modtime = -M _;
         if (!defined($lastmod) || $modtime < $lastmodtime) {
           ($lastmod    = $filename) =~ s/,v$//;
           $lastmodtime = $modtime;
         }
       }
       push(@files, $lastmod) if (defined($lastmod));
     }
     return @files;
 }  }
   
 sub htmlify($;$) {  
         (local $_, my $extra) = @_;  
   
         $_ = htmlquote($_);  sub htmlify_sub(&$)
   {
     (my $proc, local $_) = @_;
     my @a = split(m|(<a [^>]+>[^<]*</a>)|i);
     my $linked;
     my $result = '';
   
         # get URL's as link    while (($_, $linked) = splice(@a, 0, 2)) {
         s{      &$proc();
       (http|ftp|https)://\S+      $result .= $_      if defined($_);
      }{      $result .= $linked if defined($linked);
          &link($&, htmlunquote($&))    }
      }egx;  
   
         # get e-mails as link    return $result;
         $_ = htmlify_sub {  }
                 s<  
           [\w+=\-.!]+@[\w\-]+(\.[\w\-]+)+  
             ><  
               &link($&, "mailto:$&")  
                 >egix;  
             }  
             $_;  
   
         if ($extra) {  
   
                 # get PR #'s as link: "PR#nnnn" "PR: nnnn, ..." "PR nnnn, ..." "bin/nnnn"  sub htmlify($;$)
                 if (defined($prcgi) && defined($re_prkeyword))  {
                 {    (local $_, my $extra) = @_;
                         my $prev;  
   
                         do {    $_ = htmlquote($_);
                                 $prev = $_;  
   
                                 $_ = htmlify_sub {    # get URL's as link
                                         s{    s{
                       (\b$re_prkeyword[:\#]?\s*      ((https?|ftp)://.+?)([\s\']|&(quot|[lg]t);)
                        (?:     }{
                         \#?       &link($1, htmlunquote($1)) . $3
                         \d+[,\s]\s*     }egx;
                        )*  
                        \#?)  
                       (\d+)\b  
                      }{  
                          $1 . &link($2, sprintf($prcgi, $2))  
                      }egix;  
                                     }  
                                     $_;  
                         } while ($_ ne $prev);  
   
                         if (defined($re_prcategories)) {    if ($allow_mailtos) {
                                 $_ = htmlify_sub {      # Make mailto: links from email addresses.
                                         s{      $_ = htmlify_sub {
                           (\b$re_prcategories/(\d+)\b)        s<
                         }{          ([\w+=\-.!]+@[\w\-]+(?:\.[\w\-]+)+)
                                 &link($1, sprintf($prcgi, $2))         ><
                         }egox;           &link($1, "mailto:$1")
                                     }         >egix;
                                     $_;      } $_;
                         }    }
                 }  
   
                 # get manpage specs as link: "foo.1" "foo(1)"    if ($extra) {
                 if (defined($mancgi)) {      # get manpage specs as link: "foo.1" "foo(1)"
                         $_ = htmlify_sub {      if (defined($mancgi)) {
                                 s{        $_ = htmlify_sub {
                   (\b([a-zA-Z][\w.]+)          s{
                    (?:            (
                     \( ([0-9n]) \)\B             \b ( \w[\w+\-.]* (?: ::\w[\w+\-.]*)* )
                     |             (?:
                     \.([0-9n])\b              \( ([0-9n]) \) \B
                    )              |
                   )              \. ([0-9n]) \b
                  }{             )
                      &link($1, sprintf($mancgi, defined($3) ? $3 : $4, $2))            )
                  }egx;           }{
                             }              my($text, $name, $section) = ($1, $2, defined($3) ? $3 : $4);
                             $_;              ($name =~ /[A-Za-z]/ && $name !~ /\.(:|$)/)
                 }               ? &link($text, sprintf($mancgi, uri_escape($name), $section))
         }                : $text;
            }egx;
         } $_;
       }
     }
   
         $_;    return $_;
 }  }
   
 sub spacedHtmlText($;$) {  
         local $_ = $_[0];  
         my $ts = $_[1] || $tabstop;  
   
         # Cut trailing spaces and tabs  sub spacedHtmlText($;$)
         s/[ \t]+$//;  {
     (local $_, my $ts) = @_;
     return '' unless defined($_);
     $ts ||= $tabstop || 8;
   
         if (defined($ts)) {    # Expand tabs
     1 while s/(.*?)(\t+)/$1 . ' ' x (length($2) * $ts - length($1) % $ts)/e;
   
                 # Expand tabs    if ($hr_breakable) {
                 1 while s/\t+/' ' x (length($&) * $ts - length($`) % $ts)/e      s/^ /\001nbsp;/;      # protect leading and...
         }      s/ $/\001nbsp;/;      # ...trailing whitespace (mostly for String::Ediff),
       s/  / \001nbsp;/g;    # ...and leave every other space 'breakable'
     } else {
       s/ /\001nbsp;/g;
     }
   
         # replace <tab> and <space> (\001 is to protect us from htmlify)    $_ = htmlify($_, $allow_source_extra);
         # gzip can make excellent use of this repeating pattern :-)  
         if ($hr_breakable) {  
   
                 # make every other space 'breakable'    # unescape
                 s/  / \001nbsp;/g;    # 2 * <space>    y/\001/&/;
                                       # leave single space as it is  
         } else {  
                 s/ /\001nbsp;/g;  
         }  
   
         $_ = htmlify($_, $allow_source_extra);    return $_;
   }
   
         # unescape  
         y/\001/&/;  
   
         return $_;  # Note that this doesn't htmlquote the first argument...
   sub link($$)
   {
     my ($name, $url) = @_;
     return sprintf('<a href="%s">%s</a>', htmlquote($url), $name);
 }  }
   
 sub link($$) {  
         my ($name, $url) = @_;  
   
         $url =~ s/:/sprintf("%%%02x", ord($&))/eg  sub revcmp($$)
             if $url =~ /^[^a-z]/;    # relative  {
     my ($rev1, $rev2) = @_;
   
         sprintf '<a href="%s">%s</a>', hrefquote($url), $name;    # make no comparison for a tag or a branch
 }    return 0 if $rev1 =~ /[^\d.]/ || $rev2 =~ /[^\d.]/;
   
 sub revcmp($$) {    my (@r1) = split(/\./, $rev1);
         my ($rev1, $rev2) = @_;    my (@r2) = split(/\./, $rev2);
     my ($a, $b);
   
         # make no comparison for a tag or a branch    while (($a = shift(@r1)) && ($b = shift(@r2))) {
         return 0 if $rev1 =~ /[^\d.]/ || $rev2 =~ /[^\d.]/;      return $a <=> $b unless ($a == $b);
     }
     if (@r1) { return  1; }
     if (@r2) { return -1; }
     return 0;
   }
   
         my (@r1) = split (/\./, $rev1);  
         my (@r2) = split (/\./, $rev2);  
         my ($a, $b);  
   
         while (($a = shift (@r1)) && ($b = shift (@r2))) {  #
                 if ($a != $b) {  # Signal a fatal error.
                         return $a <=> $b;  #
                 }  sub fatal($$@)
         }  {
         if (@r1) { return 1; }    my ($errcode, $format, @args) = @_;
         if (@r2) { return -1; }    print "Status: $errcode\r\n";
         return 0;    html_header('Error');
     print '<div id="error">Error: ',
       sprintf($format, map(htmlquote($_), @args)), "</div>\n";
     html_footer();
     exit(1);
 }  }
   
 sub fatal($$@) {  
         my ($errcode, $format, @args) = @_;  
         if ($is_mod_perl) {  
                 Apache->request->status((split (/ /, $errcode))[0]);  
         } else {  
                 print "Status: $errcode\r\n";  
         }  
         html_header("Error");  
         print "<p>Error: ",  
           sprintf($format, map(htmlquote($_), @args)),  
           "</p>\n";  
         html_footer();  
         exit(1);  
 }  
   
 sub redirect($) {  #
         my ($url) = @_;  # Sends a redirect to the given URL.
         if ($is_mod_perl) {  #
                 Apache->request->status(301);  sub redirect($;$)
                 Apache->request->header_out(Location => $url);  {
         } else {    my ($url, $permanent) = @_;
                 print "Status: 301 Moved\r\n";    my ($status, $text);
                 print "Location: $url\r\n";    if ($permanent) {
         }      $status = '301';
         html_header("Moved");      $text   = 'Moved Permanently';
         print "<p>This document is located ", &link('here', $url), "</p>\n";    } else {
         html_footer();      $status = '302';
         exit(1);      $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);
 }  }
   
 sub safeglob($) {  
         my ($filename) = @_;  
         my ($dirname);  
         my (@results);  
         my $dh = do { local (*DH); };  
   
         ($dirname = $filename) =~ s|/[^/]+$||;  sub safeglob($)
         $filename =~ s|.*/||;  {
     my ($filename) = @_;
   
         if (opendir($dh, $dirname)) {    (my $dirname = $filename) =~ s|/[^/]+$||;
                 my $glob = $filename;    $filename =~ s|.*/||;
                 my $t;  
   
                 #       transform filename from glob to regex.  Deal with:    my @results;
                 #       [, {, ?, * as glob chars    my $dh = do { local (*DH); };
                 #       make sure to escape all other regex chars    if (opendir($dh, $dirname)) {
                 $glob =~ s/([\.\(\)\|\+])/\\$1/g;      my $glob = $filename;
                 $glob =~ s/\*/.*/g;      my $t;
                 $glob =~ s/\?/./g;  
                 $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg;  
                 foreach (readdir($dh)) {  
   
                         if (/^${glob}$/) {      #   transform filename from glob to regex.  Deal with:
                                 push (@results, "$dirname/" . $_);      #   [, {, ?, * as glob chars
                         }      #   make sure to escape all other regex chars
                 }      $glob =~ s/([\.\(\)\|\+])/\\$1/g;
                 closedir($dh);      $glob =~ s/\*/.*/g;
         }      $glob =~ s/\?/./g;
       $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg;
       $glob = qr/^$glob$/;
   
         @results;      foreach (readdir($dh)) {
 }        if ($_ =~ $glob && $_ =~ VALID_PATH) {
           push(@results, catfile($dirname, $1)); # untaint
         }
       }
       closedir($dh);
     }
   
 sub search_path($) {    return @results;
         my ($command) = @_;  
         my $d;  
   
         for $d (split (/:/, $command_path)) {  
                 return "$d/$command" if -x "$d/$command";  
         }  
   
         '';  
 }  }
   
 sub getMimeTypeFromSuffix($) {  
         my ($fullname) = @_;  
         my ($mimetype, $suffix);  
         my $fh = do { local (*FH); };  
   
         ($suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/;  #
         $mimetype = $MTYPES{$suffix};  # Gets the MIME type for the given file name.
         $mimetype = $MTYPES{'*'} if (!$mimetype);  #
   sub getMimeType($;$)
   {
     my ($fullname, $binary) = @_;
     $binary = ($keywordsubstitution && $keywordsubstitution =~ /b/)
       unless defined($binary);
   
         if (!$mimetype && -f $mime_types) {    (my $suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/;
   
                 # okey, this is something special - search the    my $mimetype = $MTYPES{$suffix};
                 # mime.types database    $mimetype  ||= $MimeTypes->mimeTypeOf($fullname) if defined($MimeTypes);
                 open($fh, "<$mime_types");  
                 while (<$fh>) {  
                         if ($_ =~ /^\s*(\S+\/\S+).*\b$suffix\b/) {  
                                 $mimetype = $1;  
                                 last;  
                         }  
                 }  
                 close($fh);  
         }  
   
         # okey, didn't find anything useful ..    if (!$mimetype && $suffix ne '*' && -f $mime_types && -r _) {
         if (!($mimetype =~ /\S\/\S/)) {      my $fh = do { local (*FH); };
                 $mimetype = "text/plain";      if (open($fh, $mime_types)) {
         }        my $re = sprintf('^\s*(\S+\/\S+)\s.+\b%s\b', quotemeta($suffix));
         return $mimetype;        $re = qr/$re/;
         while (my $line = <$fh>) {
           if ($line =~ $re) {
             $mimetype = $1;
             $MTYPES{$suffix} = $mimetype;
             last;
           }
         }
         close($fh);
       } else {
         warn("Can't open MIME types file $mime_types for reading: $!");
       }
     }
   
     $mimetype ||= $MTYPES{'*'};
     $mimetype ||= $binary ? 'application/octet-stream' : 'text/plain';
     return $mimetype;
 }  }
   
   
 ###############################  ###############################
 # read first lines like head(1)  # read first lines like head(1)
 ###############################  ###############################
 sub head($;$) {  sub head($;$)
         my $fh        = $_[0];  {
         my $linecount = $_[1] || 10;    my ($fh, $linecount) = @_;
     $linecount ||= 10;
   
         my @buf;    my @buf;
     if ($linecount > 0) {
         if ($linecount > 0) {      for (my $i = 0; !eof($fh) && $i < $linecount; $i++) {
                 my $i;        push @buf, scalar <$fh>;
                 for ($i = 0 ; !eof($fh) && $i < $linecount ; $i++) {      }
                         push @buf, scalar <$fh>;    } else {
                 }      @buf = <$fh>;
         } else {    }
                 @buf = <$fh>;    return @buf;
         }  
   
         @buf;  
 }  }
   
   
 ###############################  ###############################
 # scan vim and Emacs directives  # scan vim and Emacs directives
 ###############################  ###############################
 sub scan_directives(@) {  sub scan_directives(@)
         my $ts = undef;  {
     my $ts = undef;
   
         for (@_) {    for (@_) {
                 $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/;      $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/;
         }    }
   
         ('tabstop' => $ts);    ('tabstop' => $ts);
 }  }
   
 sub openOutputFilter() {  
         return if !defined($output_filter) || $output_filter eq '';  
   
         open(STDOUT, "|-") and return;  
   
         # child of child  
         open(STDERR, '>/dev/null');  
         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 are 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 =~ /[^\w.]/) {    # 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 "%s"',    # the cvs server in a similiar way one day (..after rewrite).
                       $ENV{QUERY_STRING});  
         }  
   
         if (&forbidden_file($fullname)) {    local (*CVS_IN, *CVS_OUT);
                 fatal("403 Forbidden",    my $annotate_err;
                       'Access forbidden.  This file is mentioned in @ForbiddenFiles');    my ($h, $err) =
                 return;      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;
   
         ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;    # OK, first send the request to the server.  A simplified example is:
         ($filename = $where) =~ s/^.*\///;    #     Root /home/kingdon/zwork/cvsroot
     #     Argument foo/xx
     #     Directory foo
     #     /home/kingdon/zwork/cvsroot/foo
     #     Directory .
     #     /home/kingdon/zwork/cvsroot
     #     annotate
     # although as you can see there are a few more details.
   
         # this seems to be necessary    print CVS_IN "Root $cvsroot\n";
         $| = 1;    print CVS_IN
         $| = 0;    # Flush      "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n";
   
         # this annotate version is based on the    # Don't worry about sending valid-requests, the server just needs to
         # cvs annotate-demo Perl script by Cyclic Software    # support "annotate" and if it doesn't, there isn't anything to be done.
         # It was written by Cyclic Software, http://www.cyclic.com/, and is in    print CVS_IN "UseUnchanged\n";
         # the public domain.    print CVS_IN "Argument -r\n";
         # we could abandon the use of rlog, rcsdiff and co using    print CVS_IN "Argument $rev\n";
         # the cvsserver in a similiar way one day (..after rewrite)    print CVS_IN "Argument $where\n";
         $pid = open2($reader, $writer, $CMD{cvs}, @cvs_options, "server")  
             or fatal("500 Internal Error",  
                      'Fatal Error - unable to open cvs for annotation');  
   
         # OK, first send the request to the server.  A simplified example is:    # The protocol requires us to fully fake a working directory (at
         #     Root /home/kingdon/zwork/cvsroot    # least to the point of including the directories down to the one
         #     Argument foo/xx    # containing the file in question).
         #     Directory foo    # So if $where is "dir/sdir/file", then dirs will be ("dir","sdir","file")
         #     /home/kingdon/zwork/cvsroot/foo    my $path = '';
         #     Directory .    foreach my $dir (split('/', $where)) {
         #     /home/kingdon/zwork/cvsroot  
         #     annotate  
         # although as you can see there are a few more details.  
   
         print $writer "Root $cvsroot\n";      if ($path eq "") {
         print $writer        # In our example, $dir is "dir".
             "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n";        $path = $dir;
       } else {
         print CVS_IN "Directory $path\n";
         print CVS_IN "$cvsroot/$path\n";
   
         # Don't worry about sending valid-requests, the server just needs to        # In our example, $_ is "sdir" and $path becomes "dir/sdir"
         # support "annotate" and if it doesn't, there isn't anything to be done.        # And the next time, "file" and "dir/sdir/file" (which then gets
         print $writer "UseUnchanged\n";        # ignored, because we don't need to send Directory for the file).
         print $writer "Argument -r\n";        $path .= "/$dir";
         print $writer "Argument $rev\n";      }
         print $writer "Argument $where\n";    }
     undef $path;
   
         # The protocol requires us to fully fake a working directory (at    # And the last "Directory" before "annotate" is the top level.
         # least to the point of including the directories down to the one    print CVS_IN "Directory .\n";
         # containing the file in question).    print CVS_IN "$cvsroot\n";
         # So if $where is "dir/sdir/file", then @dirs will be ("dir","sdir","file")  
         my @dirs = split ('/', $where);  
         my $path = "";  
         foreach (@dirs) {  
   
                 if ($path eq "") {    print CVS_IN "annotate\n";
   
                         # In our example, $_ is "dir".    # OK, we've sent our command to the server.  Thing to do is to
                         $path = $_;    # close the writer side and get all the responses.
                 } else {    if (!close(CVS_IN)) {
                         print $writer "Directory $path\n";      $h->finish();
                         print $writer "$cvsroot/$path\n";      fatal('500 Internal Error',
             'Annotate failure (exit status %s): <code>%s</code>, output: ' .
             '<pre>%s</pre>', $? >> 8, $!, $annotate_err);
     }
   
                         # In our example, $_ is "sdir" and $path becomes "dir/sdir"    navigateHeader($scriptwhere, $pathname, $filename, $rev, 'annotate');
                         # And the next time, "file" and "dir/sdir/file" (which then gets  
                         # ignored, because we don't need to send Directory for the file).  
                         $path .= "/$_";  
                 }  
         }  
   
         # And the last "Directory" before "annotate" is the top level.    my $revtype = ($rev =~ /\./) ? 'revision' : 'tag'; # TODO: tag -> branch/tag?
         print $writer "Directory .\n";    print '<h3 style="text-align: center">Annotation of ',
         print $writer "$cvsroot\n";      htmlquote("$pathname$filename"), ", $revtype $rev</h3>\n";
   
         print $writer "annotate\n";    # Ready to get the responses from the server.
     # For example:
     #     E Annotations for foo/xx
     #     E ***************
     #     M 1.3          (kingdon  06-Sep-97): hello
     #     ok
     my ($lineNr) = 0;
     my ($oldLrev, $oldLusr) = ("", "");
     my ($revprint, $usrprint);
   
         # OK, we've sent our command to the server.  Thing to do is to    if ($annTable) {
         # close the writer side and get all the responses.  If "cvs server"      print <<EOF;
         # were nicer about buffering, then we could just leave it open, I think.  <table style="border: none" cellspacing="0" cellpadding="0" summary="Annotation">
         close($writer) or die "cannot close: $!";  EOF
     } else {
       print "<pre>";
     }
   
         http_header();    # prefetch several lines
     my @buf = head(*CVS_OUT);
   
         navigateHeader($scriptwhere, $pathname, $filename, $rev, "annotate");    my %d = scan_directives(@buf);
         print  
             "<h3 style=\"text-align: center\">Annotation of $pathname$filename, Revision $rev</h3>\n";  
   
         # Ready to get the responses from the server.    while (@buf || !eof(*CVS_OUT)) {
         # For example:  
         #     E Annotations for foo/xx  
         #     E ***************  
         #     M 1.3          (kingdon  06-Sep-97): hello  
         #     ok  
         my ($lineNr) = 0;  
         my ($oldLrev, $oldLusr) = ("", "");  
         my ($revprint, $usrprint);  
   
         if ($annTable) {      $_ = @buf ? shift @buf : <CVS_OUT>;
                 print "<table style=\"border: none\" cellspacing=\"0\" cellpadding=\"0\">\n";      my @words = split;
         } else {  
                 print "<pre>";  
         }  
   
         # prefetch several lines      # Adding one is for the (single) space which follows $words[0].
         my @buf = head($reader);      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);
   
         my %d = scan_directives(@buf);        # 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 = '';
         }
   
         while (@buf || !eof($reader)) {        $usrprint = ($lusr eq $oldLusr) ? '' : $lusr;
                 $_ = @buf ? shift @buf : <$reader>;        $oldLrev = $lrev;
         $oldLusr = $lusr;
   
                 my @words = split;        print $is_textbased ? '<b>' : '<span class="current-rev">'
           if $isCurrentRev;
   
                 # Adding one is for the (single) space which follows $words[0].        $usrprint = sprintf('%-8s', $usrprint);
                 my $rest = substr($_, length($words[0]) + 1);        printf '%s%s %s %4d:', $revprint, $isCurrentRev ? '!' : ' ',
                 if ($words[0] eq "E") {          htmlquote($usrprint), $lineNr;
                         next;        print spacedHtmlText($line, $d{tabstop});
                 } elsif ($words[0] eq "M") {  
                         $lineNr++;  
                         (my $lrev = substr($_, 2,  13)) =~ y/ //d;  
                         (my $lusr = substr($_, 16, 9))  =~ y/ //d;  
                         my $line = substr($_, 36);  
                         my $isCurrentRev = ($rev eq $lrev);  
   
                         # we should parse the date here ..        print $is_textbased ? '</b>' : '</span>' if $isCurrentRev;
                         if ($lrev eq $oldLrev) {  
                                 $revprint = sprintf('%-8s', '');  
                         } else {  
                                 $revprint = sprintf('%-8s', $lrev);  
                                 $revprint =~  
                                     s`\S+`&link($&, "$scriptwhere$query#rev$&")`e  
                                     ;    # `  
                                 $oldLusr = '';  
                         }  
   
                         if ($lusr eq $oldLusr) {      } elsif ($words[0] eq "ok") {
                                 $usrprint = '';        # We could complain about any text received after this, like the
                         } else {        # CVS command line client.  But for simplicity, we don't.
                                 $usrprint = $lusr;  
                         }  
                         $oldLrev = $lrev;  
                         $oldLusr = $lusr;  
   
                         # Set bold for text-based browsers only - graphical      } elsif ($words[0] eq "error") {
                         # browsers show bold fonts a bit wider than regular fonts,        fatal("500 Internal Error",
                         # so it looks irregular.              'Error occured during annotate: <b>%s</b>', $_);
                         print "<b>" if ($isCurrentRev && $is_textbased);      }
     }
     $h->finish();
   
                         printf "%s%s %-8s %4d:", $revprint,    if ($annTable) {
                             $isCurrentRev ? '!' : ' ', $usrprint, $lineNr;      print "</table>";
                         print spacedHtmlText($line, $d{'tabstop'});    } else {
       print "</pre>";
                         print "</b>" if ($isCurrentRev && $is_textbased);    }
                 } elsif ($words[0] eq "ok") {    html_footer();
   
                         # 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>',  
                               $_);  
                 }  
         }  
   
         if ($annTable) {  
                 print "</table>";  
         } else {  
                 print "</pre>";  
         }  
         close($reader) or warn "cannot close: $!";  
         wait;  
 }  }
   
 ###############################  ###############################
 # make Checkout  # make Checkout
 ###############################  ###############################
 sub doCheckout($$) {  sub doCheckout($$$)
         my ($fullname, $rev) = @_;  {
         my ($mimetype, $revopt);    my ($fullname, $rev, $tag) = @_;
         my $fh = do { local (*FH); };    $rev = $tag || undef if (!$rev || $rev eq '.');
   
         if ($rev eq 'HEAD' || $rev eq '.') {    # Start resolving whether we will do a markup view or not.
                 $rev = undef;    my $do_markup = undef;
         }    my $want_type = $input{'content-type'};
   
         # make sure the revisions a wellformed, for security    # No markup if markup disallowed.
         # reasons ..    $do_markup = 0 unless $allow_markup;
         if (defined($rev) && $rev =~ /[^\w.]/) {  
                 fatal("404 Not Found",  
                       'Malformed query "%s"',  
                       $ENV{QUERY_STRING});  
         }  
   
         if (&forbidden_file($fullname)) {    # No markup if checkout magic cookie in URL.
                 fatal("403 Forbidden",    $do_markup = 0 if (!defined($do_markup) && $doCheckout);
                       'Access forbidden.  This file is mentioned in @ForbiddenFiles');  
                 return;  
         }  
   
         # get mimetype    # Do markup if explicitly asked using cvsweb-markup content type.  If the
         if (defined($input{"content-type"})    # asked content type is anything else, no markup.
             && ($input{"content-type"} =~ /\S\/\S/))    if (!defined($do_markup) && $want_type) {
         {      if ($want_type =~ CVSWEBMARKUP) {
                 $mimetype = $input{"content-type"}        $want_type = undef;
         } else {        $do_markup = 1;
                 $mimetype = &getMimeTypeFromSuffix($fullname);      } else {
         }        $do_markup = 0;
       }
     }
   
         if (defined($rev)) {    # Ok, if $do_markup is still undefined, we know that a download has not been
                 $revopt = "-r$rev";    # explicitly asked.  For the last check further down below we'll need to
                 if ($use_moddate) {    # know if the file is binary, and possibly run a log on it.
                         readLog($fullname, $rev);    my $needlog = $do_markup || $use_moddate;
                         $moddate = $date{$rev};  
                 }  
         } else {  
                 $revopt = "-rHEAD";  
   
                 if ($use_moddate) {    my $moddate = undef;
                         readLog($fullname);    my $revopt;
                         $moddate = $date{$symrev{HEAD}};    if (defined($rev)) {
                 }      $revopt = "-r$rev";
         }      if ($needlog) {
         readLog($fullname, $rev);
         $moddate   = $date{$rev};
         # TODO: even this does not work for branch tags, but only normal tags :(
         $moddate ||= $date{$symrev{$rev}} if defined($symrev{$rev});
       }
     } else {
       $revopt = "-rHEAD";
       if ($needlog) {
         readLog($fullname);
         $moddate = $date{$symrev{HEAD}};
       }
     }
   
         ### just for the record:    my $cr = abs_path($cvsroot) || $cvsroot;
         ### 'cvs co' seems to have a bug regarding single checkout of    # abs_path() taints when run as a CGI...
         ### directories/files having spaces in it;    if ($cr =~ VALID_PATH) {
         ### this is an issue that should be resolved on cvs's side      $cr = $1;
         #    } else {
         # Safely for a child process to read from.      fatal('500 Internal Error', 'Illegal CVS root: <code>%s</code>', $cr);
         if (!open($fh, "-|")) {    # child    }
                  # chdir to $tmpdir before to avoid non-readable cgi-bin directories    # Use abs_path() to work around a bug of cvs -p; expand symlinks if we can.
                 chdir($tmpdir);    my @cmd = ($CMD{cvs}, @cvs_options, '-d', $cr, 'co', '-p', $revopt, $where);
                 open(STDERR, ">&STDOUT");    # Redirect stderr to stdout  
   
                 # work around a bug of cvs -p; expand symlinks    local (*CVS_OUT, *CVS_ERR);
                 use Cwd 'abs_path';    my ($h, $err) =
                 exec($CMD{cvs}, @cvs_options,      startproc(\@cmd, \"", '>pipe', \*CVS_OUT, '2>pipe', \*CVS_ERR);
                      '-d', abs_path($cvsroot),    fatal('500 Internal Error',
                      'co', '-p',          'Checkout failure (exit status %s), output: <pre>%s</pre>',
                      $revopt, $where) or exit -1;          $? >> 8 || -1, $err)
         }      unless $h;
   
         if (eof($fh)) {    if (eof(CVS_ERR)) {
                 fatal("404 Not Found",      $h->finish();
                       '%s is not (any longer) pertinent',      fatal("404 Not Found", '%s is not (any longer) pertinent', $where);
                       $where);    }
         }  
   
         #===================================================================    #===================================================================
         #Checking out squid/src/ftp.c    #Checking out squid/src/ftp.c
         #RCS:  /usr/src/CVS/squid/src/ftp.c,v    #RCS:  /usr/src/CVS/squid/src/ftp.c,v
         #VERS: 1.1.1.28.6.2    #VERS: 1.1.1.28.6.2
         #***************    #***************
   
         # Parse CVS header    # Parse CVS header
         my ($revision, $filename, $cvsheader);    my ($revision, $filename, $cvsheader);
         $filename = "";    $filename = "";
         while (<$fh>) {    while (<CVS_ERR>) {
                 last if (/^\*\*\*\*/);      last if (/^\*\*\*\*/);
                 $revision = $1 if (/^VERS: (.*)$/);      $revision = $1 if (/^VERS: (.*)$/);
   
                 if (/^Checking out (.*)$/) {      if (/^Checking out (.*)$/) {
                         $filename = $1;        ($filename = $1) =~ s|^\./+||;
                         $filename =~ s/^\.\/*//;      }
                 }      $cvsheader .= $_;
                 $cvsheader .= $_;    }
         }    close(CVS_ERR);
   
         if ($filename ne $where) {    if ($filename ne $where) {
                 fatal("500 Internal Error",      $h->finish();
                       'Unexpected output from cvs co: %s',      fatal("500 Internal Error",
                       $cvsheader);            'Unexpected output from cvs co: <pre>%s</pre> ' .
         }            '(expected "<code>%s</code>" but got "<code>%s</code>")',
         $| = 1;            $cvsheader, $where, $filename);
     }
   
         if ($mimetype eq "text/x-cvsweb-markup") {    # Last checks whether we'll do markup or not.
                 &cvswebMarkup($fh, $fullname, $revision);    my $isbin = $keywordsubstitution && $keywordsubstitution =~ /b/;
         } else {    my $mimetype = getMimeType($fullname, $isbin);
                 http_header($mimetype);  
                 print <$fh>;  
         }  
         close($fh);  
 }  
   
 sub cvswebMarkup($$$) {    # If we still are not sure whether to do markup or not:
         my ($filehandle, $fullname, $revision) = @_;    # if the MIME type is "viewable" or this is not a binary file, do.
         my ($pathname,   $filename);    $do_markup = !$isbin || viewable($mimetype) unless defined($do_markup);
   
         ($pathname = $where) =~ s/(Attic\/)?[^\/]*$//;    if ($do_markup) {
         ($filename = $where) =~ s/^.*\///;  
         my ($fileurl) = urlencode($filename);  
   
         http_header();      # 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();
       }
   
         navigateHeader($scriptwhere, $pathname, $filename, $revision, "view");      # Here we know the last modified date, but don't know if tags have been
         print "<hr noshade>";      # added afterwards (those are shown in the markup view): no last-modified.
         print "<table width=\"100%\">\n<tr>\n<td style=\"background-color: $markupLogColor\">";      cvswebMarkup(\*CVS_OUT, $fullname, $revision, $isbin, $mimetype, $needlog);
         print "File: ", &clickablePath($where, 1);  
         print "&nbsp;(";  
         &download_link($fileurl, $revision, "download");  
         print ")";  
   
         if (!$defaultTextPlain) {      $h->finish() unless $linked;
                 print "&nbsp;(";  
                 &download_link($fileurl, $revision, "as text", "text/plain");  
                 print ")";  
         }  
         print "<br>\n";  
   
         if ($show_log_in_markup) {    } else {
                 readLog($fullname);    #,$revision);      http_header($want_type || $mimetype, $moddate);
                 printLog($revision, 0);      local $/ = undef;
         } else {      print <CVS_OUT>;
                 print "Version: <b>$revision</b><br>\n";      $h->finish();
                 print "Tag: <b>", $input{only_with_tag}, "</b><br>\n"    }
                     if $input{only_with_tag};  }
         }  
         print "</td>\n</tr>\n</table>";  
         my $url = download_url($fileurl, $revision, $mimetype);  
         print "<hr noshade>";  
   
         if ($mimetype =~ /^image/) {  
                 printf '<img src="%s" alt=""><br>', hrefquote("$url$barequery");  
         } elsif ($mimetype =~ m%^application/pdf%) {  
                 printf '<embed src="%s" width="100%"><br>',  
                     hrefquote("$url$barequery");  
         } elsif ($preformat_in_markup) {  
                 print "<pre>";  
   
                 # prefetch several lines  sub cvswebMarkup($$$$$$;$)
                 my @buf = head($filehandle);  {
     my ($filehandle, $fullname, $rev, $isbin, $mimetype, $logged, $mod) = @_;
   
                 my %d = scan_directives(@buf);    (my $pathname = $where) =~ s|((?<=/)Attic/)?[^/]*$||;
     (my $filename = $where) =~ s|^.*/||;
   
                 while (@buf || !eof($filehandle)) {    navigateHeader($scriptwhere, $pathname, $filename, $rev, 'view', $mod);
                         $_ = @buf ? shift @buf : <$filehandle>;  
   
                         print spacedHtmlText($_, $d{'tabstop'});    print <<EOF;
                 }  <hr />
                 print "</pre>";  <div class="log-markup">
         } else {  File:&nbsp;
                 print "<pre>";  EOF
     print &clickablePath($where, 1), "<br />\n";
   
                 while (<$filehandle>) {    if ($show_log_in_markup) {
                         print htmlquote($_);      readLog($fullname) unless $logged; #,$rev);
                 }      printLog($rev, $mimetype, $isbin);
                 print "</pre>";    } 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;
         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($) {  
         my ($mimetype) = @_;  
   
         $mimetype =~ m%^((text|image)/|application/pdf)%;  sub viewable($)
   {
     return shift =~ m{^((text|image)/|application/pdf)}i;
 }  }
   
   
 ###############################  ###############################
 # Show Colored Diff  # Show Colored Diff
 ###############################  ###############################
 sub doDiff($$$$$$) {  sub doDiff($$$$$$)
         my ($fullname, $r1, $tr1, $r2, $tr2, $f) = @_;  {
         my $fh = do { local (*FH); };    my ($fullname, $r1, $tr1, $r2, $tr2, $f) = @_;
         my ($rev1, $rev2, $sym1, $sym2, $f1, $f2);  
   
         if (&forbidden_file($fullname)) {    if (forbidden($fullname)) {
                 fatal("403 Forbidden",      fatal('403 Forbidden', 'Access to %s forbidden.', $where);
                       'Access forbidden.  This file is mentioned in @ForbiddenFiles');    }
                 return;  
         }  
   
         if ($r1 =~ /([^:]+)(:(.+))?/) {    my ($rev1, $sym1);
                 $rev1 = $1;    if ($r1 =~ /([^:]+)(:(.+))?/) {
                 $sym1 = $3;      $rev1 = $1;
         }      $sym1 = $3;
         if ($r1 eq 'text') {    }
                 $rev1 = $tr1;    if ($r1 eq 'text') {
                 $sym1 = "";      $rev1 = $tr1;
         }      $sym1 = "";
     }
   
         if ($r2 =~ /([^:]+)(:(.+))?/) {    my ($rev2, $sym2);
                 $rev2 = $1;    if ($r2 =~ /([^:]+)(:(.+))?/) {
                 $sym2 = $3;      $rev2 = $1;
         }      $sym2 = $3;
         if ($r2 eq 'text') {    }
                 $rev2 = $tr2;    if ($r2 eq 'text') {
                 $sym2 = "";      $rev2 = $tr2;
         }      $sym2 = "";
     }
   
         # make sure the revisions a wellformed, for security    #
         # reasons ..    # rev1 and rev2 are now both numeric revisions.
         if ($rev1 =~ /[^\w.]/ || $rev2 =~ /[^\w.]/) {    # Thus we do a DWIM here and swap them if rev1 is after rev2.
                 fatal("404 Not Found",    # XXX should we warn about the fact that we do this?
                       'Malformed query "%s"',    if (&revcmp($rev1, $rev2) > 0) {
                       $ENV{QUERY_STRING});      my ($tmp1, $tmp2) = ($rev1, $sym1);
         }      ($rev1, $sym1) = ($rev2, $sym2);
       ($rev2, $sym2) = ($tmp1, $tmp2);
     }
   
         #    my $mimetype = getMimeType($fullname);
         # 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 $difftype = $DIFFTYPES{$f};  
   
         if (!$difftype) {    $f = $DEFAULTVALUE{f} || 'u' if ($f =~ /^ext\d*$/);
                 fatal("400 Bad arguments",    my $difftype = $DIFFTYPES{$f};
                       'Diff format %s not understood',    if (!$difftype) {
                       $f);      fatal("400 Bad arguments", 'Diff format %s not understood', $f);
         }    }
   
         my @difftype       = @{$difftype->{'opts'}};    my @difftype       = @{$difftype->{opts}};
         my $human_readable = $difftype->{'colored'};    my $human_readable = $difftype->{colored};
   
         # apply special options    # Apply special diff options.
         if ($showfunc) {    push @difftype, '-p';
                 push @difftype, '-p' if $f ne 's';  
   
                 my ($re1, $re2);    if ($human_readable) {
       push(@difftype, '-w')  if $hr_ignwhite;
       push(@difftype, '-kk') if $hr_ignkeysubst;
     }
   
                 while (($re1, $re2) = each %funcline_regexp) {    my $fh = do { local (*FH); };
                         if ($fullname =~ /$re1/) {    if (!open($fh, "-|")) {    # child
                                 push @difftype, '-F', $re2;      open(STDERR, ">&STDOUT");    # Redirect stderr to stdout
                                 last;      exec($CMD{rcsdiff}, @rcsdiff_options, @difftype, "-r$rev1", "-r$rev2",
                         }           $fullname) or exit -1;
                 }    }
         }  
   
         if ($human_readable) {    if ($human_readable) {
                 if ($hr_ignwhite) {      #
                         push @difftype, '-w';      # Human readable diff.
                 }      #
                 if ($hr_ignkeysubst) {      human_readable_diff($fh, $rev2);
                         push @difftype, '-kk';      html_footer();
                 }      gzipclose();
         }      exit;
     } else {
       #
       # Plain diff.
       #
       http_header("text/plain");
     }
   
         if (!open($fh, "-|")) {    # child    #
                 open(STDERR, ">&STDOUT");    # Redirect stderr to stdout    #===================================================================
                 openOutputFilter();    #RCS file: /home/ncvs/src/sys/netinet/tcp_output.c,v
                 exec($CMD{rcsdiff}, @difftype, "-r$rev1", "-r$rev2", $fullname) or exit -1;    #retrieving revision 1.16
         }    #retrieving revision 1.17
         if ($human_readable) {    #diff -c -r1.16 -r1.17
                 http_header();    #*** /home/ncvs/src/sys/netinet/tcp_output.c     1995/11/03 22:08:08     1.16
                 &human_readable_diff($fh, $rev2);    #--- /home/ncvs/src/sys/netinet/tcp_output.c     1995/12/05 17:46:35     1.17
                 html_footer();    #
                 gzipclose();    # Ideas:
                 exit;    # - nuke the stderr output if it's what we expect it to be
         } else {    # - Add "no differences found" if the diff command supplied no output.
                 http_header("text/plain");    #
         }    #*** 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) {
         #RCS file: /home/ncvs/src/sys/netinet/tcp_output.c,v        s|$cvsroot/||o;
         #retrieving revision 1.16        if ($sym1) {
         #retrieving revision 1.17          chop;
         #diff -c -r1.16 -r1.17          $_ .= " $sym1\n";
         #*** /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      } elsif (m|^$f2 $cvsroot|o) {
         #        s|$cvsroot/||o;
         # 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...)  
         #  
         if (grep { $_ eq '-u' } @difftype) {  
                 $f1 = '---';  
                 $f2 = '\+\+\+';  
         } else {  
                 $f1 = '\*\*\*';  
                 $f2 = '---';  
         }  
   
         while (<$fh>) {        if ($sym2) {
                 if (m|^$f1 $cvsroot|o) {          chop;
                         s|$cvsroot/||o;          $_ .= " $sym2\n";
                         if ($sym1) {        }
                                 chop;      }
                                 $_ .= " $sym1\n";      print $_;
                         }    }
                 } elsif (m|^$f2 $cvsroot|o) {    close($fh);
                         s|$cvsroot/||o;  
   
                         if ($sym2) {  
                                 chop;  
                                 $_ .= " $sym2\n";  
                         }  
                 }  
                 print $_;  
         }  
         close($fh);  
 }  }
   
   
 ###############################  ###############################
 # Show Logs ..  # Show Logs ..
 ###############################  ###############################
 sub getDirLogs($$@) {  sub getDirLogs($$@)
         my ($cvsroot, $dirname, @otherFiles) = @_;  {
         my ($state, $otherFiles, $tag, $file, $date, $branchpoint, $branch,    my ($cvsroot, $dirname, @otherFiles) = @_;
             $log);    my $tag = $input{only_with_tag};
         my ($rev, $revision, $revwanted, $filename, $head, $author);    my $DirName = catdir($cvsroot, $where);
   
         $tag = $input{only_with_tag};    my @files = &safeglob("$DirName/*,v");
     push (@files, &safeglob("$DirName/Attic/*,v")) unless $input{hideattic};
     foreach my $file (@otherFiles) {
       push(@files, catfile($DirName, $file));
     }
   
         my ($DirName) = "$cvsroot/$where";    # Weed out unreadable files.
         my (@files, @filetags);    my $i = 0;
         my $fh = do { local (*FH); };    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));
       }
     }
   
         push (@files, &safeglob("$DirName/*,v"));    # If there are no files, we're done.
         push (@files, &safeglob("$DirName/Attic/*,v"))    return @unreadable unless @files;
             if (!$input{'hideattic'});  
         foreach $file (@otherFiles) {  
                 push (@files, "$DirName/$file");  
         }  
   
         # just execute rlog if there are any files    my @cmd = ($CMD{rlog});
         if ($#files < 0) {    # Can't use -r<tag> as '-' is allowed in tagnames,
                 return;    # but misinterpreted by rlog.
         }    push(@cmd, '-r') unless defined($tag);
   
         if (defined($tag)) {    my $fh = do { local (*FH); };
     if (!open($fh, '-|')) {                       # Child
       open(STDERR, '>', devnull()) unless $DEBUG; # Ignore rlog's complaints.
       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;
         }
       }
       exec(@cmd, @files) or exit -1;
     }
     undef @cmd;
   
                 #can't use -r<tag> as - is allowed in tagnames, but misinterpreated by rlog..    my $state = 'start';
                 if (!open($fh, "-|")) {    # child    my ($date, $branchpoint, $branch, $log, @filetags);
                         open(STDERR, '>/dev/null'); # rlog may complain; ignore.    my ($rev, $revision, $revwanted, $filename, $head, $author, $keywordsubst);
                         openOutputFilter();  
                         exec($CMD{rlog}, @files) or exit -1;  
                 }  
         } else {  
   
                 if (!open($fh, "-|")) {    # child    while (<$fh>) {
                         open(STDERR, '>/dev/null'); # rlog may complain; ignore.      if ($state eq "start") {
                         openOutputFilter();  
                         exec($CMD{rlog}, '-r', @files) or exit -1;  
                 }  
         }  
         $state = "start";  
   
         while (<$fh>) {        #Next file. Initialize file variables
                 if ($state eq "start") {        $rev         = '';
         $revwanted   = '';
         $branch      = '';
         $branchpoint = '';
         $filename    = '';
         $log         = '';
         $revision    = '';
         %symrev      = ();
         @filetags    = ();
         $keywordsubst= '';
   
                         #Next file. Initialize file variables        #jump to head state
                         $rev         = '';        $state = "head";
                         $revwanted   = '';      }
                         $branch      = '';  
                         $branchpoint = '';  
                         $filename    = '';  
                         $log         = '';  
                         $revision    = '';  
                         %symrev      = ();  
                         @filetags    = ();  
   
                         #jump to head state      again:
                         $state = "head";  
                 }  
                 print "$state:$_" if ($verbose);  
                 again:  
   
                 if ($state eq "head") {      if ($state eq "head") {
   
                         #$rcsfile = $1 if (/^RCS file: (.+)$/); #not used (yet)        #$rcsfile = $1 if (/^RCS file: (.+)$/); #not used (yet)
   
                         if (/^Working file: (.+)$/) {        if (/^Working file: (.+)$/) {
                                 $filename = $1;          $filename = $1;
                         } elsif (/^head: (.+)$/) {        } elsif (/^head: (.+)$/) {
                                 $head = $1;          $head = $1;
                         } elsif (/^branch: (.+)$/) {        } elsif (/^branch: (.+)$/) {
                                 $branch = $1          $branch = $1;
                         } elsif (/^symbolic names:/) {        } elsif (/^keyword substitution: (.+)$/) {
                                 $state = "tags";          $keywordsubst = $1;
                                 ($branch = $head) =~ s/\.\d+$//        } elsif (/^symbolic names:/) {
                                     if $branch eq '';          $state = "tags";
                                 $branch =~ s/(\d+)$/0.$1/;          ($branch = $head) =~ s/\.\d+$//
                                 $symrev{MAIN}  = $branch;            if $branch eq '';
                                 $symrev{HEAD}  = $branch;          $branch =~ s/(\d+)$/0.$1/;
                                 $alltags{MAIN} = 1;          $symrev{MAIN}  = $branch;
                                 $alltags{HEAD} = 1;          $symrev{HEAD}  = $branch;
                                 push (@filetags, "MAIN", "HEAD");          $alltags{MAIN} = 1;
                         } elsif (/$LOG_REVSEPARATOR/o) {          $alltags{HEAD} = 1;
                                 $state = "log";          push (@filetags, "MAIN", "HEAD");
                                 $rev   = '';        } elsif ($_ =~ LOG_REVSEPR) {
                                 $date  = '';          $state = "log";
                                 $log   = '';          $rev   = '';
           $date  = '';
           $log   = '';
   
                                 # Try to reconstruct the relative filename if RCS spits out a full path          # Try to reconstruct the relative filename if RCS spits out a full path
                                 $filename =~ s%^\Q$DirName\E/%%;          $filename =~ s%^\Q$DirName\E/%%;
                         }        }
                         next;        next;
                 }      }
   
                 if ($state eq "tags") {      if ($state eq "tags") {
                         if (/^\s+([^:]+):\s+([\d\.]+)\s*$/) {        if (/^\s+([^:]+):\s+([\d\.]+)\s*$/) {
                                 push (@filetags, $1);          push (@filetags, $1);
                                 $symrev{$1}  = $2;          $symrev{$1}  = $2;
                                 $alltags{$1} = 1;          $alltags{$1} = 1;
                                 next;          next;
                         } elsif (/^\S/) {        } elsif (/^\S/) {
   
                                 if (defined($tag)) {          if (defined($tag)) {
                                         if (defined($symrev{$tag})            if (defined($symrev{$tag}) || $tag eq "HEAD") {
                                             || $tag eq "HEAD")              $revwanted    = $symrev{$tag eq "HEAD" ? "MAIN" : $tag};
                                         {              ($branch      = $revwanted) =~ s/\b0\.//;
                                                 $revwanted =              ($branchpoint = $branch)    =~ s/\.?\d+$//;
                                                     $symrev{$tag eq "HEAD" ?              $revwanted    = '' if ($revwanted ne $branch);
                                                     "MAIN" : $tag};            } elsif ($tag ne "HEAD") {
                                                 ($branch = $revwanted) =~              $state = "skip";
                                                     s/\b0\.//;              next;
                                                 ($branchpoint = $branch) =~            }
                                                     s/\.?\d+$//;          }
                                                 $revwanted = ''  
                                                     if ($revwanted ne $branch);  
                                         } elsif ($tag ne "HEAD") {  
                                                 print  
                                                     "Tag not found, skip this file"  
                                                     if ($verbose);  
                                                 $state = "skip";  
                                                 next;  
                                         }  
                                 }  
   
                                 foreach my $tagfound (@filetags) {          foreach my $tagfound (@filetags) {
                                         $tags{$tagfound} = 1;            $tags{$tagfound} = 1;
                                 }          }
                                 $state = "head";          $state = "head";
                                 goto again;          goto again;
                         }        }
                 }      }
   
                 if ($state eq "log") {      if ($state eq "log") {
                         if (/$LOG_REVSEPARATOR/o || /$LOG_FILESEPARATOR/o) {        if ($_ =~ LOG_REVSEPR || $_ =~ LOG_FILESEPR) {
   
                                 # End of a log entry.          # End of a log entry.
                                 my $revbranch = $rev;          my $revbranch = $rev;
                                 $revbranch =~ s/\.\d+$//;          $revbranch =~ s/\.\d+$//;
                                 print "$filename $rev Wanted: $revwanted ",  
                                     "Revbranch: $revbranch Branch: $branch ",  
                                     "Branchpoint: $branchpoint\n"  
                                     if ($verbose);  
   
                                 if ($revwanted eq '' && $branch ne ''          if ($revwanted eq '' && $branch ne '' && $branch eq $revbranch
                                     && $branch eq $revbranch || !defined($tag))              || !defined($tag))
                                 {          {
                                         print            $revwanted = $rev;
                                             "File revision $rev found for branch $branch\n"          }
                                             if ($verbose);  
                                         $revwanted = $rev;  
                                 }  
   
                                 if ($revwanted ne '' ? $rev eq $revwanted :          if ($revwanted ne ''
                                     $branchpoint ne '' ? $rev eq $branchpoint :              ? $rev eq $revwanted
                                     0 && ($rev eq $head))              : $branchpoint ne ''
                                 {    # Don't think head is needed here..                ? $rev eq $branchpoint
                                         print                : 0
                                             "File info $rev found for $filename\n"              && ($rev eq $head))
                                             if ($verbose);          {    # Don't think head is needed here..
                                         my @finfo =            my @finfo = ($rev, $date, $log, $author, $filename, $keywordsubst);
                                             ($rev, $date, $log, $author,            (my $name = $filename) =~ s%/.*%%;
                                                 $filename);            $fileinfo{$name} = [@finfo];
                                         my ($name);            $state = "done" if ($rev eq $revwanted);
                                         ($name = $filename) =~ s%/.*%%;          }
                                         $fileinfo{$name} = [@finfo];          $rev  = '';
                                         $state = "done" if ($rev eq $revwanted);          $date = '';
                                 }          $log  = '';
                                 $rev  = '';        } elsif ($date eq ''
                                 $date = '';                 && m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);|)
                                 $log  = '';        {
                         } elsif ($date eq ''          my $yr    = $1;
                             && m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);|          $yr      -= 1900 if ($yr > 100); # Damn 2-digit year routines :-)
                             )          $date     = timegm($6, $5, $4, $3, $2 - 1, $yr);
                         {          ($author) = /author: ([^;]+)/;
                                 my $yr = $1;          $state    = 'log';
           $log      = '';
           next;
         } elsif ($rev eq '' && /^revision (\d+(?:\.\d+)+).*$/) {
           $rev = $1;    # .*$ eats up the locker(lockers?) info, if any
           next;
         } else {
           $log .= $_;
         }
       }
   
                                 # damn 2-digit year routines :-)      if ($_ =~ LOG_FILESEPR) {
                                 if ($yr > 100) {        $state = "start";
                                         $yr -= 1900;        next;
                                 }      }
                                 $date =    }
                                     &Time::Local::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_FILESEPARATOR/o) {    my $linesread = $. || 0;
                         $state = "start";    close($fh);
                         next;  
                 }  
         }  
   
         if ($. == 0) {    if ($linesread == 0) {
                 fatal("500 Internal Error",      fatal('500 Internal Error',
                       'Failed to spawn GNU rlog on <em>"%s"</em>.  <p>Did you set the <b>$command_path</b> in your configuration file correctly ? (Currently "%s"',            'Failed to spawn rlog on <em>"%s"</em>',
                       join (", ", @files), $command_path);            htmlquote(join(', ', @files)));
         }    }
         close($fh);    return @unreadable;
 }  }
   
 sub readLog($;$) {  
         my ($fullname, $revision) = @_;  
         my ($symnames, $head, $rev, $br, $brp, $branch, $branchrev);  
         my $fh = do { local (*FH); };  
   
         if (defined($revision)) {  sub readLog($;$)
                 $revision = "-r$revision";  {
         } else {    my ($fullname, $revision) = @_;
                 $revision = "";    my ($symnames, $head, $rev, $br, $brp, $branch, $branchrev);
         }  
   
         undef %symrev;    undef %symrev;
         undef %revsym;    undef %revsym;
         undef @allrevisions;    undef @allrevisions;
         undef %date;    undef %date;
         undef %author;    undef %author;
         undef %state;    undef %state;
         undef %difflines;    undef %difflines;
         undef %log;    undef %log;
     $keywordsubstitution = '';
   
         print("Going to rlog '$fullname'\n") if ($verbose);    my $fh = do { local (*FH); };
         if (!open($fh, "-|")) {    # child    if (!open($fh, "-|")) {    # child
                 if ($revision ne '') {      $revision = defined($revision) ? "-r$revision" : '';
                         openOutputFilter();      if ($revision =~ /\./) {
                         exec($CMD{rlog}, $revision, $fullname) or exit -1;        # Normal revision, not a branch/tag name.
                 } else {        exec($CMD{rlog}, $revision, $fullname) or exit -1;
                         openOutputFilter();      } else {
                         exec($CMD{rlog}, $fullname) or exit -1;        exec($CMD{rlog}, $fullname) or exit -1;
                 }      }
         }    }
   
         while (<$fh>) {    my $curbranch = undef;
                 print if ($verbose);    while (<$fh>) {
                 if ($symnames) {      if ($symnames) {
                         if (/^\s+([^:]+):\s+([\d\.]+)/) {        if (/^\s+([^:]+):\s+([\d\.]+)/) {
                                 $symrev{$1} = $2;          $symrev{$1} = $2;
                         } else {          next;
                                 $symnames = 0;        } else {
                         }          $symnames = 0;
                 } elsif (/^head:\s+([\d\.]+)/) {        }
                         $head = $1;      }
                 } elsif (/^branch:\s+([\d\.]+)/) {      if (/^head:\s+([\d\.]+)/) {
                         $curbranch = $1;        $head = $1;
                 } elsif (/^symbolic names/) {      } elsif (/^branch:\s+([\d\.]+)/) {
                         $symnames = 1;        $curbranch = $1;
                 } elsif (/^-----/) {      } elsif (/^symbolic names/) {
                         last;        $symnames = 1;
                 }      } elsif (/^keyword substitution: (.+)$/) {
         }        $keywordsubstitution = $1;
         ($curbranch = $head) =~ s/\.\d+$// if (!defined($curbranch));      } elsif (/^-----/) {
         last;
       }
     }
     ($curbranch = $head) =~ s/\.\d+$// if (!defined($curbranch));
   
         # each log entry is of the form:    # each log entry is of the form:
         # ----------------------------    # ----------------------------
         # revision 3.7.1.1    # revision 3.7.1.1
         # date: 1995/11/29 22:15:52;  author: fenner;  state: Exp;  lines: +5 -3    # date: 1995/11/29 22:15:52;  author: fenner;  state: Exp;  lines: +5 -3
         # log info    # log info
         # ----------------------------    # ----------------------------
   
         # For a locked revision, the first line after the separator    # For a locked revision, the first line after the separator
         # becomes smth like    # becomes smth like
         # revision 9.19 locked by: vassilii;    # revision 9.19       locked by: vassilii;
   
         logentry:    logentry:
   
         while (!/$LOG_FILESEPARATOR/o) {    while ($_ !~ LOG_FILESEPR) {
                 $_ = <$fh>;      $_ = <$fh>;
                 last logentry if (!defined($_));    # EOF      last logentry if (!defined($_));    # EOF
                 print "R:", $_ if ($verbose);      if (/^revision (\d+(?:\.\d+)+)/) {
                 if (/^revision (\d+(?:\.\d+)+)/) {        $rev = $1;
                         $rev = $1;        unshift(@allrevisions, $rev);
                         unshift (@allrevisions, $rev);      } elsif ($_ =~ LOG_FILESEPR || $_ =~ LOG_REVSEPR) {
                 } elsif (/$LOG_FILESEPARATOR/o || /$LOG_REVSEPARATOR/o) {        next logentry;
                         next logentry;      } else {
                 } else {  
   
                         # The rlog output is syntactically ambiguous.  We must        # The rlog output is syntactically ambiguous.  We must
                         # have guessed wrong about where the end of the last log        # have guessed wrong about where the end of the last log
                         # message was.        # message was.
                         # Since this is likely to happen when people put rlog output        # Since this is likely to happen when people put rlog output
                         # in their commit messages, don't even bother keeping        # in their commit messages, don't even bother keeping
                         # these lines since we don't know what revision they go with        # these lines since we don't know what revision they go with
                         # any more.        # any more.
                         next logentry;        next logentry;
                 }      }
                 $_ = <$fh>;      $_ = <$fh>;
                 print "D:", $_ if ($verbose);      if (
                 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+-]+))?|
                     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;
                         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', $_);
       }
   
                         # damn 2-digit year routines :-)    line:
                         if ($yr > 100) {      while (<$fh>) {
                                 $yr -= 1900;        next line if (/^branches:\s/);
                         }        last line if ($_ =~ LOG_FILESEPR || $_ =~ LOG_REVSEPR);
                         $date{$rev} =        $log{$rev} .= $_;
                             &Time::Local::timegm($6, $5, $4, $3, $2 - 1, $yr);      }
                         $author{$rev}    = $7;    }
                         $state{$rev}     = $8;    close($fh);
                         $difflines{$rev} = $10;  
                 } else {  
                         fatal("500 Internal Error",  
                               'Error parsing RCS output: %s',  
                               $_);  
                 }  
                 line:  
   
                 while (<$fh>) {    @revorder = reverse sort { revcmp($a, $b) } @allrevisions;
                         print "L:", $_ if ($verbose);  
                         next line if (/^branches:\s/);  
                         last line  
                             if (/$LOG_FILESEPARATOR/o || /$LOG_REVSEPARATOR/o);  
                         $log{$rev} .= $_;  
                 }  
                 print "E:", $_ if ($verbose);  
         }  
         close($fh);  
         print "Done reading RCS file\n" if ($verbose);  
   
         @revorder = reverse sort { revcmp($a, $b) } @allrevisions;    #
         print "Done sorting revisions", join (" ", @revorder), "\n"    # HEAD is an artificial tag which is simply the highest tag number on the main
             if ($verbose);    # 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+)$/0.$1/;
   
         #    foreach $rev (@revorder) {
         # HEAD is an artificial tag which is simply the highest tag number on the main      if ($rev =~ /^(\S*)\.\d+$/ && $headrev eq $1) {
         # branch, unless there is a branch tag in the RCS file in which case it's the        $symrev{HEAD} = $rev;
         # highest revision on that branch.  Find it by looking through @revorder; it        last;
         # 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{HEAD} = $headrev) =~ s/\.\d+$// unless defined($symrev{HEAD});
         ($symrev{"MAIN"} = $headrev) =~ s/(\d+)$/0.$1/;  
   
         foreach $rev (@revorder) {    #
                 if ($rev =~ /^(\S*)\.\d+$/ && $headrev eq $1) {    # Now that we know all of the revision numbers, we can associate
                         $symrev{"HEAD"} = $rev;    # absolute revision numbers with all of the symbolic names, and
                         last;    # pass them to the form so that the same association doesn't have
                 }    # to be built then.
         }    #
         ($symrev{"HEAD"} = $headrev) =~ s/\.\d+$//    undef @branchnames;
             if (!defined($symrev{"HEAD"}));    undef %branchpoint;
         print "Done finding HEAD\n" if ($verbose);    undef $sel;
   
         #    foreach (reverse sort keys %symrev) {
         # Now that we know all of the revision numbers, we can associate      $rev = $symrev{$_};
         # absolute revision numbers with all of the symbolic names, and      if ($rev =~ /^((.*)\.)?\b0\.(\d+)$/) {
         # pass them to the form so that the same association doesn't have        push (@branchnames, $_);
         # to be built then.  
         #  
         undef @branchnames;  
         undef %branchpoint;  
         undef $sel;  
   
         foreach (reverse sort keys %symrev) {        #
                 $rev = $symrev{$_};        # A revision number of A.B.0.D really translates into
                 if ($rev =~ /^((.*)\.)?\b0\.(\d+)$/) {        # "the highest current revision on branch A.B.D".
                         push (@branchnames, $_);        #
         # 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;
         $rev = $head;
   
                         #        my $regex = '^' . quotemeta($branchrev) . '\b';
                         # A revision number of A.B.0.D really translates into        $regex = qr/$regex/;
                         # "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 = quotemeta $branchrev;  
                         $rev   = $head;  
   
                         foreach my $r (@revorder) {        foreach my $r (@revorder) {
                                 if ($r =~ /^${regex}\b/) {          if ($r =~ $regex) {
                                         $rev = $branchrev;            $rev = $branchrev;
                                         last;            last;
                                 }          }
                         }        }
                         next if ($rev eq "");        next if ($rev eq "");
   
                         if ($rev ne $head && $head ne "") {        if ($rev ne $head && $head ne "") {
                                 $branchpoint{$head} .= ", "          $branchpoint{$head} .= ', ' if ($branchpoint{$head});
                                     if ($branchpoint{$head});          $branchpoint{$head} .= $_;
                                 $branchpoint{$head} .= $_;        }
                         }      }
                 }      $revsym{$rev} .= ", " if ($revsym{$rev});
                 $revsym{$rev} .= ", " if ($revsym{$rev});      $revsym{$rev} .= $_;
                 $revsym{$rev} .= $_;      $sel .= sprintf("<option value=\"%s:%s\">%s</option>\n",
                 $sel .= "<option value=\"${rev}:${_}\">$_</option>\n";                      htmlquote($rev), (htmlquote($_)) x 2);
         }    }
         print "Done associating revisions with branches\n" if ($verbose);  
   
         my ($onlyonbranch, $onlybranchpoint);    my ($onlyonbranch, $onlybranchpoint);
         if ($onlyonbranch = $input{'only_with_tag'}) {    if ($onlyonbranch = $input{only_with_tag}) {
                 $onlyonbranch = $symrev{$onlyonbranch};      $onlyonbranch = $symrev{$onlyonbranch};
                 if ($onlyonbranch =~ s/\b0\.//) {      if ($onlyonbranch && $onlyonbranch =~ s/\b0\.//) {
                         ($onlybranchpoint = $onlyonbranch) =~ s/\.\d+$//;        ($onlybranchpoint = $onlyonbranch) =~ s/\.\d+$//;
                 } else {      } else {
                         $onlybranchpoint = $onlyonbranch;        $onlybranchpoint = $onlyonbranch;
                 }      }
   
                 if (!defined($onlyonbranch) || $onlybranchpoint eq "") {      if (!defined($onlyonbranch) || $onlybranchpoint eq "") {
                         fatal("404 Tag not found",        fatal("404 Tag not found", 'Tag "<code>%s</code>" is not defined.',
                               'Tag %s not defined',              $input{only_with_tag});
                               $input{'only_with_tag'});      }
                 }    }
         }  
   
         undef @revisions;    undef @revisions;
   
         foreach (@allrevisions) {    foreach (@allrevisions) {
                 ($br  = $_)  =~ s/\.\d+$//;      ($br  = $_)  =~ s/\.\d+$//;
                 ($brp = $br) =~ s/\.\d+$//;      ($brp = $br) =~ s/\.\d+$//;
                 next      next if ($onlyonbranch
                     if ($onlyonbranch && $br ne $onlyonbranch               && $br ne $onlyonbranch
                     && $_ ne $onlybranchpoint);               && $_  ne $onlybranchpoint);
                 unshift (@revisions, $_);      unshift(@revisions, $_);
         }    }
   
         if ($logsort eq "date") {    if ($logsort eq "date") {
   
                 # Sort the revisions in commit order an secondary sort on revision      # Sort the revisions in commit order an secondary sort on revision
                 # (secondary sort needed for imported sources, or the first main      # (secondary sort needed for imported sources, or the first main
                 # revision gets before the same revision on the 1.1.1 branch)      # revision gets before the same revision on the 1.1.1 branch)
                 @revdisplayorder =      @revdisplayorder =
                     sort { $date{$b} <=> $date{$a} || -revcmp($a, $b) }        sort { $date{$b} <=> $date{$a} || -revcmp($a, $b) } @revisions;
                     @revisions;    } elsif ($logsort eq "rev") {
         } elsif ($logsort eq "rev") {  
   
                 # Sort the revisions in revision order, highest first      # Sort the revisions in revision order, highest first
                 @revdisplayorder = reverse sort { revcmp($a, $b) } @revisions;      @revdisplayorder = reverse sort { revcmp($a, $b) } @revisions;
         } else {    } else {
   
                 # No sorting. Present in the same order as rlog / cvs log      # No sorting. Present in the same order as rlog / cvs log
                 @revdisplayorder = @revisions;      @revdisplayorder = @revisions;
         }    }
   
     return $curbranch;
 }  }
   
 sub printDiffLinks($$) {  
         my ($text, $url) = @_;  
         my @extra;  
   
         local $_;  sub getDiffLinks($$$)
         for ($DIFFTYPES{$defaultDiffType}{'colored'} ? qw(u) : qw(h)) {  {
                 my $f = $_ eq $defaultDiffType ? '' : $_;    my ($url, $mimetype, $isbin) = @_;
   
                 push @extra, &link(lc $DIFFTYPES{$_}{'descr'}, "$url&f=$f");    my @links = ();
         }    if (!$isbin) { # Offer ordinary diff only for non-binary files.
       push(@links, &link('preferred', $url));
         print &link($text, $url), ' (', join (', ', @extra), ')';      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"));
       }
     }
     return @links;
 }  }
   
 sub printLog($;$) {  
         my ($link, $br, $brp);  
         ($_, $link) = @_;  
         ($br  = $_)  =~ s/\.\d+$//;  
         ($brp = $br) =~ s/\.?\d+$//;  
         my ($isDead, $prev);  
   
         $link = 1 if (!defined($link));  sub printLog($$$;$$)
         $isDead = ($state{$_} eq "dead");  {
     # 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 "<p>\n";    print "<a name=\"rev$_\"></a>";
         if ($link && !$isDead) {    if (defined($revsym{$_})) {
                 my ($filename);      foreach my $sym (split(", ", $revsym{$_})) {
                 ($filename = $where) =~ s/^.*\///;        print '<a name="', htmlquote($sym), '"></a>';
                 my ($fileurl) = urlencode($filename);      }
                 print "<a name=\"rev$_\"></a>";    }
     if ($revsym{$br} && !defined($nameprinted{$br})) {
       foreach my $sym (split(", ", $revsym{$br})) {
         print '<a name="', htmlquote($sym), '"></a>';
       }
       $nameprinted{$br} = 1;
     }
   
                 if (defined($revsym{$_})) {    print "\n Revision <b>$_</b>";
                         foreach my $sym (split (", ", $revsym{$_})) {    if (/^1\.1\.1\.\d+$/) {
                                 print "<a name=\"$sym\"></a>";      print " <i>(vendor branch)</i>";
                         }    }
                 }  
   
                 if (defined($revsym{$br}) && $revsym{$br}    (my $filename = $where) =~ s|^.*/||;
                     && !defined($nameprinted{$br}))    my $fileurl   = uri_escape($filename);
                 {    undef $filename;
                         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) {    my $isDead = ($state{$_} eq 'dead');
                         print " / (";    if (!$isDead) {
                         &download_link($fileurl, $_, "download", $mimetype);  
                         print ")";  
                 }  
   
                 if (not $defaultTextPlain) {      print ': ', download_link($fileurl, $_, 'download', $mimetype);
                         print " / (";  
                         &download_link($fileurl, $_, "as text", "text/plain");  
                         print ")";  
                 }  
   
                 if (!$defaultViewable) {      my @vlinks = ();
                         print " / (";      push(@vlinks, display_link($fileurl, $_, 'text', 'text/plain'))
                         &download_link($fileurl, $_, "view",        unless $isbin;
                                 "text/x-cvsweb-markup");      push(@vlinks, display_link($fileurl, $_, 'markup', 'text/x-cvsweb-markup'))
                         print ")";        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 ($allow_annotate) {      unless ($isbin) {
                         print " - ";        print ' - ';
                         print &link(        if ($isSelected) {
                                 'annotate',          print '<b>[selected&nbsp;for&nbsp;diffs]</b>';
                                 sprintf(        } else {
                                         '%s/%s?annotate=%s%s', $scriptname,          print &link('select&nbsp;for&nbsp;diffs',
                                         urlencode($where),     $_,                      sprintf('%s?r1=%s%s#rev%s',
                                         $barequery                              $fileurl, $_, $barequery, $_));
                                 )        }
                         );      }
                 }    }
     print "<br />\n";
   
                 # Plus a select link if enabled, and this version isn't selected    print '<i>';
                 if ($allow_version_select) {    print scalar gmtime($date{$_}), ' UTC</i> (';
                         if ((!defined($input{"r1"}) || $input{"r1"} ne $_)) {    print readableTime(time() - $date{$_}, 1), ' ago)';
                                 print " - ";    print ' by <i>', htmlquote($author{$_}), "</i><br />\n";
                                 print &link(  
                                         '[select for diffs]',  
                                         sprintf(  
                                                 '%s?r1=%s%s', $scriptwhere,  
                                                 $_,           $barequery  
                                         )  
                                 );  
                         } else {  
                                 print " - <b>[selected]</b>";  
                         }  
                 }  
         } else {  
                 print "Revision <b>$_</b>";  
         }  
   
         if (/^1\.1\.1\.\d+$/) {    printf("Branches: %s<br />\n", link_tags($revsym{$br})) if $revsym{$br};
                 print " <i>(vendor branch)</i>";    printf("CVS tags: %s<br />\n", link_tags($revsym{$_}))  if $revsym{$_};
         }    printf("Branch point for: %s<br />\n", link_tags($branchpoint{$_}))
         if (defined @mytz) {      if $branchpoint{$_};
                 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    # Find the previous revision
         my @prevrev = split (/\./, $_);    my $prev;
         do {    my @prevrev = split(/\./, $_);
                 if (--$prevrev[$#prevrev] <= 0) {    do {
       if (--$prevrev[$#prevrev] <= 0) {
   
                         # If it was X.Y.Z.1, just make it X.Y        # If it was X.Y.Z.1, just make it X.Y
                         pop (@prevrev);        pop (@prevrev);
                         pop (@prevrev);        pop (@prevrev);
                 }      }
                 $prev = join (".", @prevrev);      $prev = join (".", @prevrev);
         } until (defined($date{$prev}) || $prev eq "");    } until (defined($date{$prev}) || $prev eq "");
   
         if ($prev ne "") {    if ($isDead) {
                 if ($difflines{$_}) {      print "<b><i>FILE REMOVED</i></b><br />\n";
                         print    } else {
                             "<br>Changes since <b>$prev: $difflines{$_} lines</b>";      my %diffrev = ();
                 }      $diffrev{$_} = 1;
         }      $diffrev{""} = 1;
       my $diff = 'Diff to:';
       my $printed = 0;
   
         if ($isDead) {      #
                 print "<br><b><i>FILE REMOVED</i></b>\n";      # Offer diff to previous revision
         } elsif ($link) {      if ($prev) {
                 my %diffrev = ();        $diffrev{$prev} = 1;
                 $diffrev{$_} = 1;        my $url =
                 $diffrev{""} = 1;          sprintf('%s.diff?r1=%s;r2=%s%s', $fileurl, $prev, $_, $barequery);
                 print '<br>';        if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
                 my $diff = 'Diff';          print $diff, ' previous ', $prev, ': ', join(', ', @dlinks);
           $diff = ';'; $printed = 1;
         }
       }
   
                 #      #
                 # Offer diff to previous revision      # Plus, if it's on a branch, and it's not a vendor branch,
                 if ($prev) {      # offer a diff with the branch point.
                         $diffrev{$prev} = 1;      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;
         }
       }
   
                         my $url =      #
                             sprintf('%s.diff?r1=%s&r2=%s%s', $scriptwhere,      # Plus, if it's on a branch, and it's not a vendor branch,
                                 $prev, $_, $barequery);      # 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);
   
                         print $diff, " to previous ";        for ($i = 0; $i < $#revorder && $revorder[$i] ne $_; $i++) {
                         $diff = '';        }
                         printDiffLinks($prev, $url);        my @tmp2 = split(/\./, $_);
                 }        for ($nextmain = ""; $i > 0; $i--) {
           my $next = $revorder[$i - 1];
           my @tmp1 = split(/\./, $next);
   
                 #          if (@tmp1 < @tmp2) {
                 # Plus, if it's on a branch, and it's not a vendor branch,            $nextmain = $next;
                 # offer a diff with the branch point.            last;
                 if ($revsym{$brp} && !/^1\.1\.1\.\d+$/          }
                     && !defined($diffrev{$brp}))  
                 {  
                         my $url =  
                             sprintf('%s.diff?r1=%s&r2=%s%s', $scriptwhere, $brp,  
                                 $_, $barequery);  
   
                         print $diff, " to branchpoint ";          # Only the highest version on a branch should have
                         $diff = '';          # a diff for the "next MAIN".
                         printDiffLinks($brp, $url);          last
                 }            if (@tmp1 - 1 <= @tmp2
             && join (".", @tmp1[0 .. $#tmp1 - 1]) eq
             join (".", @tmp2[0 .. $#tmp1 - 1]));
         }
   
                 #        if (!defined($diffrev{$nextmain})) {
                 # Plus, if it's on a branch, and it's not a vendor branch,          $diffrev{$nextmain} = 1;
                 # offer to diff with the next revision of the higher branch.          my $url = sprintf('%s.diff?r1=%s;r2=%s%s',
                 # (e.g. change gets committed and then brought            $fileurl, $nextmain, $_, $barequery);
                 # over to -stable)          if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
                 if (/^\d+\.\d+\.\d+/ && !/^1\.1\.1\.\d+$/) {            print $diff, ' next MAIN ', $nextmain, ': ', join(', ', @dlinks);
                         my ($i, $nextmain);            $diff = ';'; $printed = 1;
           }
         }
       }
   
                         for ($i = 0 ; $i < $#revorder && $revorder[$i] ne $_ ;      # Plus if user has selected only r1, then present a link
                             $i++)      # to make a diff to that revision
                         {      if (defined($input{r1}) && !defined($diffrev{$input{r1}})) {
                         }        $diffrev{$input{r1}} = 1;
                         my @tmp2 = split (/\./, $_);        my $url = sprintf('%s.diff?r1=%s;r2=%s%s',
                         for ($nextmain = "" ; $i > 0 ; $i--) {          $fileurl, $input{r1}, $_, $barequery);
                                 my $next = $revorder[$i - 1];        if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
                                 my @tmp1 = split (/\./, $next);          print $diff, ' selected ', $input{r1}, ': ', join(', ', @dlinks);
           $diff = ';'; $printed = 1;
         }
       }
   
                                 if (@tmp1 < @tmp2) {      print "<br />\n" if $printed;
                                         $nextmain = $next;    }
                                         last;  
                                 }  
   
                                 # Only the highest version on a branch should have    if ($prev ne "" && $difflines{$_}) {
                                 # a diff for the "next main".      printf "Changes since revision %s: %s lines<br />\n",
                                 last        htmlquote($prev), htmlquote($difflines{$_});
                                     if (@tmp1 - 1 <= @tmp2    }
                                     && join (".", @tmp1[0 .. $#tmp1 - 1]) eq  
                                     join (".", @tmp2[0 .. $#tmp1 - 1]));  
                         }  
   
                         if (!defined($diffrev{$nextmain})) {    print "<pre class=\"log\">\n";
                                 $diffrev{$nextmain} = 1;    print &htmlify($log{$_}, $allow_log_extra);
     print "</pre>\n";
   }
   
                                 my $url =  
                                     sprintf('%s.diff?r1=%s&r2=%s%s',  
                                         $scriptwhere, $nextmain, $_,  
                                         $barequery);  
   
                                 print $diff, " next main ";  sub doLog($)
                                 $diff = '';  {
                                 printDiffLinks($nextmain, $url);    my ($fullname) = @_;
                         }  
                 }  
   
                 # Plus if user has selected only r1, then present a link    my $curbranch = readLog($fullname);
                 # to make a diff to that revision  
                 if (defined($input{"r1"}) && !defined($diffrev{$input{"r1"}})) {  
                         $diffrev{$input{"r1"}} = 1;  
   
                         my $url =    html_header("CVS log for $where");
                             sprintf('%s.diff?r1=%s&r2=%s%s', $scriptwhere,  
                                 $input{'r1'}, $_, $barequery);  
   
                         print $diff, " to selected ";    my $upwhere = $where;
                         $diff = '';    (my $filename = $where) =~ s|^.*/||;
                         printDiffLinks($input{'r1'}, $url);    my $backurl = "./$query#" . uri_escape($filename);
                 }    if ($where =~ m|^(.*?)((?<=/)Attic/)?[^/]+$|) {
       $upwhere = $1;
       $backurl = ".$backurl" if $2; # skip over Attic
     }
   
         }    my $isbin = $keywordsubstitution =~ /b/;
         print "\n</p>\n<pre>\n";    my $mimetype = getMimeType($filename, $isbin);
         print &htmlify($log{$_}, $allow_log_extra);  
         print "</pre>\n";  
 }  
   
 sub doLog($) {    print "<p>\n ";
         my ($fullname) = @_;    print &link($backicon, $backurl), " <b>Up to ",
         my ($diffrev, $upwhere, $filename, $backurl);      &clickablePath($upwhere, 1), "</b>\n</p>\n";
     print "<p>\n ";
     print &link('Request diff between arbitrary revisions', '#diff');
     print "\n</p>\n<hr />\n";
   
         readLog($fullname);    print "<p>\n";
   
         html_header("CVS log for $where");    my $explain = $isbin ? ' (i.e.: CVS considers this a binary file)' : '';
         ($upwhere  = $where) =~ s|(Attic/)?[^/]+$||;    print "Keyword substitution: $keywordsubstitution$explain<br />\n";
         ($filename = $where) =~ s|^.*/||;    if ($curbranch) {
         $backurl = $scriptname . "/" . urlencode($upwhere) . $query;      print "Default branch: ", ($revsym{$curbranch} || $curbranch);
         print "<p>\n ";    } else {
         print &link($backicon, "$backurl#$filename"), " <b>Up to ",      print "No default branch";
             &clickablePath($upwhere, 1), "</b>\n</p>\n";    }
         print "<p>\n ";    print "<br />\n";
         print &link('Request diff between arbitrary revisions', '#diff');  
         print "\n</p>\n<hr noshade>\n";  
   
         print "<p>\n";    print 'Current tag: ', htmlquote($input{only_with_tag}), "<br />\n"
         if ($curbranch) {      if $input{only_with_tag};
                 print "Default branch: ", ($revsym{$curbranch} || $curbranch);    print "</p>\n";
         } else {  
                 print "No default branch";  
         }  
         print "<br>\n";  
   
         if ($input{only_with_tag}) {    undef %nameprinted;
                 print "Current tag: $input{only_with_tag}<br>\n";  
         }  
         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;
     }
   
         for (my $i = 0 ; $i <= $#revdisplayorder ; $i++) {    printf(<<EOF, $scriptwhere);
                 print "<hr size=\"1\" noshade>\n";  <hr />
                 printLog($revdisplayorder[$i]);  <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
   
         print "<hr noshade>\n<p>\n";    foreach (@stickyvars) {
         print "<a name=\"diff\">\n";      printf("<input type=\"hidden\" name=\"%s\" value=\"%s\" />\n",
         print "This form allows you to request diff's between any two\n";             $_, htmlquote($input{$_}))
         print "revisions of a file.  You may select a symbolic revision\n";        if (defined($input{$_}) &&
         print "name using the selection box or you may type in a numeric\n";            (!defined($DEFAULTVALUE{$_}) || $input{$_} ne $DEFAULTVALUE{$_}));
         print "name using the type-in text box.\n";    }
         print "</a>\n</p>\n";  
         print  
             "<form method=\"get\" action=\"${scriptwhere}.diff\" name=\"diff_select\">\n";  
   
         foreach (@stickyvars) {    print <<EOF;
                 printf('<input type="hidden" name="%s" value="%s">', $_,  <table summary="Diff between arbitrary revisions">
                     $input{$_})  <tr>
                     if (defined($input{$_})  <td class="opt-label">
                     && ((!defined($DEFAULTVALUE{$_})  <label for="r1" accesskey="1">Diffs between</label>
                     || $input{$_} ne $DEFAULTVALUE{$_}) && $input{$_} ne ""));  </td>
         }  <td class="opt-value">
         print "<table style=\"border: none\">\n<tr>\n";  <select id="r1" name="r1">
         print "<td align=\"right\">";  <option value="text" selected="selected">Use Text Field</option>
         print "<label for=\"r1\" accesskey=\"1\">Diffs between </label>\n";  EOF
         print "<select id=\"r1\" name=\"r1\">\n";    print $sel, "</select>\n";
         print "<option value=\"text\" selected>Use Text Field</option>\n";  
         print $sel;  
         print "</select>\n";  
         $diffrev = $revdisplayorder[$#revdisplayorder];  
         $diffrev = $input{"r1"} if (defined($input{"r1"}));  
         print  
             "<input type=\"text\" size=\"$inputTextSize\" name=\"tr1\" value=\"$diffrev\" onchange=\"this.form.r1.selectedIndex=0\"></td>\n";  
         print "<td><br></td>\n</tr>\n";  
         print "<tr>\n<td align=\"right\">";  
         print "<label for=\"r2\" accesskey=\"2\">and </label>\n";  
         print "<select id=\"r2\" name=\"r2\">\n";  
         print "<option value=\"text\" selected>Use Text Field</option>\n";  
         print $sel;  
         print "</select>\n";  
         $diffrev = $revdisplayorder[0];  
         $diffrev = $input{"r2"} if (defined($input{"r2"}));  
         print  
             "<input type=\"text\" size=\"$inputTextSize\" name=\"tr2\" value=\"$diffrev\" onchange=\"this.form.r2.selectedIndex=0\"></td>\n";  
         print "<td><input type=\"submit\" value=\"  Get Diffs  \" accesskey=\"G\"></td>\n";  
         print "</tr>\n</table>\n";  
         print "</form>\n";  
         print "<hr noshade>\n";  
         print "<form method=\"get\" action=\"$scriptwhere\">\n";  
         print "<table style=\"border: none\">\n";  
         print "<tr>\n<td align=\"right\">";  
         print "<label for=\"f\" accesskey=\"D\">Preferred Diff type:";  
         print "</label></td>\n";  
         print "<td>";  
         printDiffSelect($use_java_script);  
         print "</td>\n<td></td>\n</tr>\n";  
   
         if (@branchnames) {    my $diffrev = defined($input{r1}) ?
                 print "<tr>\n<td align=\"right\">";      $input{r1} : $revdisplayorder[$#revdisplayorder];
                 print "<label for=\"only_with_tag\" accesskey=\"B\">";  
                 print "View only Branch:</label></td>\n";  
                 print "<td>";  
                 print "<a name=\"branch\"></a>\n";  
                 print "<select id=\"only_with_tag\" name=\"only_with_tag\"";  
                 print " onchange=\"this.form.submit()\"" if $use_java_script;  
                 print ">\n";  
                 print "<option value=\"\"";  
                 print " selected"  
                     if (defined($input{"only_with_tag"})  
                     && $input{"only_with_tag"} eq "");  
                 print ">Show all branches</option>\n";  
   
                 foreach (reverse sort @branchnames) {    printf(<<EOF, $diffrev);
                         print "<option";  <input type="text" size="12" name="tr1" value="%s" onchange="this.form.r1.selectedIndex=0" />
                         print " selected"  </td>
                             if (defined($input{"only_with_tag"})  <td></td>
                             && $input{"only_with_tag"} eq $_);  </tr>
                         print ">${_}</option>\n";  <tr>
                 }  <td class="opt-label">
                 print "</select></td>\n<td></td>\n</tr>\n";  <label for="r2" accesskey="2">and</label>
         }  </td>
   <td class="opt-value">
   <select id="r2" name="r2">
   <option value="text" selected="selected">Use Text Field</option>
   EOF
     print $sel, "</select>\n";
   
         foreach (@stickyvars) {    $diffrev = defined($input{r2}) ? $input{r2} : $revdisplayorder[0];
                 next if ($_ eq "f");  
                 next if ($_ eq "only_with_tag");    printf(<<EOF, $diffrev, $scriptwhere);
                 next if ($_ eq "logsort");  <input type="text" size="12" name="tr2" value="%s" onchange="this.form.r2.selectedIndex=0" />
                 print "<input type=\"hidden\" name=\"$_\" value=\"$input{$_}\">\n"  </td>
                     if (defined($input{$_})  <td><input type="submit" value="Get Diffs" accesskey="G" /></td>
                     && (!defined($DEFAULTVALUE{$_})  </tr>
                     || $input{$_} ne $DEFAULTVALUE{$_}) && $input{$_} ne "");  </table>
         }  </fieldset>
         print "<tr>\n<td align=\"right\">";  </form>
         print "<a name=\"logsort\"></a>\n";  <form method="get" action="%s">
         print "<label for=\"logsort\" accesskey=\"L\">Sort log by:";  <fieldset>
         print "</label></td>\n<td>";  <legend>Log view options</legend>
         printLogSortSelect($use_java_script);  <table summary="Log view options">
         print "</td>\n";  <tr>
         print "<td><input type=\"submit\" value=\"  Set  \" accesskey=\"S\"></td>\n";  <td class="opt-label">
         print "</tr>\n</table>\n";  <label for="f" accesskey="D">Preferred diff type:</label>
         print "</form>\n";  </td>
         html_footer();  <td class="opt-value">
   EOF
     printDiffSelect();
     print <<EOF;
   </td>
   <td></td>
   </tr>
   EOF
   
     if (@branchnames) {
   
       print <<EOF;
   <tr>
   <td class="opt-label">
   <label for="only_with_tag" accesskey="B">View only branch:</label>
   </td>
   <td class="opt-value">
   <a name="branch">
   <select id="only_with_tag" name="only_with_tag">
   EOF
   
       my @tmp = ();
       my $selfound = 0;
       foreach (reverse sort @branchnames) {
         my $selected =
           (defined($input{only_with_tag}) && $input{only_with_tag} eq $_);
         $selfound ||= $selected;
         push(@tmp, sprintf('<option%s>%s</option>',
                            $selected ? ' selected="selected"' : '',
                            htmlquote($_)));
       }
       printf("<option value=\"\"%s>Show all branches</option>\n",
              $selfound ? '' : ' selected="selected"');
       print join("\n", @tmp);
   
       print <<EOF
   </select>
   </a>
   </td>
   <td></td>
   </tr>
   EOF
     }
   
     print <<EOF;
   <tr>
   <td class="opt-label">
   <label for="logsort" accesskey="L">Sort log by:</label>
   </td>
   <td>
   EOF
     printLogSortSelect();
     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($$$$) {  
         my $j;  
         my ($leftColRef, $rightColRef, $leftRow, $rightRow) = @_;  
   
         if (!defined($state)) {  sub flush_diff_rows($$$$)
                 return;  {
         }    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>\n<td class=\"diff-removed\">&nbsp;@$leftColRef[$j]</td>\n";  
                         print  
                             "<td class=\"diff-empty\">&nbsp;</td>\n</tr>\n";  
                 }  
         } elsif ($state eq "PreChange") {    # state eq "PreChange"  
                     # we got removes with subsequent adds  
   
                 for ($j = 0 ; $j < $leftRow || $j < $rightRow ; $j++)    if ($state eq "PreChangeRemove") {    # we just got remove-lines before
                 {    # dump out both cols      for (my $j = 0; $j < $leftRow; $j++) {
                         print "<tr>\n";        printf(<<EOF, spacedHtmlText(@$leftColRef[$j]));
                         if ($j < $leftRow) {  <tr>
                                 print   <td class="diff diff-removed">&nbsp;%s</td>
                                     "<td class=\"diff-changed\">&nbsp;@$leftColRef[$j]</td>";   <td class="diff diff-empty">&nbsp;</td>
                         } else {  </tr>
                                 print  EOF
                                     "<td class=\"diff-changed-missing\">&nbsp;</td>";      }
                         }    } elsif ($state eq "PreChange") {     # state eq "PreChange"
                         print "\n";                                          # we got removes with subsequent adds
         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) {          if ($j < $rightRow) {
                                 print            print '<td class="diff diff-changed">&nbsp;' .
                                     "<td class=\"diff-changed\">&nbsp;@$rightColRef[$j]</td>";              spacedHtmlText(@$rightColRef[$j]) . '</td>';
                         } else {          } else {
                                 print            print '<td class="diff diff-changed-missing">&nbsp;</td>';
                                     "<td class=\"diff-changed-missing\">&nbsp;</td>";          }
                         }          print "\n</tr>\n";
                         print "\n</tr>\n";        }
                 }    }
         }  
 }  }
   
 ##  
 # Function to generate Human readable diff-files  
 # human_readable_diff(String revision_to_return_to);  
 ##  
 sub human_readable_diff($) {  
         my ($difftxt, $where_nd, $filename, $pathname, $scriptwhere_nd);  
         my ($fh, $rev) = @_;  
         my ($date1, $date2, $r1d, $r2d, $r1r, $r2r, $rev1, $rev2, $sym1, $sym2);  
         my (@rightCol, @leftCol);  
   
         ($where_nd       = $where)       =~ s/.diff$//;  #
         ($filename       = $where_nd)    =~ s/^.*\///;  # Generates "human readable", HTMLified diffs.
         ($pathname       = $where_nd)    =~ s/(Attic\/)?[^\/]*$//;  #
         ($scriptwhere_nd = $scriptwhere) =~ s/.diff$//;  sub human_readable_diff($$)
   {
     my ($fh, $rev) = @_;
   
         navigateHeader($scriptwhere_nd, $pathname, $filename, $rev, "diff");    (my $where_nd       = $where)       =~ s|\.diff$||;
     (my $filename       = $where_nd)    =~ s|^.*/||;
     (my $pathname       = $where_nd)    =~ s|((?<=/)Attic/)?[^/]*$||;
     (my $scriptwhere_nd = $scriptwhere) =~ s|\.diff$||;
   
         # Read header to pick up read revision and date, if possible    navigateHeader($scriptwhere_nd, $pathname, $filename, $rev, 'diff');
         while (<$fh>) {  
                 ($r1d, $r1r) = /\t(.*)\t(.*)$/ if (/^--- /);  
                 ($r2d, $r2r) = /\t(.*)\t(.*)$/ if (/^\+\+\+ /);  
                 last if (/^\+\+\+ /);  
         }  
   
         if (defined($r1r) && $r1r =~ /^(\d+\.)+\d+$/) {    # Read header to pick up read revision and date, if possible.
                 $rev1  = $r1r;  
                 $date1 = $r1d;  
         }  
         if (defined($r2r) && $r2r =~ /^(\d+\.)+\d+$/) {  
                 $rev2  = $r2r;  
                 $date2 = $r2d;  
         }  
   
         print    my ($r1d, $r1r, $r2d, $r2r);
             "<h3 style=\"text-align: center\">Diff for /$where_nd between version $rev1 and $rev2</h3>\n",    while (<$fh>) {
             # Using style=\"border: none\" here breaks NS 4.x badly...      ($r1d, $r1r) = /\t(.*)\t(.*)$/ if (/^--- /);
             "<table border=\"0\" cellspacing=\"0\" cellpadding=\"0\" width=\"100%\">\n",      ($r2d, $r2r) = /\t(.*)\t(.*)$/ if (/^\+\+\+ /);
             "<tr style=\"background-color: #ffffff\">\n", "<th width=\"50%\" valign=\"top\">",      last if (/^\+\+\+ /);
             "version $rev1";    }
         print ", $date1"         if (defined($date1));  
         print "<br>Tag: $sym1\n" if ($sym1);  
         print "</th>\n", "<th width=\"50%\" valign=\"top\">", "version $rev2";  
         print ", $date2"         if (defined($date2));  
         print "<br>Tag: $sym2\n" if ($sym1);  
         print "</th>\n";  
   
         my $leftRow  = 0;    my ($rev1, $date1);
         my $rightRow = 0;    if (defined($r1r) && $r1r =~ /^(\d+\.)+\d+$/) {
         my ($oldline, $newline, $funname, $diffcode, $rest);      $rev1  = $r1r;
       $date1 = $r1d;
     }
     my ($rev2, $date2);
     if (defined($r2r) && $r2r =~ /^(\d+\.)+\d+$/) {
       $rev2  = $r2r;
       $date2 = $r2d;
     }
     $rev1  = $input{r1}      unless defined($rev1);
     $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) : '';
   
         # Process diff text    my $link = uri_escape($filename) . ($query ? "$query;" : '?');
   
         # prefetch several lines    # Using <table style=\"border: none\" here breaks NS 4.x badly...
         my @buf = head($fh);    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 %d = scan_directives(@buf);    # Process diff text
     # prefetch several lines
     my @buf = head($fh);
     my %d = scan_directives(@buf);
   
         while (@buf || !eof($fh)) {    my $leftRow  = 0;
                 $difftxt = @buf ? shift @buf : <$fh>;    my $rightRow = 0;
     my ($difftxt, @rightCol, @leftCol, $oldline, $newline, $funname);
   
                 if ($difftxt =~ /^@@/) {    $link .= 'content-type=text%2Fx-cvsweb-markup;';
                         ($oldline, $newline, $funname) =    $link .= 'ln=1;' unless ($link =~ /\?.*\bln=1\b/);
                             $difftxt =~ /@@ \-([0-9]+).*\+([0-9]+).*@@(.*)/;  
                         $funname = htmlquote($funname);  
                         $funname =~ s/\s/&nbsp;/go;  
                         print  
                             "<tr class=\"diff-heading\">\n<td width=\"50%\">";  
                         print  
                             "<table width=\"100%\" border=\"1\" cellpadding=\"5\">\n<tr>\n<td><b>Line&nbsp;$oldline</b>";  
                         print  
                             "&nbsp;<span style=\"font-size: smaller\">$funname</span></td>\n</tr>\n</table>";  
                         print "</td>\n<td width=\"50%\">";  
                         print  
                             "<table width=\"100%\" border=\"1\" cellpadding=\"5\">\n<tr>\n<td><b>Line&nbsp;$newline</b>";  
                         print  
                             "&nbsp;<span style=\"font-size: smaller\">$funname</span></td>\n</tr>\n</table>\n";  
                         print "</td>\n";  
                         $state    = "dump";  
                         $leftRow  = 0;  
                         $rightRow = 0;  
                 } else {  
                         ($diffcode, $rest) = $difftxt =~ /^([-+ ])(.*)/;  
                         $_ = spacedHtmlText($rest, $d{'tabstop'});  
   
                         #########    while (@buf || !eof($fh)) {
                         # little state machine to parse unified-diff output (Hen, zeller@think.de)      $difftxt = @buf ? shift @buf : <$fh>;
                         # 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")        ($oldline, $newline, $funname) =
                                 { # 'change' never begins with '+': just dump out value          $difftxt =~ /@@ \-([0-9]+).*\+([0-9]+).*@@(.*)/;
                                         print        $funname = htmlquote($funname);
                                             "<tr>\n<td class=\"diff-empty\">&nbsp;</td>\n<td class=\"diff-added\">&nbsp;$_</td>\n</tr>\n";        $funname =~ s/\s/&nbsp;/go;
                                 } else {    # we got minus before        $funname &&= "&nbsp;<span style=\"font-size: smaller\">$funname</span>";
                                         $state = "PreChange";        my $ol = $oldline || 1;
                                         $rightCol[$rightRow++] = $_;        my $nl = $newline || 1;
                                 }  
                         } elsif ($diffcode eq '-') {  
                                 $state = "PreChangeRemove";  
                                 $leftCol[$leftRow++] = $_;  
                         } else {    # empty diffcode  
                                 flush_diff_rows \@leftCol, \@rightCol, $leftRow,  
                                     $rightRow;  
                                 print "<tr>\n<td class=\"diff-same\">&nbsp;$_</td>\n<td class=\"diff-same\">&nbsp;$_</td>\n</tr>\n";  
                                 $state    = "dump";  
                                 $leftRow  = 0;  
                                 $rightRow = 0;  
                         }  
                 }  
         }  
         close($fh);  
   
         flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;        print <<EOF;
   <tr>
   <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 is empty if we didn't have any change        $state    = "dump";
         if (!$state) {        $leftRow  = 0;
                 print "<tr>\n<td colspan=\"2\">&nbsp;</td>\n</tr>\n";        $rightRow = 0;
                 print "<tr class=\"diff-empty\">\n";      } else {
                 print        my ($diffcode, $rest) = $difftxt =~ /^([-+ ])(.*)/;
                     "<td colspan=\"2\" align=\"center\"><b>- No viewable change -</b></td>\n</tr>\n";        $diffcode = '' unless defined($diffcode);
         }        $_ = $rest;
         print "</table>\n";  
   
         print "<hr style=\"width: 100%\" noshade>\n";        #########
         print "<form method=\"get\" action=\"${scriptwhere}\">\n";        # little state machine to parse unified-diff output (Hen, zeller@think.de)
         print "<table style=\"border: none\">\n<tr>\n<td>\n";        # 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
         ##########
   
         # print legend        if ($diffcode eq '+') {
         print "<table border=\"1\">\n<tr>\n<td>";          if ($state eq "dump")
         print "Legend:<br><table style=\"border: none\" cellspacing=\"0\" cellpadding=\"1\">\n";          {    # 'change' never begins with '+': just dump out value
         print            $_ = spacedHtmlText($rest, $d{tabstop});
             "<tr>\n<td align=\"center\" class=\"diff-removed\">Removed from v.$rev1</td>\n<td class=\"diff-empty\">&nbsp;</td>\n</tr>\n";            printf(<<EOF, $_);
         print  <tr>
             "<tr class=\"diff-changed\">\n<td align=\"center\" colspan=\"2\">changed lines</td>\n</tr>\n";   <td class="diff diff-empty">&nbsp;</td>
         print   <td class="diff diff-added">&nbsp;%s</td>
             "<tr>\n<td class=\"diff-empty\">&nbsp;</td>\n<td align=\"center\" class=\"diff-added\">Added in v.$rev2</td>\n</tr>\n";  </tr>
         print "</table>\n</td>\n</tr>\n</table>\n</td>\n<td>";  EOF
           } else {    # we got minus before
             $state = "PreChange";
             $rightCol[$rightRow++] = $_;
           }
         } elsif ($diffcode eq '-') {
           $state = "PreChangeRemove";
           $leftCol[$leftRow++] = $_;
         } else {    # empty diffcode
           flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;
           $_ = 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);
   
         # Print format selector    flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;
         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 "</td>\n";  
   
         print "</tr>\n</table>\n";    # state is empty if we didn't have any change
         print "</form>\n";    if (!$state) {
       print <<EOF;
   <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
     }
   
     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();
     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
 }  }
   
 sub navigateHeader($$$$$) {  
         my ($swhere, $path, $filename, $rev, $title) = @_;  
         $swhere = "" if ($swhere eq $scriptwhere);  
         $swhere = './' . urlencode($filename) if ($swhere eq "");  
   
         # TODO: this should be moved into external CSS file.  #
         my $css = '';  # The passed in $path and $filename should not be URI escaped, and $swhere
         if ($title eq 'diff') {  # *should* be.
             $css = "  #
 <style type=\"text/css\">  sub navigateHeader($$$$$;$)
 .diff-heading {  {
   background-color: $diffcolorHeading;    my ($swhere, $path, $filename, $rev, $title, $moddate) = @_;
 }    $swhere = "" if ($swhere eq $scriptwhere);
 .diff-same {    $swhere = './' . uri_escape($filename) if ($swhere eq "");
   font-family: $difffontface;  
   font-size: smaller;  
 }  
 .diff-empty {  
   background-color: $diffcolorEmpty;  
 }  
 .diff-added {  
   background-color: $diffcolorAdd;  
   font-family: $difffontface;  
   font-size: smaller;  
 }  
 .diff-removed {  
   background-color: $diffcolorRemove;  
   font-family: $difffontface;  
   font-size: smaller;  
 }  
 .diff-changed {  
   background-color: $diffcolorChange;  
   font-family: $difffontface;  
   font-size: smaller;  
 }  
 .diff-changed-missing {  
   background-color: $diffcolorDarkChange;  
 }  
 </style>";  
         }  
   
         print <<EOF;    my $qfile = htmlquote($filename);
     my $qpath = htmlquote($path);
     my $trev  = $rev ? " - " . htmlquote($rev) : '';
   
     http_header('text/html', $moddate);
   
     print <<EOF;
 $HTML_DOCTYPE  $HTML_DOCTYPE
 <html>  <html>
 <head>  <head>
 <title>$path$filename - $title - $rev</title>$css  <title>$qpath$qfile - $title$trev</title>
 $HTML_META</head>  $HTML_META$CSS</head>
 $body_tag_for_src  <body class="src">
 <table width="100%" style="border: none; background-color: $navigationHeaderColor" cellspacing="0" cellpadding="1">  <table class="navigate-header" width="100%" summary="Navigation">
 <tr valign="bottom"><td>   <tr>
     <td>
 EOF  EOF
   
         print &link($backicon, "$swhere$query#rev$rev");    my $frag = '';
         print "<b>Return to ", &link($filename, "$swhere$query#rev$rev"),    if ($rev) {
             " CVS log";      $frag  = '#';
         print "</b> $fileicon</td>";      $frag .= 'rev' if ($rev =~ /\./);  # Normal revision: prefix with "rev".
       $frag .= $rev;                     # Append revision/branch/tag.
     }
     my $backurl = "$swhere$query$frag";
   
         print "<td align=\"right\">$diricon <b>Up to ",    print &link($backicon, $backurl);
           &clickablePath($path, 1),    printf '<b>Return to %s CVS log', &link($qfile, $backurl);
             "</b></td>";    print "</b> $fileicon</td>";
         print "</tr></table>";  
     printf(<<EOF, $diricon, &clickablePath($path, 1));
     <td style="text-align: right">%s <b>Up to %s</b></td>
    </tr>
   </table>
   EOF
 }  }
   
 sub plural_write($$) {  
         my ($num, $text) = @_;  
         if ($num != 1) {  
                 $text .= "s";  
         }  
   
         if ($num > 0) {  sub plural_write($$)
                 return join (' ', $num, $text);  {
         } else {    my ($num, $text) = @_;
                 return "";    if ($num != 1) {
         }      $text .= "s";
     }
   
     if ($num > 0) {
       return join (' ', $num, $text);
     } else {
       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 = (    my %desc = (
                 1,        'second', 60,     'minute', 3600,    'hour',                1        => 'second',
                 86400,    'day',    604800, 'week',   2628000, 'month',                60       => 'minute',
                 31536000, 'year'                3600     => 'hour',
         );                86400    => 'day',
         my @breaks = sort { $a <=> $b } keys %desc;                604800   => 'week',
         $i = 0;                2628000  => 'month',
                 31536000 => 'year'
                );
   
         while ($i <= $#breaks && $secs >= 2 * $breaks[$i]) {    my @breaks = sort { $a <=> $b } keys %desc;
                 $i++;    my $i = 0;
         }  
         $i--;  
         $break  = $breaks[$i];  
         $retval = plural_write(int($secs / $break), $desc{$break});  
   
         if ($long == 1 && $i > 0) {    while ($i <= $#breaks && $secs >= 2 * $breaks[$i]) {
                 my $rest = $secs % $break;      $i++;
                 $i--;    }
                 $break = $breaks[$i];    $i--;
                 my $resttime = plural_write(int($rest / $break), $desc{$break});    my $break  = $breaks[$i];
                 if ($resttime) {    my $retval = plural_write(int($secs / $break), $desc{$break});
                         $retval .= ", $resttime";  
                 }  
         }  
   
         return $retval;    if ($long == 1 && $i > 0) {
       my $rest = $secs % $break;
       $i--;
       $break = $breaks[$i];
       my $resttime = plural_write(int($rest / $break), $desc{$break});
       if ($resttime) {
         $retval .= ", $resttime";
       }
     }
   
     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 '/') {    my $root = '[' . htmlquote($CVSROOTdescr{$cvstree} || $cvstree) . ']';
   
                 # this should never happen - chooseCVSRoot() is    # This should never happen (see chooseCVSRoot()), but let's be sure...
                 # intended to do this    return $root if ($pathname eq '/');
                 $retval = "[$cvstree]";  
         } else {  
                 $retval .= ' ' . &link("[$cvstree]",  
                         sprintf('%s/%s#dirlist', $scriptname, $query));  
                 my $wherepath = '';  
                 my ($lastslash) = $pathname =~ m|/$|;  
   
                 foreach (split (/\//, $pathname)) {    my $retval =
                         $retval .= " / ";      ' ' . &link($root, sprintf('%s/%s#dirlist', $scriptname, $query));
                         $wherepath .= "/$_";    my $wherepath = '';
                         my ($last) = "$wherepath/" eq "/$pathname"    my ($lastslash) = $pathname =~ m|/$|;
                             || $wherepath eq "/$pathname";  
   
                         if ($clickLast || !$last) {    foreach (split(m|/|, $pathname)) {
                                 $retval .= &link($_,      $retval .= ' / ';
                                         join ('', $scriptname,      $wherepath .= "/$_";
                                         urlencode($wherepath),      my $last = "$wherepath/" eq "/$pathname" || $wherepath eq "/$pathname";
                                         (!$last || $lastslash ? '/' : ''),  
                                         $query,      if ($clickLast || !$last) {
                                         (!$last || $lastslash ? "#dirlist" : "")        $retval .= &link(htmlquote($_),
                                 ));                         join ('',
                         } else {    # do not make a link to the current dir                               $scriptname, uri_escape_path($wherepath),
                                 $retval .= $_;                               (!$last || $lastslash ? '/' : ''), $query,
                         }                               (!$last || $lastslash ? "#dirlist" : "")));
                 }      } else {    # do not make a link to the current dir
         }        $retval .= htmlquote($_);
         return $retval;      }
     }
     return $retval;
 }  }
   
 sub chooseCVSRoot() {  
   
         print "<form method=\"get\" action=\"${scriptwhere}\">\n";  sub chooseCVSRoot()
         if (2 <= @CVSROOT) {  {
                 my ($k);    print "<form method=\"get\" action=\"$scriptwhere\">\n<p>\n";
                 foreach $k (keys %input) {    if (2 <= @CVSROOT) {
                         print "<input type=\"hidden\" name=\"$k\" value=\"$input{$k}\">\n"      foreach my $k (keys %input) {
                             if ($input{$k}) && ($k ne "cvsroot");        printf("<input type=\"hidden\" name=\"%s\" value=\"%s\" />\n",
                 }               htmlquote($k), htmlquote($input{$k}))
           if ($input{$k} && $k ne 'cvsroot');
       }
   
                 # Form-Elements look wierd in Netscape if the background      print <<EOF;
                 # isn't gray and the form elements are not placed  <label for="cvsroot" accesskey="C">CVS Root:
                 # within a table ...  <select id="cvsroot" name="cvsroot">
                 print "<table style=\"border: none\">\n<tr>\n";  EOF
                 print "<td><label for=\"cvsroot\" accesskey=\"C\">CVS Root:</label></td>\n";  
                 print "<td>\n<select id=\"cvsroot\" name=\"cvsroot\"";  
                 print " onchange=\"this.form.submit()\"" if $use_java_script;  
                 print ">\n";  
   
                 foreach $k (@CVSROOT) {      foreach my $k (@CVSROOT) {
                         print "<option value=\"$k\"";        printf("<option value=\"%s\"%s>%s</option>\n",
                         print " selected" if ($k eq $cvstree);               htmlquote($k),
                         print ">",($CVSROOTdescr{$k} ? $CVSROOTdescr{$k} : $k),               ($k eq $cvstree) ? ' selected="selected"' : '',
                             "</option>\n";               htmlquote($CVSROOTdescr{$k} || $k));
                 }      }
                 print "</select>\n</td>\n<td>";      print '</select></label>';
         } else {    } else {
   
                 # no choice -- but we need the form to select module/path,      # no choice -- but we need the form to select module/path,
                 # at least for Netscape      # at least for Netscape
                 print "<p>\n";      printf "CVS Root: <b>[%s]</b>",
                 print "CVS Root: <b>[$cvstree]</b>";        htmlquote($CVSROOTdescr{$cvstree} || $cvstree);
         }    }
   
         print " <label for=\"path\" accesskey=\"P\">Module path or alias:";    print <<EOF;
         print "</label>\n";  <label for="mpath" accesskey="M">
         print "<input type=\"text\" id=\"path\" name=\"path\" value=\"\" size=\"15\">\n";  Module path or alias:
         print "<input type=\"submit\" value=\"Go\" accesskey=\"G\">";  <input type="text" id="mpath" name="path" value="" size="15" />
   </label>
         if (2 <= @CVSROOT) {  <input type="submit" value="Go" accesskey="O" />
                 print "</td>\n</tr>\n</table>";  </p>
         } else {  </form>
                 print "</p>";  EOF
         }  
         print "\n</form>";  
 }  }
   
 sub chooseMirror() {  
         my ($mirror, $moremirrors);  
         $moremirrors = 0;  
   
         # This code comes from the original BSD-cvsweb  sub fileSortCmp()
         # and may not be useful for your site; If you don't  {
         # set %MIRRORS this won't show up, anyway    (my $af = $a) =~ s/,v$//;
         #    (my $bf = $b) =~ s/,v$//;
         # Should perhaps exlude the current site somehow..    my ($rev1, $date1, $log1, $author1, $filename1) = @{$fileinfo{$af}}
         if (keys %MIRRORS) {      if (defined($fileinfo{$af}));
                 print "\nThis CVSweb is mirrored in:\n";    my ($rev2, $date2, $log2, $author2, $filename2) = @{$fileinfo{$bf}}
       if (defined($fileinfo{$bf}));
   
                 foreach $mirror (keys %MIRRORS) {    my $comp = 0;
                         print ", " if ($moremirrors);    if (defined($filename1) && defined($filename2) &&
                         print &link(htmlquote($mirror), $MIRRORS{$mirror});        $af eq $filename1   && $bf eq $filename2)
                         $moremirrors = 1;    {
                 }  
                 print "<p>\n";  
         }  
 }  
   
 sub fileSortCmp() {      # Two files
         my ($comp) = 0;      $comp = -revcmp($rev1, $rev2)             if ($byrev  && $rev1  && $rev2);
         my ($c, $d, $af, $bf);      $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);
       }
     }
   
         ($af = $a) =~ s/,v$//;    if ($comp == 0) {
         ($bf = $b) =~ s/,v$//;  
         my ($rev1, $date1, $log1, $author1, $filename1) = @{$fileinfo{$af}}  
             if (defined($fileinfo{$af}));  
         my ($rev2, $date2, $log2, $author2, $filename2) = @{$fileinfo{$bf}}  
             if (defined($fileinfo{$bf}));  
   
         if (defined($filename1) && defined($filename2) && $af eq $filename1      # Directories first, then files under version control,
             && $bf eq $filename2)      # then other, "rogue" files.
         {      # Sort by filename if no other criteria available.
   
                 # Two files      my $ad = (
                 $comp = -revcmp($rev1, $rev2) if ($byrev && $rev1 && $rev2);        (-d "$fullname/$a")
                 $comp = ($date2 <=> $date1) if ($bydate && $date1 && $date2);        ? 'D'
                 $comp = ($log1 cmp $log2) if ($bylog && $log1 && $log2);        : (defined($fileinfo{$af}) ? 'F' : 'R')
                 $comp = ($author1 cmp $author2)      );
                     if ($byauthor && $author1 && $author2);      my $bd = (
         }        (-d "$fullname/$b")
         ? 'D'
         : (defined($fileinfo{$bf}) ? 'F' : 'R')
       );
       (my $c = $a) =~ s|.*/||;
       (my $d = $b) =~ s|.*/||;
   
         if ($comp == 0) {      my ($l, $r) = ("$ad$c", "$bd$d");
       $comp = $input{ignorecase} ? (uc($l) cmp uc($r)) : ($l cmp $r);
   
                 # Directories first, then sorted on name if no other sort critera      # Parent dir is always first, then Attic.
                 # available.      if ($comp != 0) {
                 my $ad = ((-d "$fullname/$a") ? "D" : "F");        if ($l eq 'D..') {
                 my $bd = ((-d "$fullname/$b") ? "D" : "F");          $comp = -1;
                 ($c = $a) =~ s|.*/||;        } elsif ($r eq 'D..') {
                 ($d = $b) =~ s|.*/||;          $comp = 1;
                 $comp = ("$ad$c" cmp "$bd$d");        } elsif ($l eq 'DAttic') {
         }          $comp = -1;
         return $comp;        } elsif ($r eq 'DAttic') {
           $comp = 1;
         }
       }
     }
     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($checkoutMagic)    return $url;
             && (!defined($mimetype) || $mimetype ne "text/x-cvsweb-markup"))  }
         {  
                 my $path = $where;  
                 $path =~ s|[^/]+$||;  
                 $url = "$scriptname/$checkoutMagic/${path}$url";  
         }  
         $url .= "?rev=$revision";  
         $url .= '&content-type=' . urlencode($mimetype) if (defined($mimetype));  
   
         $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 ($url, $revision, $mimetype) = @_;
     $url .= '?rev=' . uri_escape($revision);
     $url .= ';content-type=' . uri_escape($mimetype) if $mimetype;
     return $url;
   }
   
         $fullurl =~ s/:/sprintf("%%%02x", ord($&))/eg;  #
   # Returns a link to display the selected revision.
         printf '<a href="%s"', hrefquote("$fullurl$barequery");  # Expects the passed in URL to be URI escaped, and without a query string.
   #
         if ($open_extern_window  sub display_link($$;$$)
             && (!defined($mimetype) || $mimetype ne "text/x-cvsweb-markup"))  {
         {    my ($url, $revision, $textlink, $mtype) = @_;
                 print ' target="cvs_checkout"';    $textlink = $revision unless defined($textlink);
     return sprintf('<a href="%s" class="display-link">%s</a>',
                 # we should have                   display_url($url, $revision, $mtype) . $barequery,
                 #   'if (document.cvswin==null) document.cvswin=window.open(...'                   htmlquote($textlink));
                 # 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) {  
                         my @attr = qw(resizeable scrollbars);  
   
                         push @attr, qw(status toolbar)  
                             if (defined($mimetype) && $mimetype eq "text/html");  
   
                         push @attr, "width=$extern_window_width"  
                             if (defined($extern_window_width));  
   
                         push @attr, "height=$extern_window_height"  
                             if (defined($extern_window_height));  
   
                         # We need the "return false" here to prevent browsers  
                         # from following the href after the onclick handler.  
                         # This would effectively load the same document in  
                         # the same window *twice*.  
                         printf  
                             q` onclick="window.open('%s','cvs_checkout','%s');return false"`,  
                             hrefquote($fullurl), join (',', @attr);  
                 }  
         }  
         print "><b>$textlink</b></a>";  
 }  }
   
 # 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;  
   
         if (defined($value)) {    my %vars = %input;
                 $vars{$toggle} = $value;  
         } else {  
                 $vars{$toggle} = $vars{$toggle} ? 0 : 1;  
         }  
   
         # Build a new query of non-default paramenters    if (defined($value)) {
         $newquery = "";      $vars{$toggle} = $value;
         foreach $var (@stickyvars) {    } else {
                 my ($value) = defined($vars{$var}) ? $vars{$var} : "";      $vars{$toggle} = $vars{$toggle} ? 0 : 1;
                 my ($default) =    }
                     defined($DEFAULTVALUE{$var}) ? $DEFAULTVALUE{$var} : "";  
   
                 if ($value ne $default) {    # Build a new query of non-default paramenters
                         $newquery .= "&" if ($newquery ne "");    my $newquery = "";
                         $newquery .= urlencode($var) . "=" . urlencode($value);    foreach my $var (@stickyvars) {
                 }      my ($value)   = defined($vars{$var})         ? $vars{$var}         : "";
         }      my ($default) = defined($DEFAULTVALUE{$var}) ? $DEFAULTVALUE{$var} : "";
   
         if ($newquery) {      if ($value ne $default) {
                 return '?' . $newquery;        $newquery .= ';' if ($newquery ne "");
         }        $newquery .= uri_escape($var) . '=' . uri_escape($value);
         return "";      }
 }    }
   
 sub urlencode($) {    if ($newquery) {
         local ($_) = @_;      return '?' . $newquery;
     }
         s/[\000-+{-\377]/sprintf("%%%02x", ord($&))/ge;    return "";
   
         $_;  
 }  }
   
 sub htmlquote($) {  sub htmlquote($)
         local ($_) = @_;  {
     local ($_) = @_;
         # Special Characters; RFC 1866    # Special Characters; RFC 1866
         s/&/&amp;/g;    s/&/&amp;/g;
         s/\"/&quot;/g;    s/\"/&quot;/g;
         s/</&lt;/g;    s/"/&quot;/g;
         s/>/&gt;/g;    s/</&lt;/g;
     s/>/&gt;/g;
         $_;    return $_;
 }  }
   
 sub htmlunquote($) {  sub htmlunquote($)
         local ($_) = @_;  {
     local ($_) = @_;
         # Special Characters; RFC 1866    # Special Characters; RFC 1866
         s/&quot;/\"/g;    s/&quot;/\"/g;
         s/&lt;/</g;    s/&lt;/</g;
         s/&gt;/>/g;    s/&gt;/>/g;
         s/&amp;/&/g;    s/&amp;/&/g;
     return $_;
         $_;  
 }  }
   
 sub hrefquote($) {  sub uri_escape_path($)
         local ($_) = @_;  {
     return join('/', map(uri_escape($_), split(m|/+|, shift, -1)));
         y/ /+/;  
   
         htmlquote($_)  
 }  }
   
 sub http_header(;$) {  sub http_header(;$$)
         my $content_type = shift || "text/html";  {
     my ($content_type, $moddate) = @_;
     $content_type ||= 'text/html';
     $content_type .= '; charset="UTF-8"' if $content_type =~ /^text\//;
   
         $content_type .= "; charset=$charset"    # Note that in the following, we explicitly join() and concatenate the
             if $content_type =~ m,^text/, && defined($charset) && $charset;    # 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().
   
         if (defined($moddate)) {    my @headers = ();
                 if ($is_mod_perl) {    # TODO: ctime(3) from scalar gmtime() isn't HTTP compliant, see HTTP::Date.
                         Apache->request->header_out(    push(@headers, 'Last-Modified: ' . scalar gmtime($moddate) . ' GMT')
                                 "Last-Modified" => scalar gmtime($moddate)      if $moddate;
                                 . " GMT");    push(@headers, 'Content-Type: ' . $content_type);
                 } else {    push(@headers, "Content-Security-Policy: default-src 'none'; " .
                         print "Last-Modified: ", scalar gmtime($moddate),      "img-src 'self'; style-src 'unsafe-inline'");
                             " GMT\r\n";  
                 }  
         }  
   
         if ($is_mod_perl) {    if ($allow_compress && $maycompress) {
                 Apache->request->content_type($content_type);        push(@headers, 'Content-Encoding: gzip');
         } else {        push(@headers, 'Vary: Accept-Encoding');     # RFC 2616, 14.44
                 print "Content-Type: $content_type\r\n";        print join("\r\n", @headers) . "\r\n\r\n";
         }  
   
         if ($allow_compress && $maycompress) {        $| = 1;
                 if ($has_zlib        $| = 0;                                      # Flush header output.
                     || (defined($CMD{gzip}) && open(GZIP, "| $CMD{gzip} -1 -c"))  
                     )  
                 {  
   
                         if ($is_mod_perl) {        tie(*GZIP, __PACKAGE__, \*STDOUT);
                                 Apache->request->content_encoding("x-gzip");        select(GZIP);
                                 Apache->request->header_out(        $gzip_open = 1;
                                         Vary => "Accept-Encoding");    } else {
                                 Apache->request->send_http_header;      print join("\r\n", @headers) . "\r\n\r\n";
                         } else {    }
                                 print "Content-Encoding: x-gzip\r\n";  
                                 print "Vary: Accept-Encoding\r\n"  
                                     ;            #RFC 2068, 14.43  
                                 print "\r\n";    # Close headers  
                         }  
                         $| = 1;  
                         $| = 0;    # Flush header output  
   
                         if ($has_zlib) {  
                                 tie *GZIP, __PACKAGE__, \*STDOUT;  
                         }  
                         select(GZIP);  
                         $gzip_open = 1;  
   
                         #           print "<!-- gzipped -->" if ($content_type =~ m|^text/html\b|);  
                 } else {  
                         if ($is_mod_perl) {  
                                 Apache->request->send_http_header;  
                         } else {  
                                 print "\r\n";    # Close headers  
                         }  
                         print  
                             "<span style=\"font-size: smaller\">Unable to find gzip binary in the <b>\$command_path</b> ($command_path) to compress output</span><br>";  
                 }  
         } else {  
   
                 if ($is_mod_perl) {  
                         Apache->request->send_http_header;  
                 } else {  
                         print "\r\n";    # Close headers  
                 }  
         }  
 }  }
   
 sub html_header($) {  
         my ($title) = @_;  sub html_header($;$)
         http_header("text/html");  {
         print <<EOH;    my ($title, $moddate) = @_;
     $title  = htmlquote($title);
     my $l   = $logo || '';
     my $css = $CSS || '';
     http_header('text/html', $moddate);
     print <<EOH;
 $HTML_DOCTYPE  $HTML_DOCTYPE
 <html>  <html>
 <head>  <head>
 <title>$title</title>  <title>$title</title>
 $HTML_META</head>  $HTML_META$css</head>
 $body_tag  <body>
 $logo <h1 align="center">$title</h1>  $l <h1>$title</h1>
 EOH  EOH
 }  }
   
 sub html_footer() {  sub html_footer()
         print "<hr noshade>\n<address>$address</address>\n</body>\n</html>\n";  {
     print "<hr />\n<address>$address</address>\n" if $address;
     print "</body>\n</html>\n";
 }  }
   
 sub link_tags($) {  sub link_tags($)
         my ($tags) = @_;  {
         my ($ret)  = "";    my ($tags) = @_;
         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 .=      $ret .= ",\n" if ($ret ne "");
                     &link($sym, $fileurl . toggleQuery('only_with_tag', $sym));      $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 @HideModules 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) = @_;  {
         local $_;    (my $path = canonpath(shift)) =~ s/,v$//;
     $path =~ s|^$cvsroot/+||;
     for my $forbidden_re (@ForbiddenFiles) {
       return 1 if ($path =~ $forbidden_re);
     }
     return 0;
   }
   
         for (@HideModules) {  
                 return 1 if $module =~ $_;  #
         }  # Starts a process using IPC::Run.  All arguments are passed to
         return 0;  # 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);
 }  }
   
 sub forbidden_file($) {  #
         my ($path) = @_;  # Runs a process using IPC::Run.  All arguments are passed to
         $path =  substr($path, length($cvsroot) + 1);  # IPC::Run::run() as-is.  Returns an array ($exitcode, $errormsg).
         local $_;  #
         for (@ForbiddenFiles) {  sub runproc(@)
                 return 1 if $path =~ $_;  {
         }    eval {
         return 0;      local $SIG{__DIE__};
       IPC::Run::run(@_);
     };
     my $exitcode = $? >> 8;
     my $errormsg  = undef;
     if ($@) {
       $exitcode ||= -1;
       $errormsg = "'@{$_[0]}' failed: $@";
     }
     return ($exitcode, $errormsg);
 }  }
   
 # Close the GZIP handle remove the tie.  #
   # Close the GZIP handle, and remove the tie.
 sub gzipclose {  #
         if ($gzip_open) {  sub gzipclose
                 select(STDOUT);  {
                 close(GZIP);    if ($gzip_open) {
                 untie *GZIP;      select(STDOUT);
                 $gzip_open = 0;      close(GZIP);
         }      untie *GZIP;
       $gzip_open = 0;
     }
 }  }
   
 # implement a gzipped file handle via the Compress:Zlib compression  # implement a gzipped file handle via the Compress:Zlib compression
Line 3679  sub MAGIC1() { 0x1f }
Line 3744  sub MAGIC1() { 0x1f }
 sub MAGIC2() { 0x8b }  sub MAGIC2() { 0x8b }
 sub OSCODE() { 3 }  sub OSCODE() { 3 }
   
 sub TIEHANDLE {  sub TIEHANDLE
         my ($class, $out) = @_;  {
         my ($d) = Compress::Zlib::deflateInit(    my ($class, $out) = @_;
                 -Level      => Compress::Zlib::Z_BEST_COMPRESSION(),    my ($d) = Compress::Zlib::deflateInit(
                 -WindowBits => -Compress::Zlib::MAX_WBITS()      -Level      => Compress::Zlib::Z_BEST_COMPRESSION(),
         ) or return undef;      -WindowBits => -Compress::Zlib::MAX_WBITS()
         my ($o) = {      )
                 handle => $out,      or return undef;
                 dh     => $d,    my ($o) = { handle => $out,
                 crc    => 0,                dh     => $d,
                 len    => 0,                crc    => 0,
         };                len    => 0,
         my ($header) =              };
             pack("c10", MAGIC1, MAGIC2, Compress::Zlib::Z_DEFLATED(), 0, 0, 0,    my ($header) = pack("C10",
             0, 0, 0, OSCODE);                        MAGIC1, MAGIC2, Compress::Zlib::Z_DEFLATED(),
         print {$o->{handle}} $header;                        0, 0, 0, 0, 0, 0, OSCODE);
         return bless($o, $class);    print {$o->{handle}} $header;
     return bless($o, $class);
 }  }
   
 sub PRINT {  sub PRINT
         my ($o)   = shift;  {
         my ($buf) = join (defined $, ? $, : "", @_);    my ($o)   = shift;
         my ($len) = length($buf);    my ($buf) = join (defined($,) ? $, : "", @_);
         my ($compressed, $status) = $o->{dh}->deflate($buf);    my ($len) = length($buf);
         print {$o->{handle}} $compressed if defined($compressed);    my ($compressed, $status) = $o->{dh}->deflate($buf);
         $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});    print {$o->{handle}} $compressed if defined($compressed);
         $o->{len} += $len;    $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});
         return $len;    $o->{len} += $len;
     return $len;
 }  }
   
 sub PRINTF {  sub PRINTF
         my ($o)   = shift;  {
         my ($fmt) = shift;    my ($o)   = shift;
         my ($buf) = sprintf($fmt, @_);    my ($fmt) = shift;
         my ($len) = length($buf);    my ($buf) = sprintf($fmt, @_);
         my ($compressed, $status) = $o->{dh}->deflate($buf);    my ($len) = length($buf);
         print {$o->{handle}} $compressed if defined($compressed);    my ($compressed, $status) = $o->{dh}->deflate($buf);
         $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});    print {$o->{handle}} $compressed if defined($compressed);
         $o->{len} += $len;    $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});
         return $len;    $o->{len} += $len;
     return $len;
 }  }
   
 sub WRITE {  sub WRITE
         my ($o, $buf, $len, $off) = @_;  {
         my ($compressed, $status) = $o->{dh}->deflate(substr($buf, 0, $len));    my ($o, $buf, $len, $off) = @_;
         print {$o->{handle}} $compressed if defined($compressed);    my ($compressed, $status) = $o->{dh}->deflate(substr($buf, 0, $len));
         $o->{crc} = Compress::Zlib::crc32(substr($buf, 0, $len), $o->{crc});    print {$o->{handle}} $compressed if defined($compressed);
         $o->{len} += $len;    $o->{crc} = Compress::Zlib::crc32(substr($buf, 0, $len), $o->{crc});
         return $len;    $o->{len} += $len;
     return $len;
 }  }
   
 sub CLOSE {  sub CLOSE
         my ($o) = @_;  {
         return if !defined($o->{dh});    my ($o) = @_;
         my ($buf) = $o->{dh}->flush();    return if !defined($o->{dh});
         $buf .= pack("V V", $o->{crc}, $o->{len});    my ($buf) = $o->{dh}->flush();
         print {$o->{handle}} $buf;    $buf .= pack("V V", $o->{crc}, $o->{len});
         undef $o->{dh};    print {$o->{handle}} $buf;
     undef $o->{dh};
 }  }
   
 sub DESTROY {  sub DESTROY
         my ($o) = @_;  {
         CLOSE($o);    my ($o) = @_;
     CLOSE($o);
 }  }
   
   # Local variables:
   # indent-tabs-mode: nil
   # cperl-indent-level: 2
   # End:
Legend:
Removed from v.1.1.1.32  
changed lines
  Added in v.4.40
CVSweb