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

Annotation of cvsweb/cvsweb.cgi, Revision 1.1.1.37

1.1.1.37! simon       1: #!/usr/bin/perl -T
1.1       jfieber     2: #
1.1.1.1   knu         3: # cvsweb - a CGI interface to CVS trees.
1.1       jfieber     4: #
1.1.1.2   knu         5: # Written in their spare time by
1.1.1.33  scop        6: #             Bill Fenner          <fenner@FreeBSD.org>   (original work)
                      7: # extended by Henner Zeller        <zeller@think.de>,
                      8: #             Henrik Nordstrom     <hno@hem.passagen.se>
                      9: #             Ken Coar             <coar@Apache.Org>
                     10: #             Dick Balaska         <dick@buckosoft.com>
                     11: #             Akinori MUSHA        <knu@FreeBSD.org>
                     12: #             Jens-Uwe Mager       <jum@helios.de>
                     13: #             Ville Skyttä         <scop@FreeBSD.org>
                     14: #             Vassilii Khachaturov <vassilii@tarunz.org>
1.1       jfieber    15: #
1.1.1.1   knu        16: # Based on:
                     17: # * Bill Fenners cvsweb.cgi revision 1.28 available from:
                     18: #   http://www.FreeBSD.org/cgi/cvsweb.cgi/www/en/cgi/cvsweb.cgi
                     19: #
                     20: # Copyright (c) 1996-1998 Bill Fenner
                     21: #           (c) 1998-1999 Henner Zeller
1.1.1.32  knu        22: #           (c) 1999      Henrik Nordstrom
                     23: #           (c) 2000-2002 Akinori MUSHA
1.1.1.37! simon      24: #           (c) 2002-2005 Ville Skyttä
1.1.1.35  scop       25: # All rights reserved.
1.1.1.1   knu        26: #
                     27: # Redistribution and use in source and binary forms, with or without
                     28: # modification, are permitted provided that the following conditions
                     29: # are met:
                     30: # 1. Redistributions of source code must retain the above copyright
                     31: #    notice, this list of conditions and the following disclaimer.
                     32: # 2. Redistributions in binary form must reproduce the above copyright
                     33: #    notice, this list of conditions and the following disclaimer in the
                     34: #    documentation and/or other materials provided with the distribution.
                     35: #
                     36: # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
                     37: # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
                     38: # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
                     39: # ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
                     40: # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
                     41: # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
                     42: # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
                     43: # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
                     44: # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
                     45: # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
                     46: # SUCH DAMAGE.
                     47: #
1.1.1.37! simon      48: # $FreeBSD: projects/cvsweb/cvsweb.cgi,v 1.295 2005/09/25 20:28:51 scop Exp $
1.1.1.28  knu        49: # $zId: cvsweb.cgi,v 1.112 2001/07/24 13:03:16 hzeller Exp $
1.1.1.29  knu        50: # $Idaemons: /home/cvs/cvsweb/cvsweb.cgi,v 1.84 2001/10/07 20:50:10 knu Exp $
1.1.1.1   knu        51: #
                     52: ###
                     53:
1.1.1.37! simon      54: require 5.006;
1.1.1.19  knu        55:
1.1.1.1   knu        56: use strict;
                     57:
1.1.1.37! simon      58: use warnings;
        !            59: use filetest qw(access);
        !            60:
1.1.1.1   knu        61: use vars qw (
1.1.1.37! simon      62:   $VERSION $CheckoutMagic $MimeTypes $DEBUG
        !            63:   $config $allow_version_select
        !            64:   @CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr
        !            65:   %MIRRORS %DEFAULTVALUE %ICONS %MTYPES
        !            66:   %DIFF_COMMANDS @DIFFTYPES %DIFFTYPES @LOGSORTKEYS %LOGSORTKEYS
        !            67:   %alltags %fileinfo %tags @branchnames %nameprinted
        !            68:   %symrev %revsym @allrevisions %date %author @revdisplayorder
        !            69:   @revisions %state %difflines %log %branchpoint @revorder $keywordsubstitution
        !            70:   $prcgi @prcategories $re_prcategories $prkeyword $re_prkeyword $mancgi
        !            71:   $doCheckout $scriptname $scriptwhere
        !            72:   $where $Browser $nofilelinks $maycompress @stickyvars %funcline_regexp
        !            73:   $is_links $is_lynx $is_w3m $is_msie $is_mozilla3 $is_textbased
        !            74:   %input $query $barequery $sortby $bydate $byrev $byauthor
        !            75:   $bylog $byfile $defaultDiffType $logsort $cvstree $cvsroot
        !            76:   $charset $output_filter
        !            77:   @command_path %CMD $allow_compress $backicon $diricon $fileicon $graphicon
        !            78:   $fullname $cvstreedefault $logo $defaulttitle $address $binfileicon
        !            79:   $long_intro $short_instruction $shortLogLen $show_author
        !            80:   $tablepadding $hr_breakable $showfunc $hr_ignwhite $hr_ignkeysubst
        !            81:   $inputTextSize $mime_types $allow_annotate $allow_markup $allow_mailtos
        !            82:   $allow_log_extra $allow_dir_extra $allow_source_extra
        !            83:   $allow_cvsgraph $cvsgraph_config $use_java_script $edit_option_form
        !            84:   $show_subdir_lastmod $show_log_in_markup $preformat_in_markup
        !            85:   $tabstop $state $annTable $sel @ForbiddenFiles
        !            86:   $use_descriptions %descriptions @mytz $dwhere
        !            87:   $use_moddate $gzip_open $file_list_len
        !            88:   $allow_tar @tar_options @gzip_options @zip_options @cvs_options
        !            89:   @annotate_options @rcsdiff_options
        !            90:   $HTML_DOCTYPE $HTML_META $cssurl $CSS $cvshistory_url
        !            91:   $allow_enscript @enscript_options %enscript_types
1.1.1.1   knu        92: );
                     93:
1.1.1.37! simon      94: use Cwd                   qw(abs_path);
        !            95: use File::Basename        qw(dirname);
        !            96: use File::Path            qw(rmtree);
        !            97: use File::Spec::Functions qw(canonpath catdir catfile curdir devnull rootdir
        !            98:                              tmpdir updir);
        !            99: use File::Temp            qw(tempdir tempfile);
        !           100: use IPC::Run              qw();
        !           101: use Time::Local           qw(timegm);
        !           102: use URI::Escape           qw(uri_escape uri_unescape);
        !           103:
        !           104: use constant VALID_PATH   => qr/^([[:^cntrl:]]+)$/o;
        !           105: use constant VALID_TAG1   => qr/^([a-zA-Z][[:graph:]]*)$/o;
        !           106: use constant VALID_TAG2   => qr/^([^\$,.:;@]+)$/o;
        !           107: use constant CVSWEBMARKUP => qr{^text/(x-cvsweb|vnd\.viewcvs)-markup$}io;
        !           108: use constant LOG_FILESEPR => qr/^={77}$/o;
        !           109: use constant LOG_REVSEPR  => qr/^-{28}$/o;
        !           110:
        !           111: use constant HAS_ZLIB     => eval { require Compress::Zlib; };
        !           112: use constant HAS_EDIFF    => eval { require String::Ediff;  };
        !           113:
        !           114: # -----------------------------------------------------------------------------
        !           115:
        !           116: # All global initialization that can be done in compile time should go to
        !           117: # the BEGIN block.  Persistent environments, such as mod_perl, will benefit
        !           118: # from this.
        !           119:
        !           120: BEGIN
        !           121: {
        !           122:   $VERSION = '3.0.6';
        !           123:
        !           124:   $HTML_DOCTYPE =
        !           125:     '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" ' .
        !           126:     '"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">';
        !           127:
        !           128:   $HTML_META = <<EOM;
        !           129: <meta name="robots" content="nofollow" />
        !           130: <meta name="generator" content="FreeBSD-CVSweb $VERSION" />
        !           131: <meta http-equiv="Content-Script-Type" content="text/javascript" />
        !           132: <meta http-equiv="Content-Style-Type" content="text/css" />
        !           133: EOM
        !           134:
        !           135:   # Use MIME::Types for MIME type lookups if it's available.
        !           136:   eval {
        !           137:     require MIME::Types;
        !           138:     $MimeTypes = MIME::Types->new(only_complete => 1);
        !           139:   };
        !           140:   $MimeTypes = undef if $@;
        !           141:
        !           142:   $CheckoutMagic = '~checkout~';
        !           143: }
        !           144:
        !           145: # -----------------------------------------------------------------------------
        !           146:
1.1.1.2   knu       147: sub printDiffSelect($);
1.1.1.37! simon     148: sub printDiffSelectStickyVars();
        !           149: sub getDiffLinks($$$);
1.1.1.11  knu       150: sub printLogSortSelect($);
1.1.1.2   knu       151: sub findLastModifiedSubdirs(@);
1.1.1.11  knu       152: sub htmlify_sub(&$);
1.1.1.2   knu       153: sub htmlify($;$);
1.1.1.6   knu       154: sub spacedHtmlText($;$);
1.1.1.2   knu       155: sub link($$);
                    156: sub revcmp($$);
1.1.1.31  knu       157: sub fatal($$@);
1.1.1.37! simon     158: sub config_error($$);
        !           159: sub redirect($;$);
1.1.1.2   knu       160: sub safeglob($);
1.1.1.21  knu       161: sub search_path($);
1.1.1.37! simon     162: sub getEnscriptHL($);
        !           163: sub getMimeType($;$);
1.1.1.6   knu       164: sub head($;$);
                    165: sub scan_directives(@);
1.1.1.29  knu       166: sub openOutputFilter();
1.1.1.2   knu       167: sub doAnnotate($$);
1.1.1.37! simon     168: sub doCheckout($$$);
        !           169: sub doEnscript($$$;$);
        !           170: sub doGraph();
        !           171: sub doGraphView();
        !           172: sub cvswebMarkup($$$$$$;$);
1.1.1.2   knu       173: sub viewable($);
                    174: sub doDiff($$$$$$);
                    175: sub getDirLogs($$@);
                    176: sub readLog($;$);
1.1.1.37! simon     177: sub printLog($$$;$$);
1.1.1.2   knu       178: sub doLog($);
                    179: sub flush_diff_rows($$$$);
1.1.1.37! simon     180: sub human_readable_diff($$);
        !           181: sub navigateHeader($$$$$;$);
1.1.1.2   knu       182: sub plural_write($$);
                    183: sub readableTime($$);
                    184: sub clickablePath($$);
                    185: sub chooseCVSRoot();
                    186: sub chooseMirror();
                    187: sub fileSortCmp();
                    188: sub download_url($$;$);
                    189: sub download_link($$$;$);
1.1.1.37! simon     190: sub display_url($$;$);
        !           191: sub display_link($$;$$);
        !           192: sub graph_link($;$);
        !           193: sub history_link($$;$);
        !           194: sub toggleQuery($;$);
1.1.1.11  knu       195: sub htmlquote($);
                    196: sub htmlunquote($);
1.1.1.37! simon     197: sub uri_escape_path($);
        !           198: sub http_header(;$$);
        !           199: sub html_header($;$);
1.1.1.2   knu       200: sub html_footer();
                    201: sub link_tags($);
1.1.1.37! simon     202: sub forbidden($);
        !           203: sub startproc(@);
        !           204: sub runproc(@);
        !           205: sub checkout_to_temp($$$);
        !           206:
        !           207: # Get rid of unsafe environment vars.  Don't do this in the BEGIN block
        !           208: # (think mod_perl)...
        !           209: delete(@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)});
1.1.1.21  knu       210:
1.1.1.37! simon     211: my ($mydir) = (dirname($0) =~ /(.*)/);    # untaint
1.1.1.22  knu       212:
1.1.1.37! simon     213: ##### Start of Configuration Area ########
1.1.1.21  knu       214:
1.1.1.2   knu       215: # == EDIT this ==
1.1.1.8   knu       216: # Locations to search for user configuration, in order:
1.1.1.37! simon     217: for (catfile($mydir, 'cvsweb.conf'), '/usr/local/etc/cvsweb/cvsweb.conf') {
        !           218:   if (-r $_) {
        !           219:     $config = $_;
        !           220:     last;
        !           221:   }
1.1.1.1   knu       222: }
                    223:
                    224: ##### End of Configuration Area   ########
                    225:
1.1.1.37! simon     226: undef $mydir;
        !           227:
        !           228: ######## Configuration parameters #########
        !           229:
1.1.1.28  knu       230: @CVSrepositories = @CVSROOT = %CVSROOT = %MIRRORS = %DEFAULTVALUE = %ICONS =
1.1.1.37! simon     231:   %MTYPES = %tags = %alltags = %fileinfo = %DIFF_COMMANDS = ();
1.1.1.1   knu       232:
1.1.1.37! simon     233: $cvstreedefault = $logo = $defaulttitle =
        !           234:   $address = $long_intro = $short_instruction = $shortLogLen = $show_author =
        !           235:   $tablepadding = $hr_breakable = $showfunc = $hr_ignwhite =
        !           236:   $hr_ignkeysubst = $inputTextSize = $mime_types = $allow_annotate =
        !           237:   $allow_markup = $allow_compress = $use_java_script = $edit_option_form =
        !           238:   $show_subdir_lastmod = $show_log_in_markup = $preformat_in_markup =
        !           239:   $tabstop = $use_moddate = $gzip_open = $DEBUG = $allow_cvsgraph =
        !           240:   $cvsgraph_config = $cvshistory_url = $allow_tar = undef;
        !           241:
        !           242: $allow_version_select = $allow_mailtos = $allow_log_extra = 1;
1.1.1.10  knu       243:
1.1.1.11  knu       244: @DIFFTYPES = qw(h H u c s);
                    245: @DIFFTYPES{@DIFFTYPES} = (
1.1.1.37! simon     246:   {
        !           247:     'descr'   => 'colored',
        !           248:     'opts'    => ['-u'],
        !           249:     'colored' => 1,
        !           250:   },
        !           251:   {
        !           252:     'descr'   => 'long colored',
        !           253:     'opts'    => ['--unified=15'],
        !           254:     'colored' => 1,
        !           255:   },
        !           256:   {
        !           257:     'descr'   => 'unified',
        !           258:     'opts'    => ['-u'],
        !           259:     'colored' => 0,
        !           260:   },
        !           261:   {
        !           262:     'descr'   => 'context',
        !           263:     'opts'    => ['-c'],
        !           264:     'colored' => 0,
        !           265:   },
        !           266:   {
        !           267:     'descr'   => 'side by side',
        !           268:     # width=168 should be enough to support 80 character line lengths
        !           269:     'opts'    => ['--side-by-side', '--width=168'],
        !           270:     'colored' => 0,
        !           271:   },
1.1.1.28  knu       272: );
1.1.1.11  knu       273:
                    274: @LOGSORTKEYS = qw(cvs date rev);
                    275: @LOGSORTKEYS{@LOGSORTKEYS} = (
1.1.1.37! simon     276:   { descr => 'Not sorted',  },
        !           277:   { descr => 'Commit date', },
        !           278:   { descr => 'Revision',    },
1.1.1.28  knu       279: );
1.1.1.11  knu       280:
1.1.1.37! simon     281: ##### End of configuration parameters #####
1.1       jfieber   282:
1.1.1.37! simon     283: my $pathinfo = '';
        !           284: if (defined($ENV{PATH_INFO}) && $ENV{PATH_INFO} ne '') {
        !           285:   ($pathinfo) = ($ENV{PATH_INFO} =~ VALID_PATH)
        !           286:     or fatal('500 Internal Error',
        !           287:              'Illegal PATH_INFO in environment: <code>%s</code>',
        !           288:              $ENV{PATH_INFO});
        !           289: }
        !           290: if ($ENV{SCRIPT_NAME}) {
        !           291:   ($scriptname) = ($ENV{SCRIPT_NAME} =~ VALID_PATH)
        !           292:     or fatal('500 Internal Error',
        !           293:              'Illegal SCRIPT_NAME in environment: <code>%s</code>',
        !           294:              $ENV{SCRIPT_NAME});
        !           295: }
        !           296:
        !           297: $scriptname    = '' unless defined($scriptname);
        !           298:
        !           299: $where         =  $pathinfo;
        !           300: $doCheckout    =  $where =~ s|^/$CheckoutMagic/|/|o;
        !           301: $where         =~ s|^/||;
        !           302: $scriptname    =~ s|^/*|/|;
1.1.1.21  knu       303:
1.1.1.22  knu       304: # Let's workaround thttpd's stupidity..
1.1.1.21  knu       305: if ($scriptname =~ m|/$|) {
1.1.1.37! simon     306:   $pathinfo .= '/';
        !           307:   my $re = quotemeta $pathinfo;
        !           308:   $scriptname =~ s/$re$//;
        !           309: }
        !           310:
        !           311: # $scriptname : the URI escaped path to this script
        !           312: # $where      : the path in the CVS repository (without leading /, or only /)
        !           313: # $scriptwhere: the URI escaped $scriptname + '/' + $where
        !           314: $scriptname   = uri_escape_path($scriptname);
        !           315: $scriptwhere  = join('/', $scriptname, uri_escape_path($where));
        !           316: $where        = '/' if ($where eq '');
        !           317:
        !           318: # In text-based browsers, it's very annoying to have two links per file;
        !           319: # skip linking the image for them.
        !           320:
        !           321: $Browser     = $ENV{HTTP_USER_AGENT} || '';
        !           322: $is_links    = ($Browser =~ m`^E?Links `);
1.1.1.28  knu       323: $is_lynx     = ($Browser =~ m`^Lynx/`i);
                    324: $is_w3m      = ($Browser =~ m`^w3m/`i);
                    325: $is_msie     = ($Browser =~ m`MSIE`);
1.1.1.1   knu       326: $is_mozilla3 = ($Browser =~ m`^Mozilla/[3-9]`);
                    327:
1.1.1.11  knu       328: $is_textbased = ($is_links || $is_lynx || $is_w3m);
1.1.1.1   knu       329:
                    330: $nofilelinks = $is_textbased;
                    331:
                    332: # newer browsers accept gzip content encoding
                    333: # and state this in a header
                    334: # (netscape did always but didn't state it)
                    335: # It has been reported that these
                    336: #  braindamaged MS-Internet Exploders claim that they
                    337: # accept gzip .. but don't in fact and
                    338: # display garbage then :-/
1.1.1.6   knu       339: # Turn off gzip if running under mod_perl and no zlib is available,
                    340: # piping does not work as expected inside the server.
1.1.1.37! simon     341: $maycompress = (
        !           342:   ((defined($ENV{HTTP_ACCEPT_ENCODING})
        !           343:     && $ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/)
        !           344:    || $is_mozilla3)
        !           345:   && !$is_msie
        !           346:   && !(defined($ENV{MOD_PERL}) && !HAS_ZLIB)
        !           347: );
        !           348:
        !           349: # Parameters that will be sticky in all constructed links/query strings.
        !           350: @stickyvars =
        !           351:   qw(cvsroot hideattic ignorecase sortby logsort f only_with_tag ln
        !           352:      hidecvsroot hidenonreadable);
1.1.1.1   knu       353:
1.1.1.37! simon     354: #
        !           355: # Load configuration.
        !           356: #
1.1.1.1   knu       357: if (-f $config) {
1.1.1.37! simon     358:   do "$config" or config_error($config, $@);
1.1.1.8   knu       359: } else {
1.1.1.37! simon     360:   fatal("500 Internal Error",
        !           361:         'Configuration not found.  Set the parameter <code>$config</code> in cvsweb.cgi to your <b>cvsweb.conf</b> configuration file first.');
        !           362: }
        !           363:
        !           364: # Try to find a readable dir where we can cd into.  Some abs_path()
        !           365: # implementations as well as various cvs operations require such a dir to
        !           366: # work properly.
        !           367: {
        !           368:   local $^W = 0;
        !           369:   for my $dir (tmpdir(), rootdir()) {
        !           370:     last if (-r $dir && chdir($dir));
        !           371:   }
        !           372: }
        !           373:
        !           374: $CSS = $cssurl ?
        !           375:   sprintf("<link rel=\"stylesheet\" type=\"text/css\" href=\"%s\" />\n",
        !           376:           htmlquote($cssurl)) : '';
        !           377:
        !           378: # --- input parameters
        !           379:
        !           380: my %query = ();
        !           381: if (defined($ENV{QUERY_STRING})) {
        !           382:   for my $p (split(/[;&]+/, $ENV{QUERY_STRING})) {
        !           383:     next unless $p;
        !           384:     $p =~ y/+/ /;
        !           385:     my ($key, $val) = split(/=/, $p, 2);
        !           386:     next unless defined($key);
        !           387:     $val = 1 unless defined($val);
        !           388:     ($key = uri_unescape($key)) =~ /[[:graph:]]/ or next;
        !           389:     ($val = uri_unescape($val)) =~ /[[:graph:]]/ or next;
        !           390:     $query{$key} = $val;
        !           391:   }
1.1.1.1   knu       392: }
                    393:
                    394: undef %input;
                    395:
1.1.1.37! simon     396: my $t;
        !           397: for my $p (qw(graph hideattic hidecvsroot hidenonreadable ignorecase ln copt
        !           398:               makeimage options tarball)) {
        !           399:   $t = $query{$p};
        !           400:   if (defined($t)) {
        !           401:     ($input{$p}) = ($t =~ /^([01]|on)$/)
        !           402:       or fatal('500 Internal Error',
        !           403:                'Invalid boolean value: <code>%s=%s</code>', $p, $t);
        !           404:   }
        !           405: }
        !           406: for my $p (qw(annotate r1 r2 rev tr1 tr2)) {
        !           407:   $t = $query{$p};
        !           408:   if (defined($t)) {
        !           409:     if (($p eq 'r1' || $p eq 'r2') && $t eq 'text') {
        !           410:       # Special case for the "Use text field" option in the log view diff form.
        !           411:       $input{$p} = $t;
        !           412:       next;
        !           413:     } elsif (($p eq 'rev' || $p eq 'annotate') && ($t eq '.' || $t eq 'HEAD')){
        !           414:       # Another special case, allow linking to latest revision using these.
        !           415:       $input{$p} = '.';
        !           416:       next;
        !           417:     }
        !           418:     my ($rev, $tag) = split(/:/, $t, 2);
        !           419:     ($input{$p}) = ($rev =~ /^(\d+(?:\.\d+)*)$/)
        !           420:       or fatal('500 Internal Error',
        !           421:                'Invalid revision: <code>%s=%s</code>', $p, $t);
        !           422:     if (defined($tag)) {
        !           423:       ($tag) = ($tag =~ VALID_TAG1)
        !           424:         or fatal('500 Internal Error',
        !           425:                  'Invalid tag/branch name in revision: <code>%s=%s</code>',
        !           426:                  $p, $t);
        !           427:       ($tag) = ($tag =~ VALID_TAG2)
        !           428:         or fatal('500 Internal Error',
        !           429:                  'Invalid tag/branch name in revision: <code>%s=%s</code>',
        !           430:                  $p, $t);
        !           431:       $input{$p} .= ':' . $tag;
        !           432:     }
        !           433:   }
        !           434: }
        !           435: $t = defined($query{only_with_tag}) ?
        !           436:   $query{only_with_tag} : $query{only_on_branch}; # Backwards compatibility.
        !           437: if (defined($t)) {
        !           438:   ($input{only_with_tag}) = ($t =~ VALID_TAG1)
        !           439:     or fatal('500 Internal Error',
        !           440:              'Invalid tag/branch name: <code>%s</code>', $t);
        !           441:   ($input{only_with_tag}) = ($t =~ VALID_TAG2)
        !           442:     or fatal('500 Internal Error',
        !           443:              'Invalid tag/branch name: <code>%s</code>', $t);
        !           444: }
        !           445: $t = $query{logsort};
        !           446: if (defined($t)) {
        !           447:   ($input{logsort}) = ($t =~ /^(cvs|date|rev)$/)
        !           448:     or fatal('500 Internal Error',
        !           449:              'Unsupported log sort key: <code>%s</code>', $t);
        !           450: }
        !           451: $t = $query{f};
        !           452: if (defined($t)) {
        !           453:   ($input{f}) = ($t =~ /^(([hH]|[ucs]c?)|ext\d*)$/)
        !           454:     or fatal('500 Internal Error',
        !           455:              'Unsupported diff format: <code>%s</code>', $t);
        !           456: }
        !           457: $t = $query{sortby};
        !           458: if (defined($t)) {
        !           459:   ($input{sortby}) = ($t =~ /^(file|date|rev|author|log)$/)
        !           460:     or fatal('500 Internal Error',
        !           461:              'Unsupported dir sort key: <code>%s</code>', $t);
        !           462: }
        !           463: $t = $query{'content-type'};
        !           464: if (defined($t)) {
        !           465:   ($input{'content-type'}) = ($t =~ m|^([-0-9A-Za-z]+/[-0-9A-Za-z\.\+]+)$|)
        !           466:     or fatal('500 Internal Error',
        !           467:              'Unsupported content type: <code>%s</code>', $t);
        !           468: }
        !           469: $t = $query{cvsroot};
        !           470: if (defined($t)) {
        !           471:   ($input{cvsroot}) = ($t =~ /^([[:print:]]+)$/)
        !           472:     or fatal('500 Internal Error',
        !           473:              'Invalid symbolic CVS root name: <code>%s</code>', $t);
        !           474: }
        !           475: $t = $query{path};
        !           476: if (defined($t)) {
        !           477:   ($input{path}) = ($t =~ VALID_PATH)
        !           478:     or fatal('500 Internal Error',
        !           479:              'Invalid path: <code>%s</code>', $t);
        !           480: }
        !           481: undef($t);
        !           482: undef(%query);
        !           483:
        !           484: # --- end input parameters
        !           485:
        !           486: #
        !           487: # CVS roots
        !           488: #
        !           489: my $rootfound = 0;
        !           490: for (my $i = 0; $i < scalar(@CVSrepositories); $i += 2) {
        !           491:   my $key = $CVSrepositories[$i];
        !           492:   my ($descr, $root) = @{$CVSrepositories[$i+1]};
        !           493:   $root = canonpath($root);
        !           494:   unless (-d $root) {
        !           495:     warn("Root '$root' defined in \@CVSrepositories is not a directory, " .
        !           496:          'entry ignored');
        !           497:     next;
        !           498:   }
        !           499:   $rootfound ||= 1;
        !           500:   $cvstreedefault = $key unless defined($cvstreedefault);
        !           501:   $CVSROOTdescr{$key} = $descr;
        !           502:   $CVSROOT{$key} = $root;
        !           503:   push(@CVSROOT, $key);
        !           504: }
        !           505: unless ($rootfound) {
        !           506:   fatal('500 Internal Error',
        !           507:         'No valid CVS roots found!  See <code>@CVSrepositories</code> in ' .
        !           508:         'the configuration file (<code>%s</code>).',
        !           509:         $config);
        !           510: }
        !           511: undef $rootfound;
        !           512:
        !           513: #
        !           514: # Default CVS root
        !           515: #
        !           516: if (!defined($CVSROOT{$cvstreedefault})) {
        !           517:   fatal("500 Internal Error",
        !           518:         '<code>$cvstreedefault</code> points to a repository (%s) not ' .
        !           519:         'defined in <code>@CVSrepositories</code> in your configuration ' .
        !           520:         'file (<code>%s</code>).',
        !           521:         $cvstreedefault,
        !           522:         $config);
        !           523: }
        !           524:
        !           525: $DEFAULTVALUE{cvsroot} = $cvstreedefault;
        !           526:
        !           527: while (my ($key, $defval) = each %DEFAULTVALUE) {
        !           528:
        !           529:   # Replace not given parameters with defaults.
        !           530:   next unless (defined($defval) && $defval =~ /\S/ && !defined($input{$key}));
        !           531:
        !           532:   # Empty checkboxes in forms return nothing, so we define a helper parameter
        !           533:   # in these forms (copt) which indicates that we just set parameters with a
        !           534:   # checkbox.
        !           535:   if ($input{copt}) {
        !           536:
        !           537:     # 'copt' is set -> the result of empty input checkbox
        !           538:     # -> set to zero (disable) if default is a boolean (0|1).
        !           539:     $input{$key} = 0 if ($defval eq '0' || $defval eq '1');
        !           540:
        !           541:   } else {
        !           542:
        !           543:     # 'copt' isn't set --> empty input is not the result
        !           544:     # of empty input checkbox --> set default.
        !           545:     $input{$key} = $defval;
        !           546:   }
1.1.1.1   knu       547: }
1.1.1.2   knu       548:
1.1.1.1   knu       549: $barequery = "";
1.1.1.10  knu       550: my @barequery;
1.1.1.1   knu       551: foreach (@stickyvars) {
1.1.1.28  knu       552:
1.1.1.37! simon     553:   # construct a query string with the sticky non default parameters set
        !           554:   if (defined($input{$_})
        !           555:       && !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_}))
        !           556:   {
        !           557:     push(@barequery, join('=', uri_escape($_), uri_escape($input{$_})));
        !           558:   }
        !           559: }
        !           560:
        !           561: if ($allow_enscript) {
        !           562:   push(@DIFFTYPES, qw(uc cc sc));
        !           563:   @DIFFTYPES{qw(uc cc sc)} = (
        !           564:     {
        !           565:      'descr'   => 'unified, colored',
        !           566:      'opts'    => ['-u'],
        !           567:      'colored' => 0,
        !           568:     },
        !           569:     {
        !           570:      'descr'   => 'context, colored',
        !           571:      'opts'    => ['-c'],
        !           572:      'colored' => 0,
        !           573:     },
        !           574:     {
        !           575:      'descr'   => 'side by side, colored',
        !           576:      # width=168 should be enough to support 80 character line lengths
        !           577:      'opts'    => ['--side-by-side', '--width=168'],
        !           578:      'colored' => 0,
        !           579:     },
        !           580:   );
        !           581: } else {
        !           582:   # No Enscript -> respect difftype, but don't offer colorization.
        !           583:   if ($input{f} && $input{f} =~ /^([ucs])c$/) {
        !           584:     $input{f} = $1;
        !           585:   }
1.1.1.1   knu       586: }
1.1.1.28  knu       587:
1.1.1.1   knu       588: # is there any query ?
1.1.1.10  knu       589: if (@barequery) {
1.1.1.37! simon     590:   $barequery = join (';', @barequery);
        !           591:   $query     = "?$barequery";
        !           592:   $barequery = ";$barequery";
1.1.1.28  knu       593: } else {
1.1.1.37! simon     594:   $query = "";
1.1.1.1   knu       595: }
1.1.1.10  knu       596: undef @barequery;
1.1.1.1   knu       597:
1.1.1.20  knu       598: if (defined($input{path})) {
1.1.1.37! simon     599:   redirect("$scriptname/$input{path}$query");
1.1.1.20  knu       600: }
                    601:
1.1.1.1   knu       602: # get actual parameters
1.1.1.30  knu       603: {
1.1.1.37! simon     604:   my $sortby = $input{sortby} || 'file';
        !           605:   $bydate    = 0;
        !           606:   $byrev     = 0;
        !           607:   $byauthor  = 0;
        !           608:   $bylog     = 0;
        !           609:   $byfile    = 0;
        !           610:   if ($sortby eq 'date') {
        !           611:     $bydate = 1;
        !           612:   } elsif ($sortby eq 'rev') {
        !           613:     $byrev = 1;
        !           614:   } elsif ($sortby eq 'author') {
        !           615:     $byauthor = 1;
        !           616:   } elsif ($sortby eq 'log') {
        !           617:     $bylog = 1;
        !           618:   } else {
        !           619:     $byfile = 1;
        !           620:   }
1.1.1.20  knu       621: }
1.1.1.1   knu       622:
1.1.1.37! simon     623: $defaultDiffType = $input{f};
        !           624:
        !           625: $logsort = $input{logsort};
1.1.1.1   knu       626:
                    627: # alternate CVS-Tree, configured in cvsweb.conf
1.1.1.37! simon     628: if ($input{cvsroot} && $CVSROOT{$input{cvsroot}}) {
        !           629:   $cvstree = $input{cvsroot};
1.1.1.1   knu       630: } else {
1.1.1.37! simon     631:   $cvstree = $cvstreedefault;
1.1.1.1   knu       632: }
                    633:
                    634: $cvsroot = $CVSROOT{$cvstree};
                    635:
                    636: # create icons out of description
1.1.1.36  scop      637: foreach my $k (keys %ICONS) {
1.1.1.37! simon     638:   my ($itxt, $ipath, $iwidth, $iheight) = @{$ICONS{$k}};
        !           639:   no strict 'refs';
        !           640:   if ($ipath) {
        !           641:     ${"${k}icon"} =
        !           642:       sprintf('<img src="%s" alt="%s" border="0" width="%d" height="%d" />',
        !           643:               htmlquote($ipath), htmlquote($itxt), $iwidth, $iheight);
        !           644:   } else {
        !           645:     ${"${k}icon"} = $itxt;
        !           646:   }
1.1.1.1   knu       647: }
                    648:
1.1.1.8   knu       649: my $config_cvstree = "$config-$cvstree";
                    650:
1.1.1.1   knu       651: # Do some special configuration for cvstrees
1.1.1.8   knu       652: if (-f $config_cvstree) {
1.1.1.37! simon     653:   do "$config_cvstree"
        !           654:     or fatal("500 Internal Error",
        !           655:              'Error in loading configuration file: %s<br /><br />%s<br />',
        !           656:              $config_cvstree, $@);
1.1.1.8   knu       657: }
1.1.1.10  knu       658: undef $config_cvstree;
1.1.1.1   knu       659:
1.1.1.37! simon     660: $re_prcategories  = '(?:' . join ('|', @prcategories) . ')' if @prcategories;
        !           661: $re_prkeyword     = quotemeta($prkeyword) if defined($prkeyword);
        !           662: $prcgi           .= '%s' if defined($prcgi) && $prcgi !~ /%s/;
1.1       jfieber   663:
1.1.1.37! simon     664: $fullname         = catfile($cvsroot, $where);
1.1.1.21  knu       665:
1.1.1.37! simon     666: my $rewrite = 0;
1.1.1.21  knu       667: if ($pathinfo =~ m|//|) {
1.1.1.37! simon     668:   $pathinfo =~ y|/|/|s;
        !           669:   $rewrite = 1;
1.1.1.21  knu       670: }
1.1.1.37! simon     671: if (-d $fullname) {
        !           672:   if ($pathinfo !~ m|/$|) {
        !           673:     $pathinfo .= '/';
        !           674:     $rewrite   = 1;
        !           675:   }
        !           676: } elsif ($pathinfo =~ m|/$|) {
        !           677:   chop $pathinfo;
        !           678:   $rewrite = 1;
1.1.1.1   knu       679: }
1.1.1.21  knu       680: if ($rewrite) {
1.1.1.37! simon     681:   redirect($scriptname . uri_escape_path($pathinfo) . $query, 1);
1.1.1.21  knu       682: }
                    683: undef $rewrite;
                    684:
1.1.1.37! simon     685: undef $pathinfo;
        !           686:
1.1.1.1   knu       687: if (!-d $cvsroot) {
1.1.1.37! simon     688:   fatal("500 Internal Error",
        !           689:         '$CVSROOT not found!<p>The server on which the CVS tree lives is probably down.  Please try again in a few minutes.');
1.1.1.1   knu       690: }
                    691:
                    692: #
1.1.1.37! simon     693: # Short-circuit forbidden things.  Note that $fullname should not change
        !           694: # after this, because the rest of the code assumes this check has already
        !           695: # been done.
1.1.1.1   knu       696: #
1.1.1.37! simon     697: fatal('403 Forbidden', 'Access to %s forbidden.', $where)
        !           698:   if forbidden($fullname);
1.1.1.16  knu       699:
                    700: #
                    701: # Handle tarball downloads before any headers are output.
                    702: #
                    703: if ($input{tarball}) {
1.1.1.37! simon     704:   fatal('403 Forbidden', 'Downloading tarballs is prohibited.')
        !           705:     unless $allow_tar;
        !           706:
        !           707:   my ($module)  =  ($where =~ m,^/?(.*),);    # untaint
        !           708:   $module       =~ s,/([^/]*)$,,;
        !           709:   my ($ext)     =  ($1 =~ /(\.t(?:ar\.)?gz|\.zip)$/);
        !           710:   my ($basedir) =  ($module =~ m,([^/]+)$,);
        !           711:
        !           712:   if ($basedir eq '' || $module eq '') {
        !           713:     fatal('500 Internal Error',
        !           714:           'You cannot download the top level directory.');
        !           715:   }
        !           716:
        !           717:   my $istar = ($ext eq '.tar.gz' || $ext eq '.tgz');
        !           718:   if ($istar) {
        !           719:     fatal('500 Internal Error', 'tar command not found.') unless $CMD{tar};
        !           720:     fatal('500 Internal Error', 'gzip command not found.') unless $CMD{gzip};
        !           721:   }
        !           722:   my $iszip = ($ext eq '.zip');
        !           723:   if ($iszip && !$CMD{zip}) {
        !           724:     fatal('500 Internal Error', 'zip command not found.');
        !           725:   }
        !           726:   if (!$istar && !$iszip) {
        !           727:     fatal('500 Internal Error', 'Unsupported archive type.');
        !           728:   }
        !           729:
        !           730:   my $tmpexportdir;
        !           731:   eval {
        !           732:     local $SIG{__DIE__};
        !           733:     # Don't use the CLEANUP argument to tempdir() here, since we might be under
        !           734:     # mod_perl (the process runs for a long time), unlink explicitly later.
        !           735:     $tmpexportdir = tempdir('.cvsweb.XXXXXXXX', TMPDIR => 1);
        !           736:   };
        !           737:   if ($@) {
        !           738:     fatal('500 Internal Error', 'Unable to make temporary directory: %s', $@);
        !           739:   }
        !           740:   if (!chdir($tmpexportdir)) {
        !           741:     fatal('500 Internal Error',
        !           742:           "Can't cd to temporary directory %s: %s", $tmpexportdir, $!);
        !           743:   }
        !           744:
        !           745:   my @fatal;
        !           746:   my $tag = $input{only_with_tag} || 'HEAD';
        !           747:   $tag = 'HEAD' if ($tag eq 'MAIN');
        !           748:
        !           749:   my @cmd =
        !           750:     ($CMD{cvs}, @cvs_options, '-Qd', $cvsroot, 'export', '-r', $tag,
        !           751:      '-d', $basedir, $module);
        !           752:   my $export_err;
        !           753:   my ($errcode, $err) = runproc(\@cmd, '2>', \$export_err);
        !           754:   if ($errcode) {
        !           755:     @fatal =
        !           756:       ('500 Internal Error',
        !           757:        'Export failure (exit status %s), output: <pre>%s</pre>',
        !           758:        $errcode, $err || $export_err);
        !           759:
        !           760:   } else {
        !           761:
        !           762:     $| = 1;    # Essential to get the buffering right.
        !           763:     local (*TAR_OUT);
        !           764:
        !           765:     my (@cmd, $ctype);
        !           766:     if ($istar) {
        !           767:       my @tar = ($CMD{tar}, @tar_options, '-cf', '-', $basedir);
        !           768:       my @gzip = ($CMD{gzip}, @gzip_options, '-c');
        !           769:       push(@cmd, \@tar, '|', \@gzip);
        !           770:       $ctype = 'application/x-gzip';
        !           771:     } elsif ($iszip) {
        !           772:       my @zip = ($CMD{zip}, @zip_options, '-r', '-', $basedir);
        !           773:       push(@cmd, \@zip, \'');
        !           774:       $ctype = 'application/zip';
        !           775:     }
        !           776:     push(@cmd, '>pipe', \*TAR_OUT);
        !           777:
        !           778:     my ($h, $err) = startproc(@cmd);
        !           779:     if ($h) {
        !           780:       print "Content-Type: $ctype\r\n\r\n";
        !           781:       local $/ = undef;
        !           782:       print <TAR_OUT>;
        !           783:       $h->finish();
        !           784:     } else {
        !           785:       @fatal = ('500 Internal Error',
        !           786:                 '%s failure (exit status %s), output: <pre>%s</pre>',
        !           787:                 $istar ? 'Tar' : 'Zip', $? >> 8 || -1, $err);
        !           788:     }
        !           789:   }
1.1.1.16  knu       790:
1.1.1.37! simon     791:   # Clean up.
        !           792:   rmtree($tmpexportdir);
1.1.1.16  knu       793:
1.1.1.37! simon     794:   &fatal(@fatal) if @fatal;
1.1.1.16  knu       795:
1.1.1.37! simon     796:   exit;
1.1.1.16  knu       797: }
                    798:
1.1.1.1   knu       799: ##############################
                    800: # View a directory
                    801: ###############################
1.1.1.16  knu       802: if (-d $fullname) {
1.1.1.37! simon     803:
        !           804:   my $dh = do { local (*DH); };
        !           805:   opendir($dh, $fullname) or fatal("404 Not Found", '%s: %s', $where, $!);
        !           806:   my @dir = grep(!forbidden(catfile($fullname, $_)), readdir($dh));
        !           807:   closedir($dh);
        !           808:   my @subLevelFiles = findLastModifiedSubdirs(@dir) if $show_subdir_lastmod;
        !           809:   my @unreadable = getDirLogs($cvsroot, $where, @subLevelFiles);
        !           810:
        !           811:   if ($where eq '/') {
        !           812:     html_header($defaulttitle);
        !           813:     $long_intro =~ s/!!CVSROOTdescr!!/$CVSROOTdescr{$cvstree}/g;
        !           814:     print $long_intro;
        !           815:   } else {
        !           816:     html_header($where);
        !           817:     my $html = (-f catfile($fullname, 'README.cvs.html,v') ||
        !           818:                 -f catfile($fullname, 'Attic', 'README.cvs.html,v'));
        !           819:     my $text = (!$html &&
        !           820:                 (-f catfile($fullname, 'README.cvs,v') ||
        !           821:                  -f catfile($fullname, 'Attic', 'README.cvs,v')));
        !           822:     if ($html || $text) {
        !           823:       my $rev = $input{only_with_tag} || 'HEAD';
        !           824:       my $cr = abs_path($cvsroot) || $cvsroot;
        !           825:       my $co = "$where/README.cvs.html" if $html;
        !           826:       $co ||= "$where/README.cvs" if $text;
        !           827:       # abs_path() taints when run as a CGI...
        !           828:       if ($cr =~ VALID_PATH) {
        !           829:         $cr = $1;
        !           830:       } else {
        !           831:         fatal('500 Internal Error', 'Illegal CVS root: <code>%s</code>', $cr);
        !           832:       }
        !           833:       my @cmd = ($CMD{cvs}, @cvs_options, '-d', $cr, 'co', '-p', "-r$rev",$co);
        !           834:       local (*CVS_OUT, *CVS_ERR);
        !           835:       my ($h, $err) = startproc(\@cmd, \"", '>pipe', \*CVS_OUT,
        !           836:                                 '2>pipe', \*CVS_ERR);
        !           837:       fatal('500 Internal Error', $err) unless $h;
        !           838:       if ($html) {
        !           839:         local $/ = undef;
        !           840:         print <CVS_OUT>;
        !           841:       } else {
        !           842:         print "<p>\n";
        !           843:         while (<CVS_OUT>) {
        !           844:           chomp;
        !           845:           print htmlquote($_), '<br />';
        !           846:         }
        !           847:         print "</p>";
        !           848:       }
        !           849:       $h->finish();
        !           850:     }
        !           851:     print $short_instruction;
        !           852:   }
        !           853:
        !           854:   if ($use_descriptions &&
        !           855:       open(DESC, catfile($cvsroot, 'CVSROOT', 'descriptions'))) {
        !           856:     while (<DESC>) {
        !           857:       chomp;
        !           858:       my ($dir, $description) = /(\S+)\s+(.*)/;
        !           859:       $descriptions{$dir} = $description;
        !           860:     }
        !           861:     close(DESC);
        !           862:   }
        !           863:
        !           864:   print "<p><a name=\"dirlist\"></a></p>\n";
        !           865:
        !           866:   # give direct access to dirs
        !           867:   if ($where eq '/') {
        !           868:     chooseMirror();
        !           869:     chooseCVSRoot();
        !           870:
        !           871:   } else {
        !           872:     print '<p>Current directory: <b>', clickablePath($where, 0), '</b>';
        !           873:     if ($cvshistory_url) {
        !           874:       (my $d = $where) =~ s|^/*(.*?)/*$|$1|;
        !           875:       print ' - ', history_link($d, '');
        !           876:     }
        !           877:     print "</p>\n";
        !           878:     print "<p>Current tag: <b>", htmlquote($input{only_with_tag}), "</b></p>\n"
        !           879:       if $input{only_with_tag};
        !           880:   }
        !           881:
        !           882:   print "<hr />\n";
        !           883:
        !           884:   my $infocols = 1;
        !           885:
        !           886:   printf(<<EOF, 'Directory index of ' . htmlquote($where));
        !           887: <table class="dir" width="100%%" cellspacing="0" cellpadding="$tablepadding" summary="%s">
        !           888: <tr>
        !           889: EOF
        !           890:   printf('<th colspan="2"%s>', ($byfile ? ' class="sorted"' : ''));
        !           891:
        !           892:   if ($byfile) {
        !           893:     print 'File';
        !           894:   } else {
        !           895:     print &link('File',
        !           896:                 sprintf('./%s#dirlist', toggleQuery('sortby', 'file')));
        !           897:   }
        !           898:   print "</th>\n";
        !           899:
        !           900:   # Do not display the other column headers if we do not have any files
        !           901:   # with revision information.
        !           902:   if (scalar(%fileinfo)) {
        !           903:     $infocols++;
        !           904:     printf('<th%s>', ($byrev ? ' class="sorted"' : ''));
        !           905:
        !           906:     if ($byrev) {
        !           907:       print 'Rev.';
        !           908:     } else {
        !           909:       print &link('Rev.',
        !           910:                   sprintf('./%s#dirlist', toggleQuery('sortby', 'rev')));
        !           911:     }
        !           912:     print "</th>\n";
        !           913:     $infocols++;
        !           914:     printf('<th%s>', ($bydate ? ' class="sorted"' : ''));
        !           915:
        !           916:     if ($bydate) {
        !           917:       print 'Age';
        !           918:     } else {
        !           919:       print &link('Age',
        !           920:                   sprintf('./%s#dirlist', toggleQuery('sortby', 'date')));
        !           921:     }
        !           922:     print "</th>\n";
        !           923:
        !           924:     if ($show_author) {
        !           925:       $infocols++;
        !           926:       printf('<th%s>', ($byauthor ? ' class="sorted"' : ''));
        !           927:
        !           928:       if ($byauthor) {
        !           929:         print 'Author';
        !           930:       } else {
        !           931:         print
        !           932:           &link('Author',
        !           933:                 sprintf('./%s#dirlist', toggleQuery('sortby', 'author')));
        !           934:       }
        !           935:       print "</th>\n";
        !           936:     }
        !           937:     $infocols++;
        !           938:     printf('<th%s>', ($bylog ? ' class="sorted"' : ''));
        !           939:
        !           940:     if ($bylog) {
        !           941:       print 'Last log entry';
        !           942:     } else {
        !           943:       print &link('Last log entry',
        !           944:                   sprintf('./%s#dirlist', toggleQuery('sortby', 'log')));
        !           945:     }
        !           946:     print "</th>\n";
        !           947:   } elsif ($use_descriptions) {
        !           948:     print "<th>Description</th>\n";
        !           949:     $infocols++;
        !           950:   }
        !           951:   print "</tr>\n";
        !           952:
        !           953:   my $dirrow = 0;
        !           954:
        !           955:   my $i;
        !           956:   lookingforattic:
        !           957:   for ($i = 0; $i <= $#dir; $i++) {
        !           958:     if ($dir[$i] eq "Attic") {
        !           959:       last lookingforattic;
        !           960:     }
        !           961:   }
        !           962:
        !           963:   if (!$input{hideattic}
        !           964:       && ($i <= $#dir)
        !           965:       && opendir($dh, $fullname . '/Attic'))
        !           966:   {
        !           967:     splice(@dir, $i, 1, grep((s|^|Attic/|, !m|/\.|), readdir($dh)));
        !           968:     closedir($dh);
        !           969:   }
        !           970:
        !           971:   my $hideAtticToggleLink =
        !           972:     $input{hideattic}
        !           973:     ? ''
        !           974:     : &link('[hide]', sprintf('./%s#dirlist', &toggleQuery('hideattic')));
        !           975:
        !           976:   # Sort without the Attic/ pathname.
        !           977:   # place directories first
        !           978:
        !           979:   my $filesexists;
        !           980:   my $filesfound;
        !           981:
        !           982:   foreach my $file (sort { &fileSortCmp } @dir) {
        !           983:
        !           984:     next if ($file eq curdir());
        !           985:
        !           986:     # ignore CVS lock and stale NFS files
        !           987:     next if ($file =~ /^\#cvs\.|^,|^\.nfs/); # \# for XEmacs cperl-mode...
        !           988:
        !           989:     # Check whether to show the CVSROOT path
        !           990:     next if ($input{hidecvsroot} && $where eq '/' && $file eq 'CVSROOT');
        !           991:
        !           992:     # Is it a directory?
        !           993:     my $isdir = -d catdir($fullname, $file);
        !           994:
        !           995:     # Ignore non-readable files and directories?
        !           996:     next if ($input{hidenonreadable} && (! -r _ || ($isdir && ! -x _)));
        !           997:
        !           998:     my $attic = '';
        !           999:     if ($file =~ s|^Attic/||) {
        !          1000:       $attic = ' <span class="attic">(in the Attic) ' .
        !          1001:         $hideAtticToggleLink . '</span>';
        !          1002:     }
        !          1003:
        !          1004:     if ($file eq updir() || $isdir) {
        !          1005:       next if ($file eq updir() && $where eq '/');
        !          1006:       my ($rev, $date, $log, $author, $filename, $keywordsubst) =
        !          1007:         @{$fileinfo{$file}} if (defined($fileinfo{$file}));
        !          1008:       printf "<tr class=\"%s\">\n<td class=\"dir\" colspan=\"2\">",
        !          1009:         ($dirrow % 2) ? 'even' : 'odd';
        !          1010:
        !          1011:       if ($file eq updir()) {
        !          1012:         my $url = "../$query";
        !          1013:         print $nofilelinks ? $backicon : &link($backicon, $url);
        !          1014:         print '&nbsp;', &link("Parent Directory", $url);
        !          1015:
        !          1016:       } else {
        !          1017:         my $url = './' . uri_escape_path($file) . "/$query";
        !          1018:         print '<a name="', htmlquote($file), '"></a>';
        !          1019:         print $nofilelinks ? $diricon : &link($diricon, $url);
        !          1020:         print '&nbsp;', &link(htmlquote("$file/"), $url), $attic;
        !          1021:         if ($file eq "Attic") {
        !          1022:           print ' <span class="attic">',
        !          1023:             &link('[show]',
        !          1024:                   sprintf('./%s#dirlist', &toggleQuery('hideattic'))),
        !          1025:                     '</span>';
        !          1026:         }
        !          1027:       }
        !          1028:
        !          1029:       # Show last change in dir
        !          1030:       if ($filename) {
        !          1031:         print "</td>\n<td>&nbsp;</td>\n<td class=\"age\">";
        !          1032:         print readableTime(time() - $date, 0) if $date;
        !          1033:         print "</td>\n<td class=\"author\">", htmlquote($author)
        !          1034:           if $show_author;
        !          1035:         print "</td>\n<td class=\"log\">";
        !          1036:         $filename =~ s%^[^/]+/%%;
        !          1037:         print &link(htmlquote("$filename/$rev"),
        !          1038:                     sprintf('%s/%s%s#rev%s',
        !          1039:                             uri_escape($file), uri_escape($filename),
        !          1040:                             $query, $rev)), '<br />';
        !          1041:         if ($log) {
        !          1042:           print htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra);
        !          1043:           print '...' if (length($log) > 80);
        !          1044:         }
        !          1045:
        !          1046:       } else {
        !          1047:         my $dwhere = ($where ne '/' ? $where : '') . $file;
        !          1048:
        !          1049:         if ($use_descriptions && defined $descriptions{$dwhere}) {
        !          1050:           print '<td colspan="', ($infocols - 1), '">';
        !          1051:           print $descriptions{$dwhere};
        !          1052:
        !          1053:         } elsif ($infocols > 1) {
        !          1054:
        !          1055:           # close the row with the appropriate number of
        !          1056:           # columns, so that the vertical seperators are visible
        !          1057:           my ($cols) = $infocols;
        !          1058:           while ($cols > 1) {
        !          1059:             print "</td>\n<td>&nbsp;";
        !          1060:             $cols--;
        !          1061:           }
        !          1062:         }
        !          1063:       }
        !          1064:
        !          1065:       print "</td>\n</tr>\n";
        !          1066:       $dirrow++;
        !          1067:
        !          1068:     } elsif ($file =~ s/,v$//) {
        !          1069:
        !          1070:       my $fileurl = ($attic ? 'Attic/' : '') . uri_escape_path($file);
        !          1071:       my $url     = './' . $fileurl . $query;
        !          1072:       $filesexists++;
        !          1073:       next if (!defined($fileinfo{$file}));
        !          1074:       my ($rev, $date, $log, $author, $filename, $keywordsubst) =
        !          1075:         @{$fileinfo{$file}};
        !          1076:       my $isbinary = $keywordsubst eq 'b' ? 1 : 0;
        !          1077:       $filesfound++;
        !          1078:
        !          1079:       printf "<tr class=\"%s\">\n", ($dirrow % 2) ? 'even' : 'odd';
        !          1080:       printf '<td class="file"%s>', $allow_cvsgraph ? '' : ' colspan="2"';
        !          1081:
        !          1082:       my $icon = $isbinary ? $binfileicon : $fileicon;
        !          1083:       print $nofilelinks ? $icon : &link($icon, $url);
        !          1084:       print '&nbsp;', &link(htmlquote($file), $url), $attic;
        !          1085:       print '</td><td class="graph">', graph_link($fileurl) if $allow_cvsgraph;
        !          1086:       print "</td>\n<td width=\"30\">", display_link($fileurl, $rev);
        !          1087:       print "</td>\n<td class=\"age\">";
        !          1088:       print readableTime(time() - $date, 0) if $date;
        !          1089:       print "</td>\n<td class=\"author\">", htmlquote($author) if $show_author;
        !          1090:       print "</td>\n<td class=\"log\">";
        !          1091:
        !          1092:       if ($log) {
        !          1093:         print htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra);
        !          1094:         print '...' if (length $log > 80);
        !          1095:       }
        !          1096:       print "</td>\n</tr>";
        !          1097:       $dirrow++;
        !          1098:     }
        !          1099:     print "\n";
        !          1100:   }
        !          1101:
        !          1102:   print "</table>\n";
        !          1103:
        !          1104:   if ((my $num = scalar(@unreadable)) && ! $input{hidenonreadable}) {
        !          1105:     printf(<<EOF, $num, htmlquote(join(', ', @unreadable)));
        !          1106: <p>
        !          1107:  <b>NOTE:</b> The following %d unreadable files were ignored:<br />
        !          1108:  <em>%s</em>
        !          1109: </p>
        !          1110: EOF
        !          1111:   }
        !          1112:
        !          1113:   if ($filesexists && !$filesfound) {
        !          1114:     my $currtag = defined($input{only_with_tag}) ?
        !          1115:       sprintf(' (%s)', htmlquote($input{only_with_tag})) : '';
        !          1116:     printf(<<EOF, $filesexists, $currtag);
        !          1117: <p>
        !          1118:  <b>NOTE:</b> There are %d files, but none matches the current tag%s.
        !          1119: </p>
        !          1120: EOF
        !          1121:   }
        !          1122:
        !          1123:   if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}})) {
        !          1124:     %tags = %alltags;
        !          1125:   }
        !          1126:
        !          1127:   if (scalar %tags
        !          1128:       || $input{only_with_tag}
        !          1129:       || $edit_option_form
        !          1130:       || defined($input{options}))
        !          1131:   {
        !          1132:     print "<hr />\n";
        !          1133:   }
        !          1134:
        !          1135:   if (scalar %tags || $input{only_with_tag}) {
        !          1136:     print "<form method=\"get\" action=\"./\">\n<p>\n";
        !          1137:     foreach my $var (@stickyvars) {
        !          1138:       printf("<input type=\"hidden\" name=\"$var\" value=\"%s\" />\n",
        !          1139:              htmlquote($input{$var}))
        !          1140:         if (defined($input{$var})
        !          1141:             && (!defined($DEFAULTVALUE{$var})
        !          1142:                 || $input{$var} ne $DEFAULTVALUE{$var})
        !          1143:             && $var ne 'only_with_tag');
        !          1144:     }
        !          1145:     printf(<<EOF, ($use_java_script ? ' onchange="this.form.submit()"' : ''));
        !          1146: <span class="nowrap">
        !          1147: <label for="only_with_tag" accesskey="T">Show only files with tag:
        !          1148: <select id="only_with_tag" name="only_with_tag"%s>
        !          1149: <option value="">All tags / default branch</option>
        !          1150: EOF
        !          1151:     foreach my $tag (reverse sort { lc $a cmp lc $b } keys %tags) {
        !          1152:       my $selected =
        !          1153:         defined($input{only_with_tag}) && $input{only_with_tag} eq $tag;
        !          1154:       printf("<option%s>%s</option>\n",
        !          1155:              $selected ? ' selected="selected"' : '',
        !          1156:              htmlquote($tag));
        !          1157:     }
        !          1158:     printf(<<EOF, htmlquote($where));
        !          1159: </select>
        !          1160: </label></span> <span class="nowrap">
        !          1161: <label for="path" accesskey="P">Module path or alias:
        !          1162: <input type="text" id="path" name="path" value="%s" size="15" /></label>
        !          1163: </span>
        !          1164: <input type="submit" value="Go" accesskey="G" />
        !          1165: </p>
        !          1166: </form>
        !          1167: EOF
        !          1168:   }
        !          1169:
        !          1170:   if ($allow_tar && $filesfound) {
        !          1171:     my ($basefile) = ($where =~ m,(?:.*/)?([^/]+),);
        !          1172:     my $havetar = $CMD{tar} && $CMD{gzip};
        !          1173:     my $havezip = $CMD{zip};
        !          1174:     if (defined($basefile) && $basefile ne '' && ($havetar || $havezip)) {
        !          1175:       my $q = ($query ? "$query;" : '?') . 'tarball=1';
        !          1176:       print "<hr />\n",
        !          1177:         '<div style="text-align: center">Download this directory in ';
        !          1178:       # Mangle the filename so browsers show a reasonable filename to download.
        !          1179:       my @types = ();
        !          1180:       $basefile = uri_escape($basefile);
        !          1181:       push(@types, &link('tarball', "$basefile.tar.gz$q")) if $havetar;
        !          1182:       push(@types, &link('zip archive', "$basefile.zip$q")) if $havezip;
        !          1183:       print join(' or ', @types), "</div>\n";
        !          1184:     }
        !          1185:   }
        !          1186:
        !          1187:   if ($edit_option_form || defined($input{options})) {
        !          1188:
        !          1189:     print <<EOF;
        !          1190: <form method="get" action="./">
        !          1191: <fieldset>
        !          1192: <legend>General options</legend>
        !          1193: <input type="hidden" name="copt" value="1" />
        !          1194: EOF
        !          1195:     for my $v qw(hidecvsroot hidenonreadable) {
        !          1196:       printf(qq{<input type="hidden" name="%s" value="%s" />\n},
        !          1197:              $v, $input{$v} || 0);
        !          1198:     }
        !          1199:     if ($cvstree ne $cvstreedefault) {
        !          1200:       print "<input type=\"hidden\" name=\"cvsroot\" value=\"$cvstree\" />\n";
        !          1201:     }
        !          1202:     print <<EOF;
        !          1203: <table summary="General options">
        !          1204: <tr>
        !          1205: <td class="opt-label">
        !          1206: <label for="sortby" accesskey="F">Sort files by:</label>
        !          1207: </td>
        !          1208: <td class="opt-value">
        !          1209: <select id="sortby" name="sortby">
        !          1210: <option value="">File</option>
        !          1211: EOF
        !          1212:     print "<option", $bydate ? ' selected="selected"' : '',
        !          1213:       " value=\"date\">Age</option>\n";
        !          1214:     print "<option", $byauthor ? ' selected="selected"' : '',
        !          1215:       " value=\"author\">Author</option>\n"
        !          1216:         if $show_author;
        !          1217:     print "<option", $byrev ? ' selected="selected"' : '',
        !          1218:       " value=\"rev\">Revision</option>\n";
        !          1219:     print "<option", $bylog ? ' selected="selected"' : '',
        !          1220:       " value=\"log\">Log message</option>\n";
        !          1221:     print <<EOF;
        !          1222: </select>,
        !          1223: <label for="ignorecase" accesskey="I">case-insensitive:
        !          1224: EOF
        !          1225:     print '<input id="ignorecase" name="ignorecase" type="checkbox"',
        !          1226:       $input{ignorecase} ? ' checked="checked"' : '',
        !          1227:         " value=\"1\" /></label>\n";
        !          1228:     print <<EOF;
        !          1229: </td>
        !          1230: <td class="opt-label">
        !          1231: <label for="hideattic" accesskey="A">Hide files in Attic:</label>
        !          1232: </td>
        !          1233: <td class="opt-value">
        !          1234: EOF
        !          1235:     print '<input id="hideattic" name="hideattic" type="checkbox"',
        !          1236:       $input{hideattic} ? ' checked="checked"' : '', ' value="1" />';
        !          1237:     print <<EOF;
        !          1238: </td>
        !          1239: </tr>
        !          1240: <tr>
        !          1241: <td class="opt-label">
        !          1242: <label for="logsort" accesskey="L">Sort log by:</label>
        !          1243: </td>
        !          1244: <td class="opt-value">
        !          1245: EOF
        !          1246:     printLogSortSelect(0);
        !          1247:     print <<EOF;
        !          1248: </td>
        !          1249: <td class="opt-label">
        !          1250: <label for="ln" accesskey="N">Show line numbers:</label>
        !          1251: </td>
        !          1252: <td class="opt-value">
        !          1253: EOF
        !          1254:     print '<input id="ln" name="ln" type="checkbox"',
        !          1255:       $input{ln} ? ' checked="checked"' : '', " value=\"1\" />\n";
        !          1256:     print <<EOF;
        !          1257: </td>
        !          1258: </tr>
        !          1259: <tr>
        !          1260: <td class="opt-label">
        !          1261: <label for="f" accesskey="D">Diff format:</label>
        !          1262: </td>
        !          1263: <td>
        !          1264: EOF
        !          1265:     printDiffSelect(0);
        !          1266:     print <<EOF;
        !          1267: </td>
        !          1268: <td colspan="2" class="opt-label">
        !          1269: <input type="submit" value="Change Options" accesskey="C" />
        !          1270: </td>
        !          1271: </tr>
        !          1272: </table>
        !          1273: </fieldset>
        !          1274: </form>
        !          1275: EOF
        !          1276:   }
        !          1277:   html_footer();
1.1.1.28  knu      1278: }
1.1.1.1   knu      1279:
                   1280: ###############################
                   1281: # View Files
                   1282: ###############################
1.1.1.28  knu      1283: elsif (-f $fullname . ',v') {
1.1.1.33  scop     1284:
1.1.1.37! simon    1285:   if (defined($input{rev}) || $doCheckout) {
        !          1286:     &doCheckout($fullname, $input{rev}, $input{only_with_tag});
        !          1287:     gzipclose();
        !          1288:     exit;
        !          1289:   }
        !          1290:
        !          1291:   if (defined($input{annotate}) && $allow_annotate) {
        !          1292:     &doAnnotate($input{annotate}, $input{only_with_tag});
        !          1293:     gzipclose();
        !          1294:     exit;
        !          1295:   }
        !          1296:
        !          1297:   if (defined($input{r1}) && defined($input{r2})) {
        !          1298:     &doDiff($fullname,  $input{r1},  $input{tr1},
        !          1299:             $input{r2}, $input{tr2}, $input{f});
        !          1300:     gzipclose();
        !          1301:     exit;
        !          1302:   }
        !          1303:
        !          1304:   if ($allow_cvsgraph && $input{graph}) {
        !          1305:     if ($input{makeimage}) {
        !          1306:       doGraph();
        !          1307:     } else {
        !          1308:       doGraphView();
        !          1309:     }
        !          1310:     gzipclose();
        !          1311:     exit;
        !          1312:   }
1.1.1.28  knu      1313:
1.1.1.37! simon    1314:   &doLog($fullname);
        !          1315: }
        !          1316:
        !          1317: ##############################
        !          1318: # View Diff
        !          1319: ##############################
        !          1320: elsif ($fullname =~ s/\.diff$//
        !          1321:        && -f $fullname . ',v' && $input{r1} && $input{r2})
        !          1322: {
        !          1323:
        !          1324:   # $where-diff-removal if 'cvs rdiff' is used
        !          1325:   # .. but 'cvs rdiff'doesn't support some options
        !          1326:   # rcsdiff does (-w and -p), so it is disabled
        !          1327:   # $where =~ s/\.diff$//;
        !          1328:
        !          1329:   # Allow diffs using the ".diff" extension so that browsers that default
        !          1330:   # to the filename in the URL when saving don't save diffs as eg. foo.c.
        !          1331:   &doDiff($fullname,  $input{r1},  $input{tr1},
        !          1332:           $input{r2}, $input{tr2}, $input{f});
        !          1333:   gzipclose();
        !          1334:   exit;
        !          1335:
        !          1336: }
        !          1337:
        !          1338: elsif (do { (my $tmp = $fullname) =~ s|/([^/]+)$|/Attic/$1|; -f "$tmp,v" }) {
        !          1339:   # The file has been removed and is in the Attic.
        !          1340:   # Send a redirect pointing to the file in the Attic.
        !          1341:   (my $newplace = $scriptwhere) =~ s|/([^/]+)$|/Attic/$1|;
        !          1342:   if ($ENV{QUERY_STRING} ne "") {
        !          1343:     redirect("$newplace?$ENV{QUERY_STRING}");
        !          1344:   } else {
        !          1345:     redirect($newplace);
        !          1346:   }
        !          1347:   exit;
1.1.1.28  knu      1348:
1.1.1.37! simon    1349: }
1.1.1.28  knu      1350:
1.1.1.37! simon    1351: elsif (0 && (my @files = &safeglob($fullname . ",v"))) {
        !          1352:   http_header("text/plain");
        !          1353:   print "You matched the following files:\n";
        !          1354:   print join ("\n", @files);
        !          1355:
        !          1356:   # TODO:
        !          1357:   # Find the tags from each file
        !          1358:   # Display a form offering diffs between said tags
        !          1359: }
        !          1360:
        !          1361: else {
        !          1362:   # Assume it's a module name with a potential path following it.
        !          1363:   my $module;
        !          1364:   my $xtra = (($module = $where) =~ s|(/.*)||) ? $1 : '';
        !          1365:
        !          1366:   # Is there an indexed version of modules?
        !          1367:   my $fh = do { local (*FH); };
        !          1368:   if (open($fh, catfile($cvsroot, 'CVSROOT', 'modules'))) {
        !          1369:     while (<$fh>) {
        !          1370:       if (/^(\S+)\s+(\S+)/o
        !          1371:           && $module eq $1
        !          1372:           && $module ne $2
        !          1373:           && -d "$cvsroot/$2")
        !          1374:       {
        !          1375:         close($fh);
        !          1376:         redirect("$scriptname/$2$xtra$query");
        !          1377:       }
        !          1378:     }
        !          1379:     close($fh);
        !          1380:   }
        !          1381:   fatal("404 Not Found", '%s: no such file or directory', $where);
1.1.1.28  knu      1382: }
1.1.1.6   knu      1383:
1.1.1.7   knu      1384: gzipclose();
1.1.1.28  knu      1385:
1.1.1.1   knu      1386: ## End MAIN
                   1387:
                   1388:
1.1.1.37! simon    1389: sub printDiffSelect($)
        !          1390: {
        !          1391:   my ($use_java_script) = @_;
        !          1392:
        !          1393:   print '<select id="f" name="f"';
        !          1394:   print ' onchange="this.form.submit()"' if $use_java_script;
        !          1395:   print ">\n";
        !          1396:
        !          1397:   for my $difftype (@DIFFTYPES) {
        !          1398:     printf("<option value=\"%s\"%s>%s</option>\n",
        !          1399:            $difftype, $input{f} eq $difftype ? ' selected="selected"' : '',
        !          1400:            "\u$DIFFTYPES{$difftype}{descr}");
        !          1401:   }
        !          1402:
        !          1403:   print "</select>";
        !          1404: }
        !          1405:
        !          1406:
        !          1407: sub printDiffSelectStickyVars()
        !          1408: {
        !          1409:   while (my ($key, $val) = each %input) {
        !          1410:     next if ($key eq 'f');
        !          1411:     next if (defined($DEFAULTVALUE{$key}) && $DEFAULTVALUE{$key} eq $val);
        !          1412:     print "<input type=\"hidden\" name=\"", htmlquote($key), "\" value=\"",
        !          1413:       htmlquote($val), "\" />\n";
        !          1414:   }
        !          1415: }
1.1.1.1   knu      1416:
                   1417:
1.1.1.37! simon    1418: sub printLogSortSelect($)
        !          1419: {
        !          1420:   my ($use_java_script) = @_;
        !          1421:
        !          1422:   print '<select id="logsort" name="logsort"';
        !          1423:   print ' onchange="this.form.submit()"' if $use_java_script;
        !          1424:   print ">\n";
        !          1425:
        !          1426:   for my $sortkey (@LOGSORTKEYS) {
        !          1427:     printf("<option value=\"%s\"%s>%s</option>\n",
        !          1428:            $sortkey, $logsort eq $sortkey ? ' selected="selected"' : '',
        !          1429:            "\u$LOGSORTKEYS{$sortkey}{descr}");
        !          1430:   }
        !          1431:
        !          1432:   print "</select>";
1.1.1.1   knu      1433: }
                   1434:
1.1.1.37! simon    1435:
        !          1436: #
        !          1437: # Find the last modified, version controlled files in the given directories.
        !          1438: # Compares solely based on modification timestamps.  Files in the returned list
        !          1439: # are without the ,v suffix, and unreadable files have been filtered out.
        !          1440: #
        !          1441: sub findLastModifiedSubdirs(@)
        !          1442: {
        !          1443:   my (@dirs) = @_;
        !          1444:
        !          1445:   my @files;
        !          1446:   foreach my $dirname (@dirs) {
        !          1447:     next if ($dirname eq curdir() || $dirname eq updir());
        !          1448:     my $dir = catdir($fullname, $dirname);
        !          1449:     next if (!-d $dir);
        !          1450:
        !          1451:     my $dh = do { local (*DH); };
        !          1452:     opendir($dh, $dir) or next;
        !          1453:     my (@filenames) = grep(!forbidden(catfile($dir, $_)), readdir($dh));
        !          1454:     closedir($dh);
        !          1455:
        !          1456:     my $lastmod     = undef;
        !          1457:     my $lastmodtime = undef;
        !          1458:     foreach my $filename (@filenames) {
        !          1459:       ($filename) =
        !          1460:         (catfile($dirname, $filename) =~ VALID_PATH) or next; # untaint
        !          1461:       my ($file) = catfile($fullname, $filename);
        !          1462:       next if ($filename !~ /,v$/o || !-f $file || !-r _);
        !          1463:       my $modtime = -M _;
        !          1464:       if (!defined($lastmod) || $modtime < $lastmodtime) {
        !          1465:         ($lastmod    = $filename) =~ s/,v$//;
        !          1466:         $lastmodtime = $modtime;
        !          1467:       }
        !          1468:     }
        !          1469:     push(@files, $lastmod) if (defined($lastmod));
        !          1470:   }
        !          1471:   return @files;
        !          1472: }
        !          1473:
        !          1474:
        !          1475: sub htmlify_sub(&$)
        !          1476: {
        !          1477:   (my $proc, local $_) = @_;
        !          1478:   my @a = split(m|(<a [^>]+>[^<]*</a>)|i);
        !          1479:   my $linked;
        !          1480:   my $result = '';
        !          1481:
        !          1482:   while (($_, $linked) = splice(@a, 0, 2)) {
        !          1483:     &$proc();
        !          1484:     $result .= $_      if defined($_);
        !          1485:     $result .= $linked if defined($linked);
        !          1486:   }
        !          1487:
        !          1488:   return $result;
        !          1489: }
        !          1490:
        !          1491:
        !          1492: sub htmlify($;$)
        !          1493: {
        !          1494:   (local $_, my $extra) = @_;
        !          1495:
        !          1496:   $_ = htmlquote($_);
        !          1497:
        !          1498:   # get URL's as link
        !          1499:   s{
        !          1500:     ((https?|ftp)://.+?)([\s\']|&(quot|[lg]t);)
        !          1501:    }{
        !          1502:      &link($1, htmlunquote($1)) . $3
        !          1503:    }egx;
        !          1504:
        !          1505:   if ($allow_mailtos) {
        !          1506:     # Make mailto: links from email addresses.
        !          1507:     $_ = htmlify_sub {
        !          1508:       s<
        !          1509:         ([\w+=\-.!]+@[\w\-]+(?:\.[\w\-]+)+)
        !          1510:        ><
        !          1511:          &link($1, "mailto:$1")
        !          1512:        >egix;
        !          1513:     } $_;
        !          1514:   }
        !          1515:
        !          1516:   if ($extra) {
        !          1517:
        !          1518:     # get PR #'s as link: "PR#nnnn" "PR: nnnn, ..." "PR nnnn, ..." "bin/nnnn"
        !          1519:     if (defined($prcgi) && defined($re_prkeyword)) {
        !          1520:       my $prev;
        !          1521:
        !          1522:       do {
        !          1523:         $prev = $_;
        !          1524:
        !          1525:         $_ = htmlify_sub {
        !          1526:           s{
        !          1527:             (\b$re_prkeyword[:\#]?\s*
        !          1528:              (?:
        !          1529:               \#?
        !          1530:               \d+[,\s]\s*
        !          1531:              )*
        !          1532:              \#?)
        !          1533:             (\d+)\b
        !          1534:            }{
        !          1535:              $1 . &link($2, sprintf($prcgi, $2))
        !          1536:            }egix;
        !          1537:         } $_;
        !          1538:       } while ($_ ne $prev);
        !          1539:
        !          1540:       if (defined($re_prcategories)) {
        !          1541:         $_ = htmlify_sub {
        !          1542:           s{
        !          1543:             (\b$re_prcategories/(\d+)\b)
        !          1544:            }{
        !          1545:              &link($1, sprintf($prcgi, $2))
        !          1546:            }egox;
        !          1547:         } $_;
        !          1548:       }
        !          1549:     }
        !          1550:
        !          1551:     # get manpage specs as link: "foo.1" "foo(1)"
        !          1552:     if (defined($mancgi)) {
        !          1553:       $_ = htmlify_sub {
        !          1554:         s{
        !          1555:           (
        !          1556:            \b ( \w[\w+\-.]* (?: ::\w[\w+\-.]*)* )
        !          1557:            (?:
        !          1558:             \( ([0-9n]) \) \B
        !          1559:             |
        !          1560:             \. ([0-9n]) \b
        !          1561:            )
        !          1562:           )
        !          1563:          }{
        !          1564:             my($text, $name, $section) = ($1, $2, defined($3) ? $3 : $4);
        !          1565:             ($name =~ /[A-Za-z]/ && $name !~ /\.(:|$)/)
        !          1566:              ? &link($text, sprintf($mancgi, $section, uri_escape($name)))
        !          1567:               : $text;
        !          1568:          }egx;
        !          1569:       } $_;
        !          1570:     }
        !          1571:   }
        !          1572:
        !          1573:   return $_;
        !          1574: }
        !          1575:
        !          1576:
        !          1577: sub spacedHtmlText($;$)
        !          1578: {
        !          1579:   (local $_, my $ts) = @_;
        !          1580:   return '' unless defined($_);
        !          1581:   $ts ||= $tabstop || 8;
        !          1582:
        !          1583:   # Expand tabs
        !          1584:   1 while s/(.*?)(\t+)/$1 . ' ' x (length($2) * $ts - length($1) % $ts)/e;
        !          1585:
        !          1586:   if ($hr_breakable) {
        !          1587:     s/^ /\001nbsp;/;      # protect leading and...
        !          1588:     s/ $/\001nbsp;/;      # ...trailing whitespace (mostly for String::Ediff),
        !          1589:     s/  / \001nbsp;/g;    # ...and leave every other space 'breakable'
        !          1590:   } else {
        !          1591:     s/ /\001nbsp;/g;
        !          1592:   }
        !          1593:
        !          1594:   $_ = htmlify($_, $allow_source_extra);
        !          1595:
        !          1596:   # unescape
        !          1597:   y/\001/&/;
        !          1598:
        !          1599:   return $_;
        !          1600: }
        !          1601:
        !          1602:
1.1.1.36  scop     1603: # Note that this doesn't htmlquote the first argument...
1.1.1.37! simon    1604: sub link($$)
        !          1605: {
        !          1606:   my ($name, $url) = @_;
        !          1607:   return sprintf('<a href="%s">%s</a>', htmlquote($url), $name);
        !          1608: }
1.1.1.1   knu      1609:
1.1.1.23  knu      1610:
1.1.1.37! simon    1611: sub revcmp($$)
        !          1612: {
        !          1613:   my ($rev1, $rev2) = @_;
        !          1614:
        !          1615:   # make no comparison for a tag or a branch
        !          1616:   return 0 if $rev1 =~ /[^\d.]/ || $rev2 =~ /[^\d.]/;
        !          1617:
        !          1618:   my (@r1) = split(/\./, $rev1);
        !          1619:   my (@r2) = split(/\./, $rev2);
        !          1620:   my ($a, $b);
        !          1621:
        !          1622:   while (($a = shift(@r1)) && ($b = shift(@r2))) {
        !          1623:     return $a <=> $b unless ($a == $b);
        !          1624:   }
        !          1625:   if (@r1) { return  1; }
        !          1626:   if (@r2) { return -1; }
        !          1627:   return 0;
        !          1628: }
        !          1629:
        !          1630:
        !          1631: #
        !          1632: # Signal a fatal error.
        !          1633: #
        !          1634: sub fatal($$@)
        !          1635: {
        !          1636:   my ($errcode, $format, @args) = @_;
        !          1637:   print "Status: $errcode\r\n";
        !          1638:   html_header('Error');
        !          1639:   print '<div id="error">Error: ',
        !          1640:     sprintf($format, map(htmlquote($_), @args)), "</div>\n";
        !          1641:   html_footer();
        !          1642:   exit(1);
        !          1643: }
        !          1644:
        !          1645:
        !          1646: #
        !          1647: # Signal a (fatal) configuration error.
        !          1648: #
        !          1649: sub config_error($$)
        !          1650: {
        !          1651:   fatal('500 Internal Error',
        !          1652:         'Error loading configuration file "<code>%s</code>":<br /><br />' .
        !          1653:         '%s<br />', @_);
        !          1654: }
        !          1655:
        !          1656:
        !          1657: #
        !          1658: # Sends a redirect to the given URL.
        !          1659: #
        !          1660: sub redirect($;$)
        !          1661: {
        !          1662:   my ($url, $permanent) = @_;
        !          1663:   my ($status, $text);
        !          1664:   if ($permanent) {
        !          1665:     $status = '301';
        !          1666:     $text   = 'Moved Permanently';
        !          1667:   } else {
        !          1668:     $status = '302';
        !          1669:     $text   = 'Found';
        !          1670:   }
        !          1671:   print "Status: $status $text\r\n", "Location: $url\r\n";
        !          1672:   html_header($text);
        !          1673:   print "<p>This document has moved ", &link('here', $url), ".</p>\n";
        !          1674:   html_footer();
        !          1675:   exit(1);
1.1.1.1   knu      1676: }
                   1677:
1.1.1.37! simon    1678:
        !          1679: sub safeglob($)
        !          1680: {
        !          1681:   my ($filename) = @_;
        !          1682:
        !          1683:   (my $dirname = $filename) =~ s|/[^/]+$||;
        !          1684:   $filename =~ s|.*/||;
        !          1685:
        !          1686:   my @results;
        !          1687:   my $dh = do { local (*DH); };
        !          1688:   if (opendir($dh, $dirname)) {
        !          1689:     my $glob = $filename;
        !          1690:     my $t;
        !          1691:
        !          1692:     #   transform filename from glob to regex.  Deal with:
        !          1693:     #   [, {, ?, * as glob chars
        !          1694:     #   make sure to escape all other regex chars
        !          1695:     $glob =~ s/([\.\(\)\|\+])/\\$1/g;
        !          1696:     $glob =~ s/\*/.*/g;
        !          1697:     $glob =~ s/\?/./g;
        !          1698:     $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg;
        !          1699:     $glob = qr/^$glob$/;
        !          1700:
        !          1701:     foreach (readdir($dh)) {
        !          1702:       if ($_ =~ $glob && $_ =~ VALID_PATH) {
        !          1703:         push(@results, catfile($dirname, $1)); # untaint
        !          1704:       }
        !          1705:     }
        !          1706:     closedir($dh);
        !          1707:   }
        !          1708:
        !          1709:   return @results;
1.1.1.1   knu      1710: }
                   1711:
1.1.1.37! simon    1712:
        !          1713: #
        !          1714: # Searches @command_path for the given executable file.
        !          1715: #
        !          1716: sub search_path($)
        !          1717: {
        !          1718:   my ($command) = @_;
        !          1719:   for my $d (@command_path) {
        !          1720:     my $cmd = catfile($d, $command);
        !          1721:     return $cmd if (-x $cmd && !-d _);
        !          1722:   }
        !          1723:   return '';
        !          1724: }
        !          1725:
        !          1726:
        !          1727: #
        !          1728: # Gets the enscript(1) highlight mode corresponding to the given filename,
        !          1729: # or undef if unsupported.
        !          1730: #
        !          1731: sub getEnscriptHL($)
        !          1732: {
        !          1733:   return undef unless $allow_enscript;
        !          1734:   my ($filename) = @_;
        !          1735:   while (my ($hl, $regex) = each %enscript_types) {
        !          1736:     return $hl if ($filename =~ $regex);
        !          1737:   }
        !          1738:   return undef;
        !          1739: }
        !          1740:
        !          1741:
        !          1742: #
        !          1743: # Gets the MIME type for the given file name.
        !          1744: #
        !          1745: sub getMimeType($;$)
        !          1746: {
        !          1747:   my ($fullname, $binary) = @_;
        !          1748:   $binary = ($keywordsubstitution && $keywordsubstitution =~ /b/)
        !          1749:     unless defined($binary);
        !          1750:
        !          1751:   (my $suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/;
        !          1752:
        !          1753:   my $mimetype = $MTYPES{$suffix};
        !          1754:   $mimetype  ||= $MimeTypes->mimeTypeOf($fullname) if defined($MimeTypes);
        !          1755:
        !          1756:   if (!$mimetype && $suffix ne '*' && -f $mime_types && -r _) {
        !          1757:     my $fh = do { local (*FH); };
        !          1758:     if (open($fh, $mime_types)) {
        !          1759:       my $re = sprintf('^\s*(\S+\/\S+)\s.+\b%s\b', quotemeta($suffix));
        !          1760:       $re = qr/$re/;
        !          1761:       while (my $line = <$fh>) {
        !          1762:         if ($line =~ $re) {
        !          1763:           $mimetype = $1;
        !          1764:           $MTYPES{$suffix} = $mimetype;
        !          1765:           last;
        !          1766:         }
        !          1767:       }
        !          1768:       close($fh);
        !          1769:     } else {
        !          1770:       warn("Can't open MIME types file $mime_types for reading: $!");
        !          1771:     }
        !          1772:   }
        !          1773:
        !          1774:   $mimetype ||= $MTYPES{'*'};
        !          1775:   $mimetype ||= $binary ? 'application/octet-stream' : 'text/plain';
        !          1776:   return $mimetype;
        !          1777: }
        !          1778:
        !          1779:
1.1.1.1   knu      1780: ###############################
1.1.1.6   knu      1781: # read first lines like head(1)
                   1782: ###############################
1.1.1.37! simon    1783: sub head($;$)
        !          1784: {
        !          1785:   my ($fh, $linecount) = @_;
        !          1786:   $linecount ||= 10;
1.1.1.6   knu      1787:
1.1.1.37! simon    1788:   my @buf;
        !          1789:   if ($linecount > 0) {
        !          1790:     for (my $i = 0; !eof($fh) && $i < $linecount; $i++) {
        !          1791:       push @buf, scalar <$fh>;
        !          1792:     }
        !          1793:   } else {
        !          1794:     @buf = <$fh>;
        !          1795:   }
        !          1796:   return @buf;
1.1.1.6   knu      1797: }
                   1798:
1.1.1.37! simon    1799:
1.1.1.6   knu      1800: ###############################
                   1801: # scan vim and Emacs directives
                   1802: ###############################
1.1.1.37! simon    1803: sub scan_directives(@)
        !          1804: {
        !          1805:   my $ts = undef;
1.1.1.6   knu      1806:
1.1.1.37! simon    1807:   for (@_) {
        !          1808:     $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/;
        !          1809:   }
1.1.1.6   knu      1810:
1.1.1.37! simon    1811:   ('tabstop' => $ts);
1.1.1.6   knu      1812: }
                   1813:
1.1.1.29  knu      1814:
1.1.1.37! simon    1815: sub openOutputFilter()
        !          1816: {
        !          1817:   return unless $output_filter;
        !          1818:
        !          1819:   open(STDOUT, "|-") and return;
1.1.1.29  knu      1820:
1.1.1.37! simon    1821:   # child of child
        !          1822:   open(STDERR, '>', devnull()) unless $DEBUG;
        !          1823:   exec($output_filter) or exit -1;
1.1.1.29  knu      1824: }
                   1825:
1.1.1.37! simon    1826:
1.1.1.6   knu      1827: ###############################
1.1.1.1   knu      1828: # show Annotation
                   1829: ###############################
1.1.1.37! simon    1830: sub doAnnotate($$)
        !          1831: {
        !          1832:   my ($rev, $tag) = @_;
        !          1833:   $rev = $tag || 'HEAD' if ($rev eq '.');
        !          1834:   (my $pathname = $where) =~ s|((?<=/)Attic/)?[^/]*$||;
        !          1835:   (my $filename = $where) =~ s|^.*/||;
        !          1836:
        !          1837:   # This annotate version is based on the cvs annotate-demo Perl script by
        !          1838:   # Cyclic Software.  It was written by Cyclic Software,
        !          1839:   # http://www.cyclic.com/, and is in the public domain.
        !          1840:   # We could abandon the use of rlog, rcsdiff and co using
        !          1841:   # the cvs server in a similiar way one day (..after rewrite).
        !          1842:
        !          1843:   local (*CVS_IN, *CVS_OUT);
        !          1844:   my $annotate_err;
        !          1845:   my ($h, $err) =
        !          1846:     startproc([ $CMD{cvs}, @annotate_options, 'server' ],
        !          1847:               '<pipe', \*CVS_IN, '>pipe', \*CVS_OUT,
        !          1848:               '2>', \$annotate_err);
        !          1849:   fatal('500 Internal Error',
        !          1850:         'Annotate failure (exit status %s), output: <pre>%s</pre>',
        !          1851:         $? >> 8 || -1, $err)
        !          1852:     unless $h;
        !          1853:
        !          1854:   # OK, first send the request to the server.  A simplified example is:
        !          1855:   #     Root /home/kingdon/zwork/cvsroot
        !          1856:   #     Argument foo/xx
        !          1857:   #     Directory foo
        !          1858:   #     /home/kingdon/zwork/cvsroot/foo
        !          1859:   #     Directory .
        !          1860:   #     /home/kingdon/zwork/cvsroot
        !          1861:   #     annotate
        !          1862:   # although as you can see there are a few more details.
        !          1863:
        !          1864:   print CVS_IN "Root $cvsroot\n";
        !          1865:   print CVS_IN
        !          1866:     "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n";
        !          1867:
        !          1868:   # Don't worry about sending valid-requests, the server just needs to
        !          1869:   # support "annotate" and if it doesn't, there isn't anything to be done.
        !          1870:   print CVS_IN "UseUnchanged\n";
        !          1871:   print CVS_IN "Argument -r\n";
        !          1872:   print CVS_IN "Argument $rev\n";
        !          1873:   print CVS_IN "Argument $where\n";
        !          1874:
        !          1875:   # The protocol requires us to fully fake a working directory (at
        !          1876:   # least to the point of including the directories down to the one
        !          1877:   # containing the file in question).
        !          1878:   # So if $where is "dir/sdir/file", then dirs will be ("dir","sdir","file")
        !          1879:   my $path = '';
        !          1880:   foreach my $dir (split('/', $where)) {
        !          1881:
        !          1882:     if ($path eq "") {
        !          1883:       # In our example, $dir is "dir".
        !          1884:       $path = $dir;
        !          1885:     } else {
        !          1886:       print CVS_IN "Directory $path\n";
        !          1887:       print CVS_IN "$cvsroot/$path\n";
        !          1888:
        !          1889:       # In our example, $_ is "sdir" and $path becomes "dir/sdir"
        !          1890:       # And the next time, "file" and "dir/sdir/file" (which then gets
        !          1891:       # ignored, because we don't need to send Directory for the file).
        !          1892:       $path .= "/$dir";
        !          1893:     }
        !          1894:   }
        !          1895:   undef $path;
        !          1896:
        !          1897:   # And the last "Directory" before "annotate" is the top level.
        !          1898:   print CVS_IN "Directory .\n";
        !          1899:   print CVS_IN "$cvsroot\n";
        !          1900:
        !          1901:   print CVS_IN "annotate\n";
        !          1902:
        !          1903:   # OK, we've sent our command to the server.  Thing to do is to
        !          1904:   # close the writer side and get all the responses.
        !          1905:   if (!close(CVS_IN)) {
        !          1906:     $h->finish();
        !          1907:     fatal('500 Internal Error',
        !          1908:           'Annotate failure (exit status %s): <code>%s</code>, output: ' .
        !          1909:           '<pre>%s</pre>', $? >> 8, $!, $annotate_err);
        !          1910:   }
        !          1911:
        !          1912:   navigateHeader($scriptwhere, $pathname, $filename, $rev, 'annotate');
        !          1913:
        !          1914:   my $revtype = ($rev =~ /\./) ? 'revision' : 'tag'; # TODO: tag -> branch/tag?
        !          1915:   print '<h3 style="text-align: center">Annotation of ',
        !          1916:     htmlquote("$pathname$filename"), ", $revtype $rev</h3>\n";
        !          1917:
        !          1918:   # Ready to get the responses from the server.
        !          1919:   # For example:
        !          1920:   #     E Annotations for foo/xx
        !          1921:   #     E ***************
        !          1922:   #     M 1.3          (kingdon  06-Sep-97): hello
        !          1923:   #     ok
        !          1924:   my ($lineNr) = 0;
        !          1925:   my ($oldLrev, $oldLusr) = ("", "");
        !          1926:   my ($revprint, $usrprint);
        !          1927:
        !          1928:   if ($annTable) {
        !          1929:     print <<EOF;
        !          1930: <table style="border: none" cellspacing="0" cellpadding="0" summary="Annotation">
        !          1931: EOF
        !          1932:   } else {
        !          1933:     print "<pre>";
        !          1934:   }
        !          1935:
        !          1936:   # prefetch several lines
        !          1937:   my @buf = head(*CVS_OUT);
        !          1938:
        !          1939:   my %d = scan_directives(@buf);
        !          1940:
        !          1941:   while (@buf || !eof(*CVS_OUT)) {
        !          1942:
        !          1943:     $_ = @buf ? shift @buf : <CVS_OUT>;
        !          1944:     my @words = split;
        !          1945:
        !          1946:     # Adding one is for the (single) space which follows $words[0].
        !          1947:     my $rest = substr($_, length($words[0]) + 1);
        !          1948:     if ($words[0] eq "E") {
        !          1949:       next;
        !          1950:     } elsif ($words[0] eq "M") {
        !          1951:       $lineNr++;
        !          1952:       (my $lrev = substr($_, 2,  13)) =~ y/ //d;
        !          1953:       (my $lusr = substr($_, 16, 9))  =~ y/ //d;
        !          1954:       my $line = substr($_, 36);
        !          1955:       # TODO: this does not work for branch/tag revisions.
        !          1956:       my $isCurrentRev = ($rev eq $lrev);
        !          1957:
        !          1958:       # we should parse the date here ..
        !          1959:       if ($lrev eq $oldLrev) {
        !          1960:         $revprint = sprintf('%-8s', '');
        !          1961:       } else {
        !          1962:         $revprint = sprintf('%-8s', $lrev);
        !          1963:         $revprint =~ s|(\S+)|&link($1, uri_escape($filename)."$query#rev$1")|e;
        !          1964:         $oldLusr = '';
        !          1965:       }
        !          1966:
        !          1967:       $usrprint = ($lusr eq $oldLusr) ? '' : $lusr;
        !          1968:       $oldLrev = $lrev;
        !          1969:       $oldLusr = $lusr;
        !          1970:
        !          1971:       print $is_textbased ? '<b>' : '<span class="current-rev">'
        !          1972:         if $isCurrentRev;
        !          1973:
        !          1974:       $usrprint = sprintf('%-8s', $usrprint);
        !          1975:       printf '%s%s %s %4d:', $revprint, $isCurrentRev ? '!' : ' ',
        !          1976:         htmlquote($usrprint), $lineNr;
        !          1977:       print spacedHtmlText($line, $d{tabstop});
        !          1978:
        !          1979:       print $is_textbased ? '</b>' : '</span>' if $isCurrentRev;
        !          1980:
        !          1981:     } elsif ($words[0] eq "ok") {
        !          1982:       # We could complain about any text received after this, like the
        !          1983:       # CVS command line client.  But for simplicity, we don't.
        !          1984:
        !          1985:     } elsif ($words[0] eq "error") {
        !          1986:       fatal("500 Internal Error",
        !          1987:             'Error occured during annotate: <b>%s</b>', $_);
        !          1988:     }
        !          1989:   }
        !          1990:   $h->finish();
        !          1991:
        !          1992:   if ($annTable) {
        !          1993:     print "</table>";
        !          1994:   } else {
        !          1995:     print "</pre>";
        !          1996:   }
        !          1997:   html_footer();
1.1.1.1   knu      1998: }
                   1999:
                   2000: ###############################
                   2001: # make Checkout
                   2002: ###############################
1.1.1.37! simon    2003: sub doCheckout($$$)
        !          2004: {
        !          2005:   my ($fullname, $rev, $tag) = @_;
        !          2006:   $rev = $tag || undef if (!$rev || $rev eq '.');
        !          2007:
        !          2008:   # Start resolving whether we will do a markup view or not.
        !          2009:   my $do_markup = undef;
        !          2010:   my $want_type = $input{'content-type'};
        !          2011:
        !          2012:   # No markup if markup disallowed.
        !          2013:   $do_markup = 0 unless $allow_markup;
        !          2014:
        !          2015:   # No markup if checkout magic cookie in URL.
        !          2016:   $do_markup = 0 if (!defined($do_markup) && $doCheckout);
        !          2017:
        !          2018:   # Do markup if explicitly asked using cvsweb-markup content type.  If the
        !          2019:   # asked content type is anything else, no markup.
        !          2020:   if (!defined($do_markup) && $want_type) {
        !          2021:     if ($want_type =~ CVSWEBMARKUP) {
        !          2022:       $want_type = undef;
        !          2023:       $do_markup = 1;
        !          2024:     } else {
        !          2025:       $do_markup = 0;
        !          2026:     }
        !          2027:   }
        !          2028:
        !          2029:   # Ok, if $do_markup is still undefined, we know that a download has not been
        !          2030:   # explicitly asked.  For the last check further down below we'll need to
        !          2031:   # know if the file is binary, and possibly run a log on it.
        !          2032:   my $needlog = $do_markup || $use_moddate;
        !          2033:
        !          2034:   my $moddate = undef;
        !          2035:   my $revopt;
        !          2036:   if (defined($rev)) {
        !          2037:     $revopt = "-r$rev";
        !          2038:     if ($needlog) {
        !          2039:       readLog($fullname, $rev);
        !          2040:       $moddate   = $date{$rev};
        !          2041:       # TODO: even this does not work for branch tags, but only normal tags :(
        !          2042:       $moddate ||= $date{$symrev{$rev}} if defined($symrev{$rev});
        !          2043:     }
        !          2044:   } else {
        !          2045:     $revopt = "-rHEAD";
        !          2046:     if ($needlog) {
        !          2047:       readLog($fullname);
        !          2048:       $moddate = $date{$symrev{HEAD}};
        !          2049:     }
        !          2050:   }
        !          2051:
        !          2052:   my $cr = abs_path($cvsroot) || $cvsroot;
        !          2053:   # abs_path() taints when run as a CGI...
        !          2054:   if ($cr =~ VALID_PATH) {
        !          2055:     $cr = $1;
        !          2056:   } else {
        !          2057:     fatal('500 Internal Error', 'Illegal CVS root: <code>%s</code>', $cr);
        !          2058:   }
        !          2059:   # Use abs_path() to work around a bug of cvs -p; expand symlinks if we can.
        !          2060:   my @cmd = ($CMD{cvs}, @cvs_options, '-d', $cr, 'co', '-p', $revopt, $where);
        !          2061:
        !          2062:   local (*CVS_OUT, *CVS_ERR);
        !          2063:   my ($h, $err) =
        !          2064:     startproc(\@cmd, \"", '>pipe', \*CVS_OUT, '2>pipe', \*CVS_ERR);
        !          2065:   fatal('500 Internal Error',
        !          2066:         'Checkout failure (exit status %s), output: <pre>%s</pre>',
        !          2067:         $? >> 8 || -1, $err)
        !          2068:     unless $h;
        !          2069:
        !          2070:   if (eof(CVS_ERR)) {
        !          2071:     $h->finish();
        !          2072:     fatal("404 Not Found", '%s is not (any longer) pertinent', $where);
        !          2073:   }
        !          2074:
        !          2075:   #===================================================================
        !          2076:   #Checking out squid/src/ftp.c
        !          2077:   #RCS:  /usr/src/CVS/squid/src/ftp.c,v
        !          2078:   #VERS: 1.1.1.28.6.2
        !          2079:   #***************
        !          2080:
        !          2081:   # Parse CVS header
        !          2082:   my ($revision, $filename, $cvsheader);
        !          2083:   $filename = "";
        !          2084:   while (<CVS_ERR>) {
        !          2085:     last if (/^\*\*\*\*/);
        !          2086:     $revision = $1 if (/^VERS: (.*)$/);
        !          2087:
        !          2088:     if (/^Checking out (.*)$/) {
        !          2089:       ($filename = $1) =~ s|^\./+||;
        !          2090:     }
        !          2091:     $cvsheader .= $_;
        !          2092:   }
        !          2093:   close(CVS_ERR);
        !          2094:
        !          2095:   if ($filename ne $where) {
        !          2096:     $h->finish();
        !          2097:     fatal("500 Internal Error",
        !          2098:           'Unexpected output from cvs co: <pre>%s</pre> ' .
        !          2099:           '(expected "<code>%s</code>" but got "<code>%s</code>")',
        !          2100:           $cvsheader, $where, $filename);
        !          2101:   }
        !          2102:
        !          2103:   # Last checks whether we'll do markup or not.
        !          2104:   my $isbin = $keywordsubstitution && $keywordsubstitution =~ /b/;
        !          2105:   my $mimetype = getMimeType($fullname, $isbin);
        !          2106:
        !          2107:   # If we still are not sure whether to do markup or not:
        !          2108:   # if the MIME type is "viewable" or this is not a binary file, do.
        !          2109:   $do_markup = !$isbin || viewable($mimetype) unless defined($do_markup);
        !          2110:
        !          2111:   if ($do_markup) {
        !          2112:
        !          2113:     # If this is something we'll be linking to in the markup view, we are
        !          2114:     # done with this particular output from "cvs co" and must discard it.
        !          2115:     my $linked = $mimetype =~ m{^image/|application/pdf$}i;
        !          2116:     if ($linked) {
        !          2117:       close(CVS_OUT);
        !          2118:       $h->finish();
        !          2119:     }
        !          2120:
        !          2121:     # Here we know the last modified date, but don't know if tags have been
        !          2122:     # added afterwards (those are shown in the markup view): no last-modified.
        !          2123:     cvswebMarkup(\*CVS_OUT, $fullname, $revision, $isbin, $mimetype, $needlog);
        !          2124:
        !          2125:     $h->finish() unless $linked;
        !          2126:
        !          2127:   } else {
        !          2128:     http_header($want_type || $mimetype, $moddate);
        !          2129:     local $/ = undef;
        !          2130:     print <CVS_OUT>;
        !          2131:     $h->finish();
        !          2132:   }
1.1.1.1   knu      2133: }
                   2134:
                   2135:
1.1.1.37! simon    2136: sub cvswebMarkup($$$$$$;$)
        !          2137: {
        !          2138:   my ($filehandle, $fullname, $rev, $isbin, $mimetype, $logged, $mod) = @_;
        !          2139:
        !          2140:   (my $pathname = $where) =~ s|((?<=/)Attic/)?[^/]*$||;
        !          2141:   (my $filename = $where) =~ s|^.*/||;
        !          2142:
        !          2143:   navigateHeader($scriptwhere, $pathname, $filename, $rev, 'view', $mod);
        !          2144:
        !          2145:   print <<EOF;
        !          2146: <hr />
        !          2147: <div class="log-markup">
        !          2148: File:&nbsp;
        !          2149: EOF
        !          2150:   print &clickablePath($where, 1), "<br />\n";
        !          2151:
        !          2152:   if ($show_log_in_markup) {
        !          2153:     readLog($fullname) unless $logged; #,$rev);
        !          2154:     printLog($rev, $mimetype, $isbin);
        !          2155:   } else {
        !          2156:     print "Revision: <b>$rev</b><br />\n";
        !          2157:     print 'Tag: ', htmlquote($input{only_with_tag}), "<br />\n"
        !          2158:       if $input{only_with_tag};
        !          2159:   }
        !          2160:   print "</div>\n<hr />";
        !          2161:   my $url = download_url(uri_escape($filename), $rev, $mimetype);
        !          2162:
        !          2163:   if ($mimetype =~ m|^image/|i) {
        !          2164:     printf '<img src="%s" alt="%s" /><br />',
        !          2165:       $url . $barequery, htmlquote($filename);
        !          2166:   } elsif (lc($mimetype) eq 'application/pdf') {
        !          2167:     printf '<embed src="%s" width="100%%" height="100%%" /><br />',
        !          2168:       $url . $barequery;
        !          2169:   } else {
        !          2170:
        !          2171:     print "<pre>\n";
        !          2172:     my $linenumbers = $input{ln} || 0;
        !          2173:
        !          2174:     if (my $enscript_hl = getEnscriptHL($filename)) {
        !          2175:       doEnscript($filehandle, $enscript_hl, $linenumbers);
        !          2176:
        !          2177:     } else {
        !          2178:       my $ln  = 0;
        !          2179:       my @buf = ();
        !          2180:       my $ts  = undef;
        !          2181:
        !          2182:       if ($preformat_in_markup) {
        !          2183:         # prefetch several lines
        !          2184:         @buf = head($filehandle);
        !          2185:         my %d = scan_directives(@buf);
        !          2186:         $ts = $d{tabstop};
        !          2187:       }
        !          2188:
        !          2189:       while (@buf || !eof($filehandle)) {
        !          2190:         $_ = @buf ? shift @buf : <$filehandle>;
        !          2191:         if ($linenumbers) {
        !          2192:           $ln++;
        !          2193:           printf '<a id="l%d" class="src">%5d: </a>', ($ln) x 2;
        !          2194:         }
        !          2195:         print $preformat_in_markup ? spacedHtmlText($_, $ts) : htmlquote($_);
        !          2196:       }
        !          2197:     }
        !          2198:
        !          2199:     print "</pre>\n";
        !          2200:   }
        !          2201:   html_footer();
        !          2202: }
        !          2203:
        !          2204:
        !          2205: sub viewable($)
        !          2206: {
        !          2207:   return shift =~ m{^((text|image)/|application/pdf)}i;
1.1.1.1   knu      2208: }
                   2209:
1.1.1.37! simon    2210:
1.1.1.1   knu      2211: ###############################
                   2212: # Show Colored Diff
                   2213: ###############################
1.1.1.37! simon    2214: sub doDiff($$$$$$)
        !          2215: {
        !          2216:   my ($fullname, $r1, $tr1, $r2, $tr2, $f) = @_;
        !          2217:
        !          2218:   if (forbidden($fullname)) {
        !          2219:     fatal('403 Forbidden', 'Access to %s forbidden.', $where);
        !          2220:   }
        !          2221:
        !          2222:   my ($rev1, $sym1);
        !          2223:   if ($r1 =~ /([^:]+)(:(.+))?/) {
        !          2224:     $rev1 = $1;
        !          2225:     $sym1 = $3;
        !          2226:   }
        !          2227:   if ($r1 eq 'text') {
        !          2228:     $rev1 = $tr1;
        !          2229:     $sym1 = "";
        !          2230:   }
        !          2231:
        !          2232:   my ($rev2, $sym2);
        !          2233:   if ($r2 =~ /([^:]+)(:(.+))?/) {
        !          2234:     $rev2 = $1;
        !          2235:     $sym2 = $3;
        !          2236:   }
        !          2237:   if ($r2 eq 'text') {
        !          2238:     $rev2 = $tr2;
        !          2239:     $sym2 = "";
        !          2240:   }
        !          2241:
        !          2242:   #
        !          2243:   # rev1 and rev2 are now both numeric revisions.
        !          2244:   # Thus we do a DWIM here and swap them if rev1 is after rev2.
        !          2245:   # XXX should we warn about the fact that we do this?
        !          2246:   if (&revcmp($rev1, $rev2) > 0) {
        !          2247:     my ($tmp1, $tmp2) = ($rev1, $sym1);
        !          2248:     ($rev1, $sym1) = ($rev2, $sym2);
        !          2249:     ($rev2, $sym2) = ($tmp1, $tmp2);
        !          2250:   }
        !          2251:
        !          2252:   my $mimetype = getMimeType($fullname);
        !          2253:
        !          2254:   #
        !          2255:   #  Check for per-MIME type diff commands.
        !          2256:   #
        !          2257:   my $diffcmd = undef;
        !          2258:   if (my $diffcmds = $DIFF_COMMANDS{lc($mimetype)}) {
        !          2259:     if ($f =~ /^ext(\d*)$/) {
        !          2260:       my $n = $1 || 0;
        !          2261:       $diffcmd = $diffcmds->[$n];
        !          2262:     }
        !          2263:   }
        !          2264:   if ($diffcmd && $diffcmd->{cmd} && $diffcmd->{name}) {
        !          2265:
        !          2266:     if ($diffcmd->{args} && ref($diffcmd->{args}) ne 'ARRAY') {
        !          2267:       fatal('500 Internal Error',
        !          2268:             'Configuration error: arguments to external diff tools must ' .
        !          2269:             'be given as array refs.  See "<code>%s</code>" in ' .
        !          2270:             '<code>%%DIFF_COMMANDS</code>.',
        !          2271:             $diffcmd->{name});
        !          2272:     }
        !          2273:
        !          2274:     (my $cvsname = $where) =~ s/\.diff$//;
        !          2275:
        !          2276:     # Create two temporary files with the two revisions
        !          2277:     my $temp_fn1 = checkout_to_temp($cvsroot, $cvsname, $rev1);
        !          2278:     my $temp_fn2 = checkout_to_temp($cvsroot, $cvsname, $rev2);
        !          2279:
        !          2280:     # Execute chosen diff binary.
        !          2281:     local (*DIFF_OUT);
        !          2282:     my @cmd = ($diffcmd->{cmd});
        !          2283:     push(@cmd, @{$diffcmd->{args}}) if $diffcmd->{args};
        !          2284:     push(@cmd, $temp_fn1, $temp_fn2);
        !          2285:     my ($h, $err) = startproc(\@cmd, \"", '>pipe', \*DIFF_OUT);
        !          2286:     if (!$h) {
        !          2287:       unlink($temp_fn1);
        !          2288:       unlink($temp_fn2);
        !          2289:       fatal('500 Internal Error',
        !          2290:             'Diff failure (exit status %s), output: <pre>%s</pre>',
        !          2291:             $? >> 8 || -1, $err);
        !          2292:     }
        !          2293:
        !          2294:     http_header($diffcmd->{type} || 'text/plain');
        !          2295:     local $/ = undef;
        !          2296:     print <DIFF_OUT>;
        !          2297:     $h->finish();
        !          2298:     unlink($temp_fn1);
        !          2299:     unlink($temp_fn2);
        !          2300:
        !          2301:     exit;
        !          2302:   }
        !          2303:
        !          2304:   #
        !          2305:   # Normal CVS diff.
        !          2306:   #
        !          2307:
        !          2308:   $f = $DEFAULTVALUE{f} || 'u' if ($f =~ /^ext\d*$/);
        !          2309:   my $difftype = $DIFFTYPES{$f};
        !          2310:   if (!$difftype) {
        !          2311:     fatal("400 Bad arguments", 'Diff format %s not understood', $f);
        !          2312:   }
        !          2313:
        !          2314:   my @difftype       = @{$difftype->{opts}};
        !          2315:   my $human_readable = $difftype->{colored};
        !          2316:
        !          2317:   # Apply special diff options.  -p and -F are not available with side by side
        !          2318:   # diffs and may cause problems with older (< 2.8) versions of diffutils if
        !          2319:   # used with --side-by-side.
        !          2320:   if ($showfunc && $f !~ /^s/) {
        !          2321:     push(@difftype, '-p');
        !          2322:     while (my ($re1, $re2) = each %funcline_regexp) {
        !          2323:       if ($fullname =~ $re1) {
        !          2324:         push(@difftype, '-F', $re2);
        !          2325:         last;
        !          2326:       }
        !          2327:     }
        !          2328:   }
        !          2329:
        !          2330:   if ($human_readable) {
        !          2331:     push(@difftype, '-w')  if $hr_ignwhite;
        !          2332:     push(@difftype, '-kk') if $hr_ignkeysubst;
        !          2333:   }
        !          2334:
        !          2335:   my $fh = do { local (*FH); };
        !          2336:   if (!open($fh, "-|")) {    # child
        !          2337:     open(STDERR, ">&STDOUT");    # Redirect stderr to stdout
        !          2338:     openOutputFilter();
        !          2339:     exec($CMD{rcsdiff}, @rcsdiff_options, @difftype, "-r$rev1", "-r$rev2",
        !          2340:          $fullname) or exit -1;
        !          2341:   }
        !          2342:
        !          2343:   if ($human_readable) {
        !          2344:     #
        !          2345:     # Human readable diff.
        !          2346:     #
        !          2347:     human_readable_diff($fh, $rev2);
        !          2348:     html_footer();
        !          2349:     gzipclose();
        !          2350:     exit;
        !          2351:
        !          2352:   } elsif ($f =~ /^([ucs])c$/) {
        !          2353:     #
        !          2354:     # Enscript colored diff.
        !          2355:     #
        !          2356:     my $hl = 'diff';
        !          2357:     $hl .= $1 if ($1 eq 'u' || $1 eq 's');
        !          2358:     (my $where_nd = $where)       =~ s/\.diff$//;
        !          2359:     (my $pathname = $where_nd)    =~ s|((?<=/)Attic/)?[^/]*$||;
        !          2360:     (my $filename = $where_nd)    =~ s|^.*/||;
        !          2361:     (my $swhere   = $scriptwhere) =~ s|\.diff$||;
        !          2362:     navigateHeader($swhere, $pathname, $filename, $rev2, 'diff');
        !          2363:     printf(<<EOF, $where_nd, $rev1, $rev2);
        !          2364: <h3 style="text-align: center">Diff for /%s between versions %s and %s</h3>
        !          2365: <pre>
        !          2366: EOF
        !          2367:     doEnscript(\$fh, $hl, 0, 'cvsweb_diff');
        !          2368:     print <<EOF;
        !          2369: </pre>
        !          2370: <hr style="width: 100%" />
        !          2371: <form method="get" action="$scriptwhere">
        !          2372: EOF
        !          2373:     printDiffSelectStickyVars();
        !          2374:     print 'Diff format: ';
        !          2375:     printDiffSelect($use_java_script);
        !          2376:     print "<input type=\"submit\" value=\"Show\" />\n</form>\n";
        !          2377:     html_footer();
        !          2378:     gzipclose();
        !          2379:     exit;
        !          2380:
        !          2381:   } else {
        !          2382:     #
        !          2383:     # Plain diff.
        !          2384:     #
        !          2385:     http_header("text/plain");
        !          2386:   }
        !          2387:
        !          2388:   #
        !          2389:   #===================================================================
        !          2390:   #RCS file: /home/ncvs/src/sys/netinet/tcp_output.c,v
        !          2391:   #retrieving revision 1.16
        !          2392:   #retrieving revision 1.17
        !          2393:   #diff -c -r1.16 -r1.17
        !          2394:   #*** /home/ncvs/src/sys/netinet/tcp_output.c     1995/11/03 22:08:08     1.16
        !          2395:   #--- /home/ncvs/src/sys/netinet/tcp_output.c     1995/12/05 17:46:35     1.17
        !          2396:   #
        !          2397:   # Ideas:
        !          2398:   # - nuke the stderr output if it's what we expect it to be
        !          2399:   # - Add "no differences found" if the diff command supplied no output.
        !          2400:   #
        !          2401:   #*** src/sys/netinet/tcp_output.c     1995/11/03 22:08:08     1.16
        !          2402:   #--- src/sys/netinet/tcp_output.c     1995/12/05 17:46:35     1.17 RELENG_2_1_0
        !          2403:   # (bogus example, but...)
        !          2404:   #
        !          2405:   my ($f1, $f2);
        !          2406:   if (grep { $_ eq '-u' } @difftype) {
        !          2407:     $f1 = '---';
        !          2408:     $f2 = '\+\+\+';
        !          2409:   } else {
        !          2410:     $f1 = '\*\*\*';
        !          2411:     $f2 = '---';
        !          2412:   }
        !          2413:
        !          2414:   while (<$fh>) {
        !          2415:     if (m|^$f1 $cvsroot|o) {
        !          2416:       s|$cvsroot/||o;
        !          2417:       if ($sym1) {
        !          2418:         chop;
        !          2419:         $_ .= " $sym1\n";
        !          2420:       }
        !          2421:     } elsif (m|^$f2 $cvsroot|o) {
        !          2422:       s|$cvsroot/||o;
        !          2423:
        !          2424:       if ($sym2) {
        !          2425:         chop;
        !          2426:         $_ .= " $sym2\n";
        !          2427:       }
        !          2428:     }
        !          2429:     print $_;
        !          2430:   }
        !          2431:   close($fh);
1.1.1.1   knu      2432: }
                   2433:
1.1.1.37! simon    2434:
1.1.1.1   knu      2435: ###############################
                   2436: # Show Logs ..
                   2437: ###############################
1.1.1.37! simon    2438: sub getDirLogs($$@)
        !          2439: {
        !          2440:   my ($cvsroot, $dirname, @otherFiles) = @_;
        !          2441:   my $tag = $input{only_with_tag};
        !          2442:   my $DirName = catdir($cvsroot, $where);
        !          2443:
        !          2444:   my @files = &safeglob("$DirName/*,v");
        !          2445:   push (@files, &safeglob("$DirName/Attic/*,v")) unless $input{hideattic};
        !          2446:   foreach my $file (@otherFiles) {
        !          2447:     push(@files, catfile($DirName, $file));
        !          2448:   }
        !          2449:
        !          2450:   # Weed out unreadable files.
        !          2451:   my $i = 0;
        !          2452:   my @unreadable = ();
        !          2453:   while ($i < scalar(@files)) {
        !          2454:     # Note: last modified files from subdirs returned by
        !          2455:     # findLastModifiedSubdirs() come without the ,v suffix so they're not
        !          2456:     # found here, but have already been checked for readability.  *cough*
        !          2457:     if (-r $files[$i] || !-e _) {
        !          2458:       $i++;
        !          2459:     } else {
        !          2460:       push(@unreadable, splice(@files, $i, 1));
        !          2461:     }
        !          2462:   }
        !          2463:
        !          2464:   # If there are no files, we're done.
        !          2465:   return @unreadable unless @files;
        !          2466:
        !          2467:   my @cmd = ($CMD{rlog});
        !          2468:   # Can't use -r<tag> as '-' is allowed in tagnames,
        !          2469:   # but misinterpreted by rlog.
        !          2470:   push(@cmd, '-r') unless defined($tag);
        !          2471:
        !          2472:   my $fh = do { local (*FH); };
        !          2473:   if (!open($fh, '-|')) {                       # Child
        !          2474:     open(STDERR, '>', devnull()) unless $DEBUG; # Ignore rlog's complaints.
        !          2475:     openOutputFilter();
        !          2476:     if ($file_list_len && $file_list_len > 1) {
        !          2477:       while (scalar(@files) > $file_list_len) {  # Process files in chunks.
        !          2478:         system(@cmd, splice(@files, 0, $file_list_len)) == 0 or exit -1;
        !          2479:       }
        !          2480:     }
        !          2481:     exec(@cmd, @files) or exit -1;
        !          2482:   }
        !          2483:   undef @cmd;
        !          2484:
        !          2485:   my $state = 'start';
        !          2486:   my ($date, $branchpoint, $branch, $log, @filetags);
        !          2487:   my ($rev, $revision, $revwanted, $filename, $head, $author, $keywordsubst);
        !          2488:
        !          2489:   while (<$fh>) {
        !          2490:     if ($state eq "start") {
        !          2491:
        !          2492:       #Next file. Initialize file variables
        !          2493:       $rev         = '';
        !          2494:       $revwanted   = '';
        !          2495:       $branch      = '';
        !          2496:       $branchpoint = '';
        !          2497:       $filename    = '';
        !          2498:       $log         = '';
        !          2499:       $revision    = '';
        !          2500:       %symrev      = ();
        !          2501:       @filetags    = ();
        !          2502:       $keywordsubst= '';
        !          2503:
        !          2504:       #jump to head state
        !          2505:       $state = "head";
        !          2506:     }
        !          2507:
        !          2508:     again:
        !          2509:
        !          2510:     if ($state eq "head") {
        !          2511:
        !          2512:       #$rcsfile = $1 if (/^RCS file: (.+)$/); #not used (yet)
        !          2513:
        !          2514:       if (/^Working file: (.+)$/) {
        !          2515:         $filename = $1;
        !          2516:       } elsif (/^head: (.+)$/) {
        !          2517:         $head = $1;
        !          2518:       } elsif (/^branch: (.+)$/) {
        !          2519:         $branch = $1;
        !          2520:       } elsif (/^keyword substitution: (.+)$/) {
        !          2521:         $keywordsubst = $1;
        !          2522:       } elsif (/^symbolic names:/) {
        !          2523:         $state = "tags";
        !          2524:         ($branch = $head) =~ s/\.\d+$//
        !          2525:           if $branch eq '';
        !          2526:         $branch =~ s/(\d+)$/0.$1/;
        !          2527:         $symrev{MAIN}  = $branch;
        !          2528:         $symrev{HEAD}  = $branch;
        !          2529:         $alltags{MAIN} = 1;
        !          2530:         $alltags{HEAD} = 1;
        !          2531:         push (@filetags, "MAIN", "HEAD");
        !          2532:       } elsif ($_ =~ LOG_REVSEPR) {
        !          2533:         $state = "log";
        !          2534:         $rev   = '';
        !          2535:         $date  = '';
        !          2536:         $log   = '';
        !          2537:
        !          2538:         # Try to reconstruct the relative filename if RCS spits out a full path
        !          2539:         $filename =~ s%^\Q$DirName\E/%%;
        !          2540:       }
        !          2541:       next;
        !          2542:     }
        !          2543:
        !          2544:     if ($state eq "tags") {
        !          2545:       if (/^\s+([^:]+):\s+([\d\.]+)\s*$/) {
        !          2546:         push (@filetags, $1);
        !          2547:         $symrev{$1}  = $2;
        !          2548:         $alltags{$1} = 1;
        !          2549:         next;
        !          2550:       } elsif (/^\S/) {
        !          2551:
        !          2552:         if (defined($tag)) {
        !          2553:           if (defined($symrev{$tag}) || $tag eq "HEAD") {
        !          2554:             $revwanted    = $symrev{$tag eq "HEAD" ? "MAIN" : $tag};
        !          2555:             ($branch      = $revwanted) =~ s/\b0\.//;
        !          2556:             ($branchpoint = $branch)    =~ s/\.?\d+$//;
        !          2557:             $revwanted    = '' if ($revwanted ne $branch);
        !          2558:           } elsif ($tag ne "HEAD") {
        !          2559:             $state = "skip";
        !          2560:             next;
        !          2561:           }
        !          2562:         }
        !          2563:
        !          2564:         foreach my $tagfound (@filetags) {
        !          2565:           $tags{$tagfound} = 1;
        !          2566:         }
        !          2567:         $state = "head";
        !          2568:         goto again;
        !          2569:       }
        !          2570:     }
        !          2571:
        !          2572:     if ($state eq "log") {
        !          2573:       if ($_ =~ LOG_REVSEPR || $_ =~ LOG_FILESEPR) {
        !          2574:
        !          2575:         # End of a log entry.
        !          2576:         my $revbranch = $rev;
        !          2577:         $revbranch =~ s/\.\d+$//;
        !          2578:
        !          2579:         if ($revwanted eq '' && $branch ne '' && $branch eq $revbranch
        !          2580:             || !defined($tag))
        !          2581:         {
        !          2582:           $revwanted = $rev;
        !          2583:         }
        !          2584:
        !          2585:         if ($revwanted ne ''
        !          2586:             ? $rev eq $revwanted
        !          2587:             : $branchpoint ne ''
        !          2588:               ? $rev eq $branchpoint
        !          2589:               : 0
        !          2590:             && ($rev eq $head))
        !          2591:         {    # Don't think head is needed here..
        !          2592:           my @finfo = ($rev, $date, $log, $author, $filename, $keywordsubst);
        !          2593:           (my $name = $filename) =~ s%/.*%%;
        !          2594:           $fileinfo{$name} = [@finfo];
        !          2595:           $state = "done" if ($rev eq $revwanted);
        !          2596:         }
        !          2597:         $rev  = '';
        !          2598:         $date = '';
        !          2599:         $log  = '';
        !          2600:       } elsif ($date eq ''
        !          2601:                && m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);|)
        !          2602:       {
        !          2603:         my $yr    = $1;
        !          2604:         $yr      -= 1900 if ($yr > 100); # Damn 2-digit year routines :-)
        !          2605:         $date     = timegm($6, $5, $4, $3, $2 - 1, $yr);
        !          2606:         ($author) = /author: ([^;]+)/;
        !          2607:         $state    = 'log';
        !          2608:         $log      = '';
        !          2609:         next;
        !          2610:       } elsif ($rev eq '' && /^revision (\d+(?:\.\d+)+).*$/) {
        !          2611:         $rev = $1;    # .*$ eats up the locker(lockers?) info, if any
        !          2612:         next;
        !          2613:       } else {
        !          2614:         $log .= $_;
        !          2615:       }
        !          2616:     }
        !          2617:
        !          2618:     if ($_ =~ LOG_FILESEPR) {
        !          2619:       $state = "start";
        !          2620:       next;
        !          2621:     }
        !          2622:   }
        !          2623:
        !          2624:   my $linesread = $. || 0;
        !          2625:   close($fh);
        !          2626:
        !          2627:   if ($linesread == 0) {
        !          2628:     fatal('500 Internal Error',
        !          2629:           'Failed to spawn GNU rlog on <em>"%s"</em>.<br /><br />Did you set the <b><code>@command_path</code></b> in your configuration file correctly? (Currently: "<code>%s</code>")',
        !          2630:           htmlquote(join(', ', @files)), join(':', @command_path));
        !          2631:   }
        !          2632:
        !          2633:   return @unreadable;
1.1.1.1   knu      2634: }
1.1       jfieber  2635:
1.1.1.37! simon    2636:
        !          2637: sub readLog($;$)
        !          2638: {
        !          2639:   my ($fullname, $revision) = @_;
        !          2640:   my ($symnames, $head, $rev, $br, $brp, $branch, $branchrev);
        !          2641:
        !          2642:   undef %symrev;
        !          2643:   undef %revsym;
        !          2644:   undef @allrevisions;
        !          2645:   undef %date;
        !          2646:   undef %author;
        !          2647:   undef %state;
        !          2648:   undef %difflines;
        !          2649:   undef %log;
        !          2650:   $keywordsubstitution = '';
        !          2651:
        !          2652:   my $fh = do { local (*FH); };
        !          2653:   if (!open($fh, "-|")) {    # child
        !          2654:     openOutputFilter();
        !          2655:     $revision = defined($revision) ? "-r$revision" : '';
        !          2656:     if ($revision =~ /\./) {
        !          2657:       # Normal revision, not a branch/tag name.
        !          2658:       exec($CMD{rlog}, $revision, $fullname) or exit -1;
        !          2659:     } else {
        !          2660:       exec($CMD{rlog}, $fullname) or exit -1;
        !          2661:     }
        !          2662:   }
        !          2663:
        !          2664:   my $curbranch = undef;
        !          2665:   while (<$fh>) {
        !          2666:     if ($symnames) {
        !          2667:       if (/^\s+([^:]+):\s+([\d\.]+)/) {
        !          2668:         $symrev{$1} = $2;
        !          2669:         next;
        !          2670:       } else {
        !          2671:         $symnames = 0;
        !          2672:       }
        !          2673:     }
        !          2674:     if (/^head:\s+([\d\.]+)/) {
        !          2675:       $head = $1;
        !          2676:     } elsif (/^branch:\s+([\d\.]+)/) {
        !          2677:       $curbranch = $1;
        !          2678:     } elsif (/^symbolic names/) {
        !          2679:       $symnames = 1;
        !          2680:     } elsif (/^keyword substitution: (.+)$/) {
        !          2681:       $keywordsubstitution = $1;
        !          2682:     } elsif (/^-----/) {
        !          2683:       last;
        !          2684:     }
        !          2685:   }
        !          2686:   ($curbranch = $head) =~ s/\.\d+$// if (!defined($curbranch));
        !          2687:
        !          2688:   # each log entry is of the form:
        !          2689:   # ----------------------------
        !          2690:   # revision 3.7.1.1
        !          2691:   # date: 1995/11/29 22:15:52;  author: fenner;  state: Exp;  lines: +5 -3
        !          2692:   # log info
        !          2693:   # ----------------------------
        !          2694:
        !          2695:   # For a locked revision, the first line after the separator
        !          2696:   # becomes smth like
        !          2697:   # revision 9.19       locked by: vassilii;
        !          2698:
        !          2699:   logentry:
        !          2700:
        !          2701:   while ($_ !~ LOG_FILESEPR) {
        !          2702:     $_ = <$fh>;
        !          2703:     last logentry if (!defined($_));    # EOF
        !          2704:     if (/^revision (\d+(?:\.\d+)+)/) {
        !          2705:       $rev = $1;
        !          2706:       unshift(@allrevisions, $rev);
        !          2707:     } elsif ($_ =~ LOG_FILESEPR || $_ =~ LOG_REVSEPR) {
        !          2708:       next logentry;
        !          2709:     } else {
        !          2710:
        !          2711:       # The rlog output is syntactically ambiguous.  We must
        !          2712:       # have guessed wrong about where the end of the last log
        !          2713:       # message was.
        !          2714:       # Since this is likely to happen when people put rlog output
        !          2715:       # in their commit messages, don't even bother keeping
        !          2716:       # these lines since we don't know what revision they go with
        !          2717:       # any more.
        !          2718:       next logentry;
        !          2719:     }
        !          2720:     $_ = <$fh>;
        !          2721:     if (
        !          2722:       m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);\s+author:\s+(\S+);\s+state:\s+(\S+);\s+(lines:\s+([0-9\s+-]+))?|
        !          2723:       )
        !          2724:     {
        !          2725:       my $yr           = $1;
        !          2726:       $yr             -= 1900 if ($yr > 100); # Damn 2-digit year routines :-)
        !          2727:       $date{$rev}      = timegm($6, $5, $4, $3, $2 - 1, $yr);
        !          2728:       $author{$rev}    = $7;
        !          2729:       $state{$rev}     = $8;
        !          2730:       $difflines{$rev} = $10;
        !          2731:     } else {
        !          2732:       fatal("500 Internal Error", 'Error parsing RCS output: %s', $_);
        !          2733:     }
        !          2734:
        !          2735:   line:
        !          2736:     while (<$fh>) {
        !          2737:       next line if (/^branches:\s/);
        !          2738:       last line if ($_ =~ LOG_FILESEPR || $_ =~ LOG_REVSEPR);
        !          2739:       $log{$rev} .= $_;
        !          2740:     }
        !          2741:   }
        !          2742:   close($fh);
        !          2743:
        !          2744:   @revorder = reverse sort { revcmp($a, $b) } @allrevisions;
        !          2745:
        !          2746:   #
        !          2747:   # HEAD is an artificial tag which is simply the highest tag number on the main
        !          2748:   # branch, unless there is a branch tag in the RCS file in which case it's the
        !          2749:   # highest revision on that branch.  Find it by looking through @revorder; it
        !          2750:   # is the first commit listed on the appropriate branch.
        !          2751:   # This is not neccesary the same revision as marked as head in the RCS file.
        !          2752:   my $headrev = $curbranch || "1";
        !          2753:   ($symrev{MAIN} = $headrev) =~ s/(\d+)$/0.$1/;
        !          2754:
        !          2755:   foreach $rev (@revorder) {
        !          2756:     if ($rev =~ /^(\S*)\.\d+$/ && $headrev eq $1) {
        !          2757:       $symrev{HEAD} = $rev;
        !          2758:       last;
        !          2759:     }
        !          2760:   }
        !          2761:   ($symrev{HEAD} = $headrev) =~ s/\.\d+$// unless defined($symrev{HEAD});
        !          2762:
        !          2763:   #
        !          2764:   # Now that we know all of the revision numbers, we can associate
        !          2765:   # absolute revision numbers with all of the symbolic names, and
        !          2766:   # pass them to the form so that the same association doesn't have
        !          2767:   # to be built then.
        !          2768:   #
        !          2769:   undef @branchnames;
        !          2770:   undef %branchpoint;
        !          2771:   undef $sel;
        !          2772:
        !          2773:   foreach (reverse sort keys %symrev) {
        !          2774:     $rev = $symrev{$_};
        !          2775:     if ($rev =~ /^((.*)\.)?\b0\.(\d+)$/) {
        !          2776:       push (@branchnames, $_);
        !          2777:
        !          2778:       #
        !          2779:       # A revision number of A.B.0.D really translates into
        !          2780:       # "the highest current revision on branch A.B.D".
        !          2781:       #
        !          2782:       # If there is no branch A.B.D, then it translates into
        !          2783:       # the head A.B .
        !          2784:       #
        !          2785:       # This reasoning also applies to the main branch A.B,
        !          2786:       # with the branch number 0.A, with the exception that
        !          2787:       # it has no head to translate to if there is nothing on
        !          2788:       # the branch, but I guess this can never happen?
        !          2789:       #
        !          2790:       # (the code below gracefully forgets about the branch
        !          2791:       # if it should happen)
        !          2792:       #
        !          2793:       $head = defined($2) ? $2 : "";
        !          2794:       $branch = $3;
        !          2795:       $branchrev = $head . ($head ne "" ? "." : "") . $branch;
        !          2796:       $rev = $head;
        !          2797:
        !          2798:       my $regex = '^' . quotemeta($branchrev) . '\b';
        !          2799:       $regex = qr/$regex/;
        !          2800:
        !          2801:       foreach my $r (@revorder) {
        !          2802:         if ($r =~ $regex) {
        !          2803:           $rev = $branchrev;
        !          2804:           last;
        !          2805:         }
        !          2806:       }
        !          2807:       next if ($rev eq "");
        !          2808:
        !          2809:       if ($rev ne $head && $head ne "") {
        !          2810:         $branchpoint{$head} .= ', ' if ($branchpoint{$head});
        !          2811:         $branchpoint{$head} .= $_;
        !          2812:       }
        !          2813:     }
        !          2814:     $revsym{$rev} .= ", " if ($revsym{$rev});
        !          2815:     $revsym{$rev} .= $_;
        !          2816:     $sel .= sprintf("<option value=\"%s:%s\">%s</option>\n",
        !          2817:                     htmlquote($rev), (htmlquote($_)) x 2);
        !          2818:   }
        !          2819:
        !          2820:   my ($onlyonbranch, $onlybranchpoint);
        !          2821:   if ($onlyonbranch = $input{only_with_tag}) {
        !          2822:     $onlyonbranch = $symrev{$onlyonbranch};
        !          2823:     if ($onlyonbranch && $onlyonbranch =~ s/\b0\.//) {
        !          2824:       ($onlybranchpoint = $onlyonbranch) =~ s/\.\d+$//;
        !          2825:     } else {
        !          2826:       $onlybranchpoint = $onlyonbranch;
        !          2827:     }
        !          2828:
        !          2829:     if (!defined($onlyonbranch) || $onlybranchpoint eq "") {
        !          2830:       fatal("404 Tag not found", 'Tag "<code>%s</code>" is not defined.',
        !          2831:             $input{only_with_tag});
        !          2832:     }
        !          2833:   }
        !          2834:
        !          2835:   undef @revisions;
        !          2836:
        !          2837:   foreach (@allrevisions) {
        !          2838:     ($br  = $_)  =~ s/\.\d+$//;
        !          2839:     ($brp = $br) =~ s/\.\d+$//;
        !          2840:     next if ($onlyonbranch
        !          2841:              && $br ne $onlyonbranch
        !          2842:              && $_  ne $onlybranchpoint);
        !          2843:     unshift(@revisions, $_);
        !          2844:   }
        !          2845:
        !          2846:   if ($logsort eq "date") {
        !          2847:
        !          2848:     # Sort the revisions in commit order an secondary sort on revision
        !          2849:     # (secondary sort needed for imported sources, or the first main
        !          2850:     # revision gets before the same revision on the 1.1.1 branch)
        !          2851:     @revdisplayorder =
        !          2852:       sort { $date{$b} <=> $date{$a} || -revcmp($a, $b) } @revisions;
        !          2853:   } elsif ($logsort eq "rev") {
        !          2854:
        !          2855:     # Sort the revisions in revision order, highest first
        !          2856:     @revdisplayorder = reverse sort { revcmp($a, $b) } @revisions;
        !          2857:   } else {
        !          2858:
        !          2859:     # No sorting. Present in the same order as rlog / cvs log
        !          2860:     @revdisplayorder = @revisions;
        !          2861:   }
        !          2862:
        !          2863:   return $curbranch;
1.1.1.30  knu      2864: }
1.1.1.37! simon    2865:
        !          2866:
        !          2867: sub getDiffLinks($$$)
        !          2868: {
        !          2869:   my ($url, $mimetype, $isbin) = @_;
        !          2870:
        !          2871:   my @links = ();
        !          2872:   if (!$isbin) { # Offer ordinary diff only for non-binary files.
        !          2873:     push(@links, &link('preferred', $url));
        !          2874:     for my $difftype ($DIFFTYPES{$defaultDiffType}{colored} ? qw(u) : qw(h)) {
        !          2875:       my $f = $difftype eq $defaultDiffType ? '' : $difftype;
        !          2876:       push(@links,
        !          2877:            &link(htmlquote(lc($DIFFTYPES{$difftype}{descr})), "$url;f=$f"));
        !          2878:     }
        !          2879:   }
        !          2880:   if (my $extdiffs = $DIFF_COMMANDS{lc($mimetype)}) {
        !          2881:     for my $i (0 .. scalar(@$extdiffs)-1) {
        !          2882:       my $extdiff = $extdiffs->[$i];
        !          2883:       push(@links, &link(htmlquote($extdiff->{name}), "$url;f=ext$i"))
        !          2884:         if ($extdiff->{cmd} && $extdiff->{name});
        !          2885:     }
        !          2886:   }
        !          2887:   return @links;
1.1.1.30  knu      2888: }
                   2889:
1.1.1.37! simon    2890:
        !          2891: sub printLog($$$;$$)
        !          2892: {
        !          2893:   # inlogview: 1 if in log view, otherwise in markup view.
        !          2894:   ($_, my $mimetype, my $isbin, my $inlogview, my $isSelected) = @_;
        !          2895:   (my $br  = $_)  =~ s/\.\d+$//;
        !          2896:   (my $brp = $br) =~ s/\.?\d+$//;
        !          2897:
        !          2898:   print "<a name=\"rev$_\"></a>";
        !          2899:   if (defined($revsym{$_})) {
        !          2900:     foreach my $sym (split(", ", $revsym{$_})) {
        !          2901:       print '<a name="', htmlquote($sym), '"></a>';
        !          2902:     }
        !          2903:   }
        !          2904:   if ($revsym{$br} && !defined($nameprinted{$br})) {
        !          2905:     foreach my $sym (split(", ", $revsym{$br})) {
        !          2906:       print '<a name="', htmlquote($sym), '"></a>';
        !          2907:     }
        !          2908:     $nameprinted{$br} = 1;
        !          2909:   }
        !          2910:
        !          2911:   print "\n Revision <b>$_</b>";
        !          2912:   if (/^1\.1\.1\.\d+$/) {
        !          2913:     print " <i>(vendor branch)</i>";
        !          2914:   }
        !          2915:
        !          2916:   (my $filename = $where) =~ s|^.*/||;
        !          2917:   my $fileurl   = uri_escape($filename);
        !          2918:   undef $filename;
        !          2919:
        !          2920:   my $isDead = ($state{$_} eq 'dead');
        !          2921:   if (!$isDead) {
        !          2922:
        !          2923:     print ': ', download_link($fileurl, $_, 'download', $mimetype);
        !          2924:
        !          2925:     my @vlinks = ();
        !          2926:     push(@vlinks, display_link($fileurl, $_, 'text', 'text/plain'))
        !          2927:       unless $isbin;
        !          2928:     push(@vlinks, display_link($fileurl, $_, 'markup', 'text/x-cvsweb-markup'))
        !          2929:       if ($allow_markup && $inlogview && (!$isbin || viewable($mimetype)));
        !          2930:     if (!$isbin && $allow_annotate) {
        !          2931:       push(@vlinks,
        !          2932:            &link('annotated',
        !          2933:                  sprintf('%s?annotate=%s%s', $fileurl, $_, $barequery)));
        !          2934:     }
        !          2935:     print ' - view: ', join(', ', @vlinks) if @vlinks;
        !          2936:     undef @vlinks;
        !          2937:
        !          2938:     if (!$isbin && $allow_version_select) {
        !          2939:       print ' - ';
        !          2940:       if ($isSelected) {
        !          2941:         print '<b>[selected&nbsp;for&nbsp;diffs]</b>';
        !          2942:       } else {
        !          2943:         print &link('select&nbsp;for&nbsp;diffs',
        !          2944:                     sprintf('%s?r1=%s%s#rev%s',
        !          2945:                             $fileurl, $_, $barequery, $_));
        !          2946:       }
        !          2947:     }
        !          2948:     print ' - ', graph_link('', 'revision graph')
        !          2949:       if (!$inlogview && $allow_cvsgraph);
        !          2950:   }
        !          2951:   print "<br />\n";
        !          2952:
        !          2953:   print '<i>';
        !          2954:   if (defined @mytz) {
        !          2955:     my ($est) = $mytz[(localtime($date{$_}))[8]];
        !          2956:     print scalar localtime($date{$_}), " $est</i> (";
        !          2957:   } else {
        !          2958:     print scalar gmtime($date{$_}), " UTC</i> (";
        !          2959:   }
        !          2960:   print readableTime(time() - $date{$_}, 1), ' ago)';
        !          2961:   print ' by <i>', htmlquote($author{$_}), "</i><br />\n";
        !          2962:
        !          2963:   printf("Branches: %s<br />\n", link_tags($revsym{$br})) if $revsym{$br};
        !          2964:   printf("CVS tags: %s<br />\n", link_tags($revsym{$_}))  if $revsym{$_};
        !          2965:   printf("Branch point for: %s<br />\n", link_tags($branchpoint{$_}))
        !          2966:     if $branchpoint{$_};
        !          2967:
        !          2968:   # Find the previous revision
        !          2969:   my $prev;
        !          2970:   my @prevrev = split(/\./, $_);
        !          2971:   do {
        !          2972:     if (--$prevrev[$#prevrev] <= 0) {
        !          2973:
        !          2974:       # If it was X.Y.Z.1, just make it X.Y
        !          2975:       pop (@prevrev);
        !          2976:       pop (@prevrev);
        !          2977:     }
        !          2978:     $prev = join (".", @prevrev);
        !          2979:   } until (defined($date{$prev}) || $prev eq "");
        !          2980:
        !          2981:   if ($isDead) {
        !          2982:     print "<b><i>FILE REMOVED</i></b><br />\n";
        !          2983:   } else {
        !          2984:     my %diffrev = ();
        !          2985:     $diffrev{$_} = 1;
        !          2986:     $diffrev{""} = 1;
        !          2987:     my $diff = 'Diff to:';
        !          2988:     my $printed = 0;
        !          2989:
        !          2990:     #
        !          2991:     # Offer diff to previous revision
        !          2992:     if ($prev) {
        !          2993:       $diffrev{$prev} = 1;
        !          2994:       my $url =
        !          2995:         sprintf('%s.diff?r1=%s;r2=%s%s', $fileurl, $prev, $_, $barequery);
        !          2996:       if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
        !          2997:         print $diff, ' previous ', $prev, ': ', join(', ', @dlinks);
        !          2998:         $diff = ';'; $printed = 1;
        !          2999:       }
        !          3000:     }
        !          3001:
        !          3002:     #
        !          3003:     # Plus, if it's on a branch, and it's not a vendor branch,
        !          3004:     # offer a diff with the branch point.
        !          3005:     if ($revsym{$brp}
        !          3006:       && !/^1\.1\.1\.\d+$/
        !          3007:       && !defined($diffrev{$brp}))
        !          3008:     {
        !          3009:       my $url =
        !          3010:         sprintf('%s.diff?r1=%s;r2=%s%s', $fileurl, $brp, $_, $barequery);
        !          3011:       if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
        !          3012:         print $diff, ' branchpoint ', $brp, ': ', join(', ', @dlinks);
        !          3013:         $diff = ';'; $printed = 1;
        !          3014:       }
        !          3015:     }
        !          3016:
        !          3017:     #
        !          3018:     # Plus, if it's on a branch, and it's not a vendor branch,
        !          3019:     # offer to diff with the next revision of the higher branch.
        !          3020:     # (e.g. change gets committed and then brought
        !          3021:     # over to -stable)
        !          3022:     if (/^\d+\.\d+\.\d+/ && !/^1\.1\.1\.\d+$/) {
        !          3023:       my ($i, $nextmain);
        !          3024:
        !          3025:       for ($i = 0; $i < $#revorder && $revorder[$i] ne $_; $i++) {
        !          3026:       }
        !          3027:       my @tmp2 = split(/\./, $_);
        !          3028:       for ($nextmain = ""; $i > 0; $i--) {
        !          3029:         my $next = $revorder[$i - 1];
        !          3030:         my @tmp1 = split(/\./, $next);
        !          3031:
        !          3032:         if (@tmp1 < @tmp2) {
        !          3033:           $nextmain = $next;
        !          3034:           last;
        !          3035:         }
        !          3036:
        !          3037:         # Only the highest version on a branch should have
        !          3038:         # a diff for the "next MAIN".
        !          3039:         last
        !          3040:           if (@tmp1 - 1 <= @tmp2
        !          3041:           && join (".", @tmp1[0 .. $#tmp1 - 1]) eq
        !          3042:           join (".", @tmp2[0 .. $#tmp1 - 1]));
        !          3043:       }
        !          3044:
        !          3045:       if (!defined($diffrev{$nextmain})) {
        !          3046:         $diffrev{$nextmain} = 1;
        !          3047:         my $url = sprintf('%s.diff?r1=%s;r2=%s%s',
        !          3048:           $fileurl, $nextmain, $_, $barequery);
        !          3049:         if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
        !          3050:           print $diff, ' next MAIN ', $nextmain, ': ', join(', ', @dlinks);
        !          3051:           $diff = ';'; $printed = 1;
        !          3052:         }
        !          3053:       }
        !          3054:     }
        !          3055:
        !          3056:     # Plus if user has selected only r1, then present a link
        !          3057:     # to make a diff to that revision
        !          3058:     if (defined($input{r1}) && !defined($diffrev{$input{r1}})) {
        !          3059:       $diffrev{$input{r1}} = 1;
        !          3060:       my $url = sprintf('%s.diff?r1=%s;r2=%s%s',
        !          3061:         $fileurl, $input{r1}, $_, $barequery);
        !          3062:       if (my @dlinks = getDiffLinks($url, $mimetype, $isbin)) {
        !          3063:         print $diff, ' selected ', $input{r1}, ': ', join(', ', @dlinks);
        !          3064:         $diff = ';'; $printed = 1;
        !          3065:       }
        !          3066:     }
        !          3067:
        !          3068:     print "<br />\n" if $printed;
        !          3069:   }
        !          3070:
        !          3071:   if ($prev ne "" && $difflines{$_}) {
        !          3072:     printf "Changes since revision %s: %s lines<br />\n",
        !          3073:       htmlquote($prev), htmlquote($difflines{$_});
        !          3074:   }
        !          3075:
        !          3076:   print "<pre class=\"log\">\n";
        !          3077:   print &htmlify($log{$_}, $allow_log_extra);
        !          3078:   print "</pre>\n";
        !          3079: }
        !          3080:
        !          3081:
        !          3082: #
        !          3083: # Generates the HTML view for CvsGraph.
        !          3084: #
        !          3085: sub doGraphView()
        !          3086: {
        !          3087:   (my $pathname = $where) =~ s|[^/]*$||;
        !          3088:   (my $filename = $where) =~ s|^.*/||;
        !          3089:
        !          3090:   navigateHeader($scriptwhere, $pathname, $filename, undef, 'graph');
        !          3091:
        !          3092:   my $title = 'Revision graph of ' . htmlquote($pathname . $filename);
        !          3093:   my $mapname = 'CvsGraphMap';
        !          3094:
        !          3095:   printf(<<EOF, $title, $mapname, $cvstree, $title);
        !          3096: <h3 style="text-align: center">%s</h3>
        !          3097: <div style="text-align: center"><img border="0" usemap="#%s" src="?cvsroot=%s;graph=1;makeimage=1" alt="%s" />
        !          3098: EOF
        !          3099:
        !          3100:   # Remove any pre-existing tag/branch names from branch links.
        !          3101:   (my $notag_query = $barequery) =~ s/;+only_with_tag=.*?(?=;|$)//g;
        !          3102:
        !          3103:   my @graph_cmd =
        !          3104:     ($CMD{cvsgraph},
        !          3105:      '-r', $cvsroot,
        !          3106:      '-m', $pathname,
        !          3107:      '-i',
        !          3108:      '-M', $mapname,
        !          3109:      '-x', 'x',
        !          3110:      "-Omap_branch_href=\"href=\\\"./?only_with_tag=%(%t%)$notag_query\\\"\"",
        !          3111:      "-Omap_rev_href=\"href=\\\"?rev=%(%R%)$barequery\\\"\"",
        !          3112:      "-Omap_diff_href=\"href=\\\"%(%F%).diff" .
        !          3113:      "?r1=%(%P%);r2=%(%R%)$barequery\\\"\"",
        !          3114:      );
        !          3115:   push(@graph_cmd, '-c', $cvsgraph_config) if $cvsgraph_config;
        !          3116:   push(@graph_cmd, $filename . ',v');
        !          3117:
        !          3118:   local *CVSGRAPH_OUT;
        !          3119:   my ($h, $err) =
        !          3120:     startproc(\@graph_cmd, \"", '>pipe', \*CVSGRAPH_OUT);
        !          3121:   fatal('500 Internal Error', $err) unless $h;
        !          3122:
        !          3123:   # Browser compatibility kludge: many browsers do not support client side
        !          3124:   # image maps where the <map> element contains only the id attribute.  Let's
        !          3125:   # add the corresponding name attribute to it on the fly.
        !          3126:   while (<CVSGRAPH_OUT>) {
        !          3127:     s/(<map\s+id="([^"]+)")\s*>/$1 name="$2">/;
        !          3128:     print;
        !          3129:   }
        !          3130:
        !          3131:   $h->finish();
        !          3132:   print "</div>\n";
        !          3133:
        !          3134:   html_footer();
        !          3135: }
        !          3136:
        !          3137:
        !          3138: #
        !          3139: # Generates a graph using CvsGraph.
        !          3140: #
        !          3141: sub doGraph()
        !          3142: {
        !          3143:   (my $pathname = $where) =~ s|[^/]*$||;
        !          3144:   (my $filename = $where) =~ s|^.*/||;
        !          3145:
        !          3146:   http_header('image/png');
        !          3147:
        !          3148:   my @graph_cmd = ($CMD{cvsgraph}, '-r', $cvsroot, '-m', $pathname);
        !          3149:   push(@graph_cmd, '-c', $cvsgraph_config) if $cvsgraph_config;
        !          3150:   push(@graph_cmd, $filename . ',v');
        !          3151:
        !          3152:   local *CVSGRAPH_OUT;
        !          3153:   my ($h, $err) =
        !          3154:     startproc(\@graph_cmd, \"", '>pipe', \*CVSGRAPH_OUT);
        !          3155:   fatal('500 Internal Error', $err) unless $h;
        !          3156:   {
        !          3157:     local $/ = undef;
        !          3158:     binmode(\*STDOUT);
        !          3159:     print <CVSGRAPH_OUT>;
        !          3160:   }
        !          3161:   $h->finish();
        !          3162: }
        !          3163:
        !          3164:
        !          3165: sub doLog($)
        !          3166: {
        !          3167:   my ($fullname) = @_;
        !          3168:
        !          3169:   my $curbranch = readLog($fullname);
        !          3170:
        !          3171:   html_header("CVS log for $where");
        !          3172:
        !          3173:   my $upwhere = $where;
        !          3174:   (my $filename = $where) =~ s|^.*/||;
        !          3175:   my $backurl = "./$query#" . uri_escape($filename);
        !          3176:   if ($where =~ m|^(.*?)((?<=/)Attic/)?[^/]+$|) {
        !          3177:     $upwhere = $1;
        !          3178:     $backurl = ".$backurl" if $2; # skip over Attic
        !          3179:   }
        !          3180:
        !          3181:   my $isbin = $keywordsubstitution =~ /b/;
        !          3182:   my $mimetype = getMimeType($filename, $isbin);
        !          3183:
        !          3184:   print "<p>\n ";
        !          3185:   print &link($backicon, $backurl), " <b>Up to ",
        !          3186:     &clickablePath($upwhere, 1), "</b>\n</p>\n";
        !          3187:   print "<p>\n ";
        !          3188:   print &link('Request diff between arbitrary revisions', '#diff');
        !          3189:   print ' - ', &graph_link('', 'Display revisions graphically')
        !          3190:     if $allow_cvsgraph;
        !          3191:   if ($cvshistory_url) {
        !          3192:     (my $d = $upwhere) =~ s|/+$||;
        !          3193:     print ' - ', history_link($d, $filename);
        !          3194:   }
        !          3195:   print "\n</p>\n<hr />\n";
        !          3196:
        !          3197:   print "<p>\n";
        !          3198:
        !          3199:   my $explain = $isbin ? ' (i.e.: CVS considers this a binary file)' : '';
        !          3200:   print "Keyword substitution: $keywordsubstitution$explain<br />\n";
        !          3201:   if ($curbranch) {
        !          3202:     print "Default branch: ", ($revsym{$curbranch} || $curbranch);
        !          3203:   } else {
        !          3204:     print "No default branch";
        !          3205:   }
        !          3206:   print "<br />\n";
        !          3207:
        !          3208:   print 'Current tag: ', htmlquote($input{only_with_tag}), "<br />\n"
        !          3209:     if $input{only_with_tag};
        !          3210:   print "</p>\n";
        !          3211:
        !          3212:   undef %nameprinted;
        !          3213:
        !          3214:   for my $r (@revdisplayorder) {
        !          3215:     print "<hr />\n";
        !          3216:     my $sel = (defined($input{r1}) && $input{r1} eq $r);
        !          3217:     print "<div class=\"diff-selected\">\n" if $sel;
        !          3218:     printLog($r, $mimetype, $isbin, 1, $sel);
        !          3219:     print "</div>\n" if $sel;
        !          3220:   }
        !          3221:
        !          3222:   printf(<<EOF, $scriptwhere);
        !          3223: <hr />
        !          3224: <form method="get" action="%s.diff" id="diff_select">
        !          3225: <fieldset>
        !          3226: <legend>Diff request</legend>
        !          3227: <p>
        !          3228:  <a name="diff">
        !          3229:   This form allows you to request diffs between any two revisions of a file.
        !          3230:   You may select a symbolic revision name using the selection box or you may
        !          3231:   type in a numeric name using the type-in text box.
        !          3232:  </a>
        !          3233: </p>
        !          3234: EOF
        !          3235:
        !          3236:   foreach (@stickyvars) {
        !          3237:     printf("<input type=\"hidden\" name=\"%s\" value=\"%s\" />\n",
        !          3238:            $_, htmlquote($input{$_}))
        !          3239:       if (defined($input{$_}) &&
        !          3240:           (!defined($DEFAULTVALUE{$_}) || $input{$_} ne $DEFAULTVALUE{$_}));
        !          3241:   }
        !          3242:
        !          3243:   print <<EOF;
        !          3244: <table summary="Diff between arbitrary revisions">
        !          3245: <tr>
        !          3246: <td class="opt-label">
        !          3247: <label for="r1" accesskey="1">Diffs between</label>
        !          3248: </td>
        !          3249: <td class="opt-value">
        !          3250: <select id="r1" name="r1">
        !          3251: <option value="text" selected="selected">Use Text Field</option>
        !          3252: EOF
        !          3253:   print $sel, "</select>\n";
        !          3254:
        !          3255:   my $diffrev = defined($input{r1}) ?
        !          3256:     $input{r1} : $revdisplayorder[$#revdisplayorder];
        !          3257:
        !          3258:   printf(<<EOF, $inputTextSize, $diffrev);
        !          3259: <input type="text" size="%s" name="tr1" value="%s" onchange="this.form.r1.selectedIndex=0" />
        !          3260: </td>
        !          3261: <td></td>
        !          3262: </tr>
        !          3263: <tr>
        !          3264: <td class="opt-label">
        !          3265: <label for="r2" accesskey="2">and</label>
        !          3266: </td>
        !          3267: <td class="opt-value">
        !          3268: <select id="r2" name="r2">
        !          3269: <option value="text" selected="selected">Use Text Field</option>
        !          3270: EOF
        !          3271:   print $sel, "</select>\n";
        !          3272:
        !          3273:   $diffrev = defined($input{r2}) ? $input{r2} : $revdisplayorder[0];
        !          3274:
        !          3275:   printf(<<EOF, $inputTextSize, $diffrev, $scriptwhere);
        !          3276: <input type="text" size="%s" name="tr2" value="%s" onchange="this.form.r2.selectedIndex=0" />
        !          3277: </td>
        !          3278: <td><input type="submit" value="Get Diffs" accesskey="G" /></td>
        !          3279: </tr>
        !          3280: </table>
        !          3281: </fieldset>
        !          3282: </form>
        !          3283: <form method="get" action="%s">
        !          3284: <fieldset>
        !          3285: <legend>Log view options</legend>
        !          3286: <table summary="Log view options">
        !          3287: <tr>
        !          3288: <td class="opt-label">
        !          3289: <label for="f" accesskey="D">Preferred diff type:</label>
        !          3290: </td>
        !          3291: <td class="opt-value">
        !          3292: EOF
        !          3293:   printDiffSelect($use_java_script);
        !          3294:   print <<EOF;
        !          3295: </td>
        !          3296: <td></td>
        !          3297: </tr>
        !          3298: EOF
        !          3299:
        !          3300:   if (@branchnames) {
        !          3301:
        !          3302:     printf(<<EOF, $use_java_script ? ' onchange="this.form.submit()"' : '');
        !          3303: <tr>
        !          3304: <td class="opt-label">
        !          3305: <label for="only_with_tag" accesskey="B">View only branch:</label>
        !          3306: </td>
        !          3307: <td class="opt-value">
        !          3308: <a name="branch">
        !          3309: <select id="only_with_tag" name="only_with_tag"%s>
        !          3310: EOF
        !          3311:
        !          3312:     my @tmp = ();
        !          3313:     my $selfound = 0;
        !          3314:     foreach (reverse sort @branchnames) {
        !          3315:       my $selected =
        !          3316:         (defined($input{only_with_tag}) && $input{only_with_tag} eq $_);
        !          3317:       $selfound ||= $selected;
        !          3318:       push(@tmp, sprintf('<option%s>%s</option>',
        !          3319:                          $selected ? ' selected="selected"' : '',
        !          3320:                          htmlquote($_)));
        !          3321:     }
        !          3322:     printf("<option value=\"\"%s>Show all branches</option>\n",
        !          3323:            $selfound ? '' : ' selected="selected"');
        !          3324:     print join("\n", @tmp);
        !          3325:
        !          3326:     print <<EOF
        !          3327: </select>
        !          3328: </a>
        !          3329: </td>
        !          3330: <td></td>
        !          3331: </tr>
        !          3332: EOF
        !          3333:   }
        !          3334:
        !          3335:   print <<EOF;
        !          3336: <tr>
        !          3337: <td class="opt-label">
        !          3338: <label for="logsort" accesskey="L">Sort log by:</label>
        !          3339: </td>
        !          3340: <td>
        !          3341: EOF
        !          3342:   printLogSortSelect($use_java_script);
        !          3343:   print <<EOF;
        !          3344: </td>
        !          3345: <td><input type="submit" value="Set" accesskey="S" /></td>
        !          3346: </tr>
        !          3347: </table>
        !          3348: EOF
        !          3349:   foreach (@stickyvars) {
        !          3350:     next if ($_ eq "f");
        !          3351:     next if ($_ eq "only_with_tag");
        !          3352:     next if ($_ eq "logsort");
        !          3353:     printf("<input type=\"hidden\" name=\"$_\" value=\"%s\" />\n",
        !          3354:            htmlquote($input{$_}))
        !          3355:       if (defined($input{$_})
        !          3356:           && (!defined($DEFAULTVALUE{$_}) || $input{$_} ne $DEFAULTVALUE{$_}));
        !          3357:   }
        !          3358:   print "</fieldset>\n</form>\n";
        !          3359:   html_footer();
        !          3360: }
        !          3361:
        !          3362:
        !          3363: sub flush_diff_rows($$$$)
        !          3364: {
        !          3365:   my ($leftColRef, $rightColRef, $leftRow, $rightRow) = @_;
        !          3366:
        !          3367:   return unless defined($state);
        !          3368:
        !          3369:   if ($state eq "PreChangeRemove") {    # we just got remove-lines before
        !          3370:     for (my $j = 0; $j < $leftRow; $j++) {
        !          3371:       printf(<<EOF, spacedHtmlText(@$leftColRef[$j]));
        !          3372: <tr>
        !          3373:  <td class="diff diff-removed">&nbsp;%s</td>
        !          3374:  <td class="diff diff-empty">&nbsp;</td>
        !          3375: </tr>
        !          3376: EOF
        !          3377:     }
        !          3378:   } elsif ($state eq "PreChange") {     # state eq "PreChange"
        !          3379:                                         # we got removes with subsequent adds
        !          3380:     if (HAS_EDIFF) {
        !          3381:       # construct the suffix tree
        !          3382:       my $left_diff = join("\n", @$leftColRef[0..$leftRow-1]);
        !          3383:       my $right_diff = join("\n", @$rightColRef[0..$rightRow-1]);
        !          3384:       my $diff_str = String::Ediff::ediff($left_diff, $right_diff);
        !          3385:
        !          3386:       my @diff_str = split(/ /, $diff_str);
        !          3387:       my $INFINITY = 10000000;
        !          3388:       push(@diff_str, ($INFINITY) x 8);
        !          3389:       my ($idx, $b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
        !          3390:         (0, @diff_str[0..7]);
        !          3391:       my ($l_cul, $r_cul) = (0, 0);
        !          3392:       my ($ldx, $rdx) = (0, 0);
        !          3393:       my (@left_html, @right_html);
        !          3394:       for (my $j = 0; $j < $leftRow; $j++) {
        !          3395:         my $line_len = length(@$leftColRef[$j]);
        !          3396:         my $line = @$leftColRef[$j];
        !          3397:         $l_cul += length($line) + 1; # includes "\n"
        !          3398:         my $l_culx = $l_cul - 1; # not includes "\n"
        !          3399:         if ($j < $lb1) {
        !          3400:           $line = spacedHtmlText($line);
        !          3401:           push(@left_html, "<td class=\"diff diff-changed\">$line</td>");
        !          3402:         } elsif ($lb1 == $j) {
        !          3403:           my $html_line;
        !          3404:           while ($lb1 == $j) {
        !          3405:             my $begin_char = $l_culx - $b1;
        !          3406:
        !          3407:             $line =~ /^(.*)(.{$begin_char})$/;
        !          3408:             $html_line .= spacedHtmlText($1) .
        !          3409:               '</span><span class="diff diff-unchanged">';
        !          3410:             $line = $2;
        !          3411:             last if ($j != $le1);
        !          3412:
        !          3413:             my $end_char = $l_culx - $e1;
        !          3414:             $line =~ /^(.*)(.{$end_char})$/;
        !          3415:             $html_line .= spacedHtmlText($1) .
        !          3416:               '</span><span class="diff diff-changed">';
        !          3417:             $line = $2;
        !          3418:
        !          3419:             $idx++;
        !          3420:             my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) =
        !          3421:               ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2);
        !          3422:             ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
        !          3423:               @diff_str[$idx*8..($idx+1)*8-1];
        !          3424:             $lb1 = $INFINITY if ($lb1 < 0);
        !          3425:             $lb2 = $INFINITY if ($lb2 < 0);
        !          3426:             $le1 = $INFINITY if ($le1 < 0);
        !          3427:             $le2 = $INFINITY if ($le2 < 0);
        !          3428:             if ($te1 > $b1) {
        !          3429:               ($b1, $lb1) = ($te1, $tle1);
        !          3430:             }
        !          3431:             if ($te2 > $b2) {
        !          3432:               ($b2, $lb2) = ($te2, $tle2);
        !          3433:             }
        !          3434:           }
        !          3435:           push(@left_html,
        !          3436:                sprintf('<td><span class="diff diff-changed">%s%s</span></td>',
        !          3437:                        $html_line, spacedHtmlText($line)));
        !          3438:         } elsif ($le1 == $j) {
        !          3439:           my $html_line;
        !          3440:           while ($le1 == $j) {
        !          3441:             my $end_char = $l_culx - $e1;
        !          3442:             $line =~ /^(.*)(.{$end_char})$/;
        !          3443:             $html_line .= spacedHtmlText($1) .
        !          3444:               '</span><span class="diff diff-changed">';
        !          3445:             $line = $2;
        !          3446:
        !          3447:             $idx++;
        !          3448:             my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) =
        !          3449:               ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2);
        !          3450:             ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
        !          3451:               @diff_str[$idx*8..($idx+1)*8-1];
        !          3452:             $lb1 = $INFINITY if ($lb1 < 0);
        !          3453:             $lb2 = $INFINITY if ($lb2 < 0);
        !          3454:             $le1 = $INFINITY if ($le1 < 0);
        !          3455:             $le2 = $INFINITY if ($le2 < 0);
        !          3456:             if ($te1 > $b1) {
        !          3457:               ($b1, $lb1) = ($te1, $tle1);
        !          3458:             }
        !          3459:             if ($te2 > $b2) {
        !          3460:               ($b2, $lb2) = ($te2, $tle2);
        !          3461:             }
        !          3462:
        !          3463:             last if ($lb1 != $j);
        !          3464:
        !          3465:             my $begin_char = $l_culx - $b1;
        !          3466:
        !          3467:             $line =~ /^(.*)(.{$begin_char})$/;
        !          3468:             $html_line .= spacedHtmlText($1) .
        !          3469:               '</span><span class="diff diff-unchanged">';
        !          3470:             $line = $2;
        !          3471:           }
        !          3472:           push(@left_html,
        !          3473:               sprintf('<td><span class="diff diff-unchanged">%s%s</span></td>',
        !          3474:                       $html_line, spacedHtmlText($line)));
        !          3475:         } else {
        !          3476:           $line = spacedHtmlText($line);
        !          3477:           push(@left_html, "<td class=\"diff diff-unchanged\">$line</td>");
        !          3478:         }
        !          3479:       }
        !          3480:       ($idx, $b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
        !          3481:         (0, @diff_str[0..7]);
        !          3482:       $lb1 = $INFINITY if ($lb1 < 0);
        !          3483:       $lb2 = $INFINITY if ($lb2 < 0);
        !          3484:       $le1 = $INFINITY if ($le1 < 0);
        !          3485:       $le2 = $INFINITY if ($le2 < 0);
        !          3486:       for (my $j = 0; $j < $rightRow; $j++) {
        !          3487:         my $line_len = length(@$rightColRef[$j]);
        !          3488:         my $line = @$rightColRef[$j];
        !          3489:         $r_cul += length($line) + 1; # includes "\n"
        !          3490:         my $r_culx = $r_cul - 1; # not includes "\n"
        !          3491:         if ($j < $lb2) {
        !          3492:           $line = spacedHtmlText($line);
        !          3493:           push(@right_html, "<td class=\"diff diff-changed\">$line</td>");
        !          3494:         } elsif ($lb2 == $j) {
        !          3495:           my $html_line;
        !          3496:           while ($lb2 == $j) {
        !          3497:             my $begin_char = $r_culx - $b2;
        !          3498:
        !          3499:             $line =~ /^(.*)(.{$begin_char})$/;
        !          3500:             $html_line .= spacedHtmlText($1) .
        !          3501:               '</span><span class="diff diff-unchanged">';
        !          3502:             $line = $2;
        !          3503:
        !          3504:             last if ($j != $le2);
        !          3505:
        !          3506:             my $end_char = $r_culx - $e2;
        !          3507:             $line =~ /^(.*)(.{$end_char})$/;
        !          3508:             $html_line .= spacedHtmlText($1) .
        !          3509:               '</span><span class="diff diff-changed">';
        !          3510:             $line = $2;
        !          3511:
        !          3512:             $idx++;
        !          3513:             my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) =
        !          3514:               ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2);
        !          3515:             ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
        !          3516:               @diff_str[$idx*8..($idx+1)*8-1];
        !          3517:             $lb1 = $INFINITY if ($lb1 < 0);
        !          3518:             $lb2 = $INFINITY if ($lb2 < 0);
        !          3519:             $le1 = $INFINITY if ($le1 < 0);
        !          3520:             $le2 = $INFINITY if ($le2 < 0);
        !          3521:             if ($te1 > $b1) {
        !          3522:               ($b1, $lb1) = ($te1, $tle1);
        !          3523:             }
        !          3524:             if ($te2 > $b2) {
        !          3525:               ($b2, $lb2) = ($te2, $tle2);
        !          3526:             }
        !          3527:           }
        !          3528:           push(@right_html,
        !          3529:                sprintf('<td><span class="diff diff-changed">%s%s</span></td>',
        !          3530:                        $html_line, spacedHtmlText($line)));
        !          3531:         } elsif ($le2 == $j) {
        !          3532:           my $html_line;
        !          3533:           while ($le2 == $j) {
        !          3534:             my $end_char = $r_culx - $e2;
        !          3535:             $line =~ /^(.*)(.{$end_char})$/;
        !          3536:             $html_line .= spacedHtmlText($1) .
        !          3537:               '</span><span class="diff diff-changed">';
        !          3538:             $line = $2;
        !          3539:
        !          3540:             $idx++;
        !          3541:             my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) =
        !          3542:               ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2);
        !          3543:             ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) =
        !          3544:               @diff_str[$idx*8..($idx+1)*8-1];
        !          3545:             $lb1 = $INFINITY if ($lb1 < 0);
        !          3546:             $lb2 = $INFINITY if ($lb2 < 0);
        !          3547:             $le1 = $INFINITY if ($le1 < 0);
        !          3548:             $le2 = $INFINITY if ($le2 < 0);
        !          3549:             if ($te1 > $b1) {
        !          3550:               ($b1, $lb1) = ($te1, $tle1);
        !          3551:             }
        !          3552:             if ($te2 > $b2) {
        !          3553:               ($b2, $lb2) = ($te2, $tle2);
        !          3554:             }
        !          3555:
        !          3556:             last if ($lb2 != $j);
        !          3557:
        !          3558:             my $begin_char = $r_culx - $b2;
        !          3559:             $line =~ /^(.*)(.{$begin_char})$/;
        !          3560:             $html_line .= spacedHtmlText($1) .
        !          3561:               '</span><span class="diff diff-unchanged">';
        !          3562:             $line = $2;
        !          3563:           }
        !          3564:           push(@right_html,
        !          3565:                sprintf('<td nowrap="nowrap"><span class="diff diff-unchanged"'.
        !          3566:                        '>%s%s</span></td>',
        !          3567:                        $html_line, spacedHtmlText($line)));
        !          3568:         } else {
        !          3569:           $line = spacedHtmlText ($line);
        !          3570:           push @right_html, "<td class=\"diff diff-unchanged\">$line</td>";
        !          3571:         }
        !          3572:       }
        !          3573:       for (my $j = 0; $j < $leftRow || $j < $rightRow ; $j++) { # dump out both cols
        !          3574:         print  '<tr>';
        !          3575:         if ($j < $leftRow) {
        !          3576:           print $left_html[$j];
        !          3577:         } else {
        !          3578:           print '<td class="diff diff-changed-missing">&nbsp;</td>';
        !          3579:         }
        !          3580:         if ($j < $rightRow) {
        !          3581:           print $right_html[$j];
        !          3582:         } else {
        !          3583:           print '<td class="diff diff-changed-missing">&nbsp;</td>';
        !          3584:         }
        !          3585:         print "</tr>\n";
        !          3586:       }
        !          3587:     } else {
        !          3588:       for (my $j = 0; $j < $leftRow || $j < $rightRow; $j++) { # dump both cols
        !          3589:         print "<tr>\n";
        !          3590:         if ($j < $leftRow) {
        !          3591:           print '<td class="diff diff-changed">&nbsp;' .
        !          3592:             spacedHtmlText(@$leftColRef[$j]) . '</td>';
        !          3593:         } else {
        !          3594:           print '<td class="diff diff-changed-missing">&nbsp;</td>';
        !          3595:         }
        !          3596:         print "\n";
        !          3597:
        !          3598:         if ($j < $rightRow) {
        !          3599:           print '<td class="diff diff-changed">&nbsp;' .
        !          3600:             spacedHtmlText(@$rightColRef[$j]) . '</td>';
        !          3601:         } else {
        !          3602:           print '<td class="diff diff-changed-missing">&nbsp;</td>';
        !          3603:         }
        !          3604:         print "\n</tr>\n";
        !          3605:       }
        !          3606:     }
        !          3607:   }
        !          3608: }
        !          3609:
        !          3610:
        !          3611: #
        !          3612: # Generates "human readable", HTMLified diffs.
        !          3613: #
        !          3614: sub human_readable_diff($$)
        !          3615: {
        !          3616:   my ($fh, $rev) = @_;
        !          3617:
        !          3618:   (my $where_nd       = $where)       =~ s|\.diff$||;
        !          3619:   (my $filename       = $where_nd)    =~ s|^.*/||;
        !          3620:   (my $pathname       = $where_nd)    =~ s|((?<=/)Attic/)?[^/]*$||;
        !          3621:   (my $scriptwhere_nd = $scriptwhere) =~ s|\.diff$||;
        !          3622:
        !          3623:   navigateHeader($scriptwhere_nd, $pathname, $filename, $rev, 'diff');
        !          3624:
        !          3625:   # Read header to pick up read revision and date, if possible.
        !          3626:
        !          3627:   my ($r1d, $r1r, $r2d, $r2r);
        !          3628:   while (<$fh>) {
        !          3629:     ($r1d, $r1r) = /\t(.*)\t(.*)$/ if (/^--- /);
        !          3630:     ($r2d, $r2r) = /\t(.*)\t(.*)$/ if (/^\+\+\+ /);
        !          3631:     last if (/^\+\+\+ /);
        !          3632:   }
        !          3633:
        !          3634:   my ($rev1, $date1);
        !          3635:   if (defined($r1r) && $r1r =~ /^(\d+\.)+\d+$/) {
        !          3636:     $rev1  = $r1r;
        !          3637:     $date1 = $r1d;
        !          3638:   }
        !          3639:   my ($rev2, $date2);
        !          3640:   if (defined($r2r) && $r2r =~ /^(\d+\.)+\d+$/) {
        !          3641:     $rev2  = $r2r;
        !          3642:     $date2 = $r2d;
        !          3643:   }
        !          3644:   $rev1  = $input{r1}      unless defined($rev1);
        !          3645:   $rev1  = $input{tr1}     if (defined($rev1) && $rev1 eq 'text');
        !          3646:   $rev1  = 'unknown-left'  unless defined($rev1);
        !          3647:   $rev2  = $input{r2}      unless defined($rev2);
        !          3648:   $rev2  = $input{tr2}     if (defined($rev2) && $rev2 eq 'text');
        !          3649:   $rev2  = 'unknown-right' unless defined($rev2);
        !          3650:   $date1 = defined($date1) ? ', ' . htmlquote($date1) : '';
        !          3651:   $date2 = defined($date2) ? ', ' . htmlquote($date2) : '';
        !          3652:
        !          3653:   my $link = uri_escape($filename) . ($query ? "$query;" : '?');
        !          3654:
        !          3655:   # Using <table style=\"border: none\" here breaks NS 4.x badly...
        !          3656:   print <<EOF;
        !          3657: <h3 style="text-align: center">Diff for /$where_nd between versions $rev1 and $rev2</h3>
        !          3658: <table border="0" cellspacing="0" cellpadding="0" width="100%" summary="Diff output">
        !          3659: <tr style="background-color: #ffffff">
        !          3660: <th style="text-align: center; vertical-align: top" width="50%">
        !          3661: <a href="${link}rev=$rev1">version $rev1</a>$date1
        !          3662: </th>
        !          3663: <th style="text-align: center; vertical-align: top" width="50%">
        !          3664: <a href="${link}rev=$rev2">version $rev2</a>$date2
        !          3665: </th>
        !          3666: </tr>
        !          3667: EOF
        !          3668:
        !          3669:   # Process diff text
        !          3670:   # prefetch several lines
        !          3671:   my @buf = head($fh);
        !          3672:   my %d = scan_directives(@buf);
        !          3673:
        !          3674:   my $leftRow  = 0;
        !          3675:   my $rightRow = 0;
        !          3676:   my ($difftxt, @rightCol, @leftCol, $oldline, $newline, $funname);
        !          3677:
        !          3678:   $link .= 'content-type=text%2Fx-cvsweb-markup;';
        !          3679:   $link .= 'ln=1;' unless ($link =~ /\?.*\bln=1\b/);
        !          3680:
        !          3681:   while (@buf || !eof($fh)) {
        !          3682:     $difftxt = @buf ? shift @buf : <$fh>;
        !          3683:
        !          3684:     if ($difftxt =~ /^@@/) {
        !          3685:       ($oldline, $newline, $funname) =
        !          3686:         $difftxt =~ /@@ \-([0-9]+).*\+([0-9]+).*@@(.*)/;
        !          3687:       $funname = htmlquote($funname);
        !          3688:       $funname =~ s/\s/&nbsp;/go;
        !          3689:       $funname &&= "&nbsp;<span style=\"font-size: smaller\">$funname</span>";
        !          3690:       my $ol = $oldline || 1;
        !          3691:       my $nl = $newline || 1;
        !          3692:
        !          3693:       print <<EOF;
        !          3694: <tr>
        !          3695: <td width="50%" class="diff-heading">
        !          3696:  <b><a href="${link}rev=$rev1#l$ol">Line&nbsp;$oldline</a></b>$funname
        !          3697: </td>
        !          3698: <td width="50%" class="diff-heading">
        !          3699:  <b><a href="${link}rev=$rev2#l$nl">Line&nbsp;$newline</a></b>$funname
        !          3700: </td>
        !          3701: </tr>
        !          3702: EOF
        !          3703:
        !          3704:       $state    = "dump";
        !          3705:       $leftRow  = 0;
        !          3706:       $rightRow = 0;
        !          3707:     } else {
        !          3708:       my ($diffcode, $rest) = $difftxt =~ /^([-+ ])(.*)/;
        !          3709:       $diffcode = '' unless defined($diffcode);
        !          3710:       $_ = $rest;
        !          3711:
        !          3712:       #########
        !          3713:       # little state machine to parse unified-diff output (Hen, zeller@think.de)
        !          3714:       # in order to get some nice 'ediff'-mode output
        !          3715:       # states:
        !          3716:       #  "dump"             - just dump the value
        !          3717:       #  "PreChangeRemove"  - we began with '-' .. so this could be the start of a 'change' area or just remove
        !          3718:       #  "PreChange"        - okey, we got several '-' lines and moved to '+' lines -> this is a change block
        !          3719:       ##########
        !          3720:
        !          3721:       if ($diffcode eq '+') {
        !          3722:         if ($state eq "dump")
        !          3723:         {    # 'change' never begins with '+': just dump out value
        !          3724:           $_ = spacedHtmlText($rest, $d{tabstop});
        !          3725:           printf(<<EOF, $_);
        !          3726: <tr>
        !          3727:  <td class="diff diff-empty">&nbsp;</td>
        !          3728:  <td class="diff diff-added">&nbsp;%s</td>
        !          3729: </tr>
        !          3730: EOF
        !          3731:         } else {    # we got minus before
        !          3732:           $state = "PreChange";
        !          3733:           $rightCol[$rightRow++] = $_;
        !          3734:         }
        !          3735:       } elsif ($diffcode eq '-') {
        !          3736:         $state = "PreChangeRemove";
        !          3737:         $leftCol[$leftRow++] = $_;
        !          3738:       } else {    # empty diffcode
        !          3739:         flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;
        !          3740:         $_ = spacedHtmlText($rest, $d{tabstop});
        !          3741:         printf(<<EOF, $_, $_);
        !          3742: <tr>
        !          3743:  <td class="diff diff-same">&nbsp;%s</td>
        !          3744:  <td class="diff diff-same">&nbsp;%s</td>
        !          3745: </tr>
        !          3746: EOF
        !          3747:         $state    = "dump";
        !          3748:         $leftRow  = 0;
        !          3749:         $rightRow = 0;
        !          3750:       }
        !          3751:     }
        !          3752:   }
        !          3753:   close($fh);
        !          3754:
        !          3755:   flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow;
        !          3756:
        !          3757:   # state is empty if we didn't have any change
        !          3758:   if (!$state) {
        !          3759:     print <<EOF;
        !          3760: <tr>
        !          3761:  <td colspan="2">&nbsp;</td>
        !          3762: </tr>
        !          3763: <tr class="diff diff-empty">
        !          3764:  <td colspan="2" align="center"><b>- No viewable change -</b></td>
        !          3765: </tr>
        !          3766: EOF
        !          3767:   }
        !          3768:
        !          3769:   printf(<<EOF, $scriptwhere);
        !          3770: </table>
        !          3771: <hr style="width: 100%%" />
        !          3772: <form method="get" action="%s">
        !          3773: <div style="float: left">
        !          3774: <label for="f">Diff format:<br />
        !          3775: EOF
        !          3776:   printDiffSelectStickyVars();
        !          3777:   printDiffSelect($use_java_script);
        !          3778:   printf(<<EOF, $rev1, $rev2);
        !          3779: </label>
        !          3780: <input type="submit" value="Show" />
        !          3781: </div>
        !          3782: <table style="float: right; border: thin outset" cellspacing="0" cellpadding="1" title="Legend" summary="Legend">
        !          3783:  <tr>
        !          3784:   <td align="center" class="diff diff-removed">Removed from v.%s</td>
        !          3785:   <td class="diff diff-empty">&nbsp;</td>
        !          3786:  </tr><tr class="diff diff-changed">
        !          3787:   <td align="center" colspan="2">changed lines</td>
        !          3788:  </tr><tr>
        !          3789:   <td class="diff diff-empty">&nbsp;</td>
        !          3790:   <td align="center" class="diff diff-added">Added in v.%s</td>
        !          3791:  </tr>
        !          3792: </table>
        !          3793: </form>
        !          3794: <br clear="all" />
        !          3795: EOF
        !          3796: }
        !          3797:
        !          3798:
        !          3799: sub doEnscript($$$;$)
        !          3800: {
        !          3801:   my ($filehandle, $highlight, $linenumbers, $lang) = @_;
        !          3802:   $lang ||= 'cvsweb';
        !          3803:
        !          3804:   my @cmd = ($CMD{enscript},
        !          3805:              @enscript_options,
        !          3806:              '-q', "--language=$lang", '-o', '-', "--highlight=$highlight");
        !          3807:
        !          3808:   local *ENSCRIPT_OUT;
        !          3809:   my ($h, $err) =
        !          3810:     startproc(\@cmd, $filehandle, '>pipe', \*ENSCRIPT_OUT);
        !          3811:   fatal('500 Internal Error', $err) unless $h;
        !          3812:
        !          3813:   # We could short-circuit and have enscript output directly to STDOUT above,
        !          3814:   # but that doesn't work with mod_perl (at least some 1.99 versions).
        !          3815:   if ($linenumbers) {
        !          3816:     my $ln = 0;
        !          3817:     while (<ENSCRIPT_OUT>) {
        !          3818:       printf '<a id="l%d" class="src">%5d: </a>', (++$ln) x 2;
        !          3819:       print $_;
        !          3820:     }
        !          3821:   } else {
        !          3822:     local $/ = undef;
        !          3823:     print <ENSCRIPT_OUT>;
        !          3824:   }
        !          3825:   $h->finish();
        !          3826: }
        !          3827:
        !          3828:
        !          3829: #
        !          3830: # The passed in $path and $filename should not be URI escaped, and $swhere
        !          3831: # *should* be.
        !          3832: #
        !          3833: sub navigateHeader($$$$$;$)
        !          3834: {
        !          3835:   my ($swhere, $path, $filename, $rev, $title, $moddate) = @_;
        !          3836:   $swhere = "" if ($swhere eq $scriptwhere);
        !          3837:   $swhere = './' . uri_escape($filename) if ($swhere eq "");
        !          3838:
        !          3839:   my $qfile = htmlquote($filename);
        !          3840:   my $qpath = htmlquote($path);
        !          3841:   my $trev  = $rev ? " - " . htmlquote($rev) : '';
        !          3842:
        !          3843:   http_header('', $moddate);
        !          3844:
        !          3845:   print <<EOF;
1.1.1.30  knu      3846: $HTML_DOCTYPE
1.1.1.29  knu      3847: <html>
                   3848: <head>
1.1.1.37! simon    3849: <title>$qpath$qfile - $title$trev</title>
        !          3850: $HTML_META$CSS</head>
        !          3851: <body class="src">
        !          3852: <table class="navigate-header" width="100%" summary="Navigation">
        !          3853:  <tr>
        !          3854:   <td>
        !          3855: EOF
        !          3856:
        !          3857:   my $frag = '';
        !          3858:   if ($rev) {
        !          3859:     $frag  = '#';
        !          3860:     $frag .= 'rev' if ($rev =~ /\./);  # Normal revision: prefix with "rev".
        !          3861:     $frag .= $rev;                     # Append revision/branch/tag.
        !          3862:   }
        !          3863:   my $backurl = "$swhere$query$frag";
        !          3864:
        !          3865:   print &link($backicon, $backurl);
        !          3866:   printf '<b>Return to %s CVS log', &link($qfile, $backurl);
        !          3867:   print "</b> $fileicon</td>";
        !          3868:
        !          3869:   printf(<<EOF, $diricon, &clickablePath($path, 1));
        !          3870:   <td style="text-align: right">%s <b>Up to %s</b></td>
        !          3871:  </tr>
        !          3872: </table>
        !          3873: EOF
        !          3874: }
        !          3875:
        !          3876:
        !          3877: sub plural_write($$)
        !          3878: {
        !          3879:   my ($num, $text) = @_;
        !          3880:   if ($num != 1) {
        !          3881:     $text .= "s";
        !          3882:   }
        !          3883:
        !          3884:   if ($num > 0) {
        !          3885:     return join (' ', $num, $text);
        !          3886:   } else {
        !          3887:     return "";
        !          3888:   }
1.1       jfieber  3889: }
                   3890:
1.1.1.37! simon    3891:
1.1.1.1   knu      3892: ##
                   3893: # print readable timestamp in terms of
                   3894: # '..time ago'
                   3895: # H. Zeller <zeller@think.de>
                   3896: ##
1.1.1.37! simon    3897: sub readableTime($$)
        !          3898: {
        !          3899:   my ($secs, $long) = @_;
        !          3900:
        !          3901:   # This function works correctly for time >= 2 seconds.
        !          3902:   return 'very little time' if ($secs < 2);
        !          3903:
        !          3904:   my %desc = (
        !          3905:               1        => 'second',
        !          3906:               60       => 'minute',
        !          3907:               3600     => 'hour',
        !          3908:               86400    => 'day',
        !          3909:               604800   => 'week',
        !          3910:               2628000  => 'month',
        !          3911:               31536000 => 'year'
        !          3912:              );
        !          3913:
        !          3914:   my @breaks = sort { $a <=> $b } keys %desc;
        !          3915:   my $i = 0;
        !          3916:
        !          3917:   while ($i <= $#breaks && $secs >= 2 * $breaks[$i]) {
        !          3918:     $i++;
        !          3919:   }
        !          3920:   $i--;
        !          3921:   my $break  = $breaks[$i];
        !          3922:   my $retval = plural_write(int($secs / $break), $desc{$break});
        !          3923:
        !          3924:   if ($long == 1 && $i > 0) {
        !          3925:     my $rest = $secs % $break;
        !          3926:     $i--;
        !          3927:     $break = $breaks[$i];
        !          3928:     my $resttime = plural_write(int($rest / $break), $desc{$break});
        !          3929:     if ($resttime) {
        !          3930:       $retval .= ", $resttime";
        !          3931:     }
        !          3932:   }
1.1.1.1   knu      3933:
1.1.1.37! simon    3934:   return $retval;
1.1.1.1   knu      3935: }
                   3936:
1.1.1.37! simon    3937:
1.1.1.1   knu      3938: #
1.1.1.37! simon    3939: # Returns a htmlified path where each directory is a link for faster
        !          3940: # navigation.  $clickLast controls whether the basename
        !          3941: # (last directory/file) is a link as well.  The passed in $pathname should
        !          3942: # *not* be URI escaped.
        !          3943: #
        !          3944: sub clickablePath($$)
        !          3945: {
        !          3946:   my ($pathname, $clickLast) = @_;
        !          3947:
        !          3948:   my $root = '[' . htmlquote($CVSROOTdescr{$cvstree} || $cvstree) . ']';
        !          3949:
        !          3950:   # This should never happen (see chooseCVSRoot()), but let's be sure...
        !          3951:   return $root if ($pathname eq '/');
        !          3952:
        !          3953:   my $retval =
        !          3954:     ' ' . &link($root, sprintf('%s/%s#dirlist', $scriptname, $query));
        !          3955:   my $wherepath = '';
        !          3956:   my ($lastslash) = $pathname =~ m|/$|;
        !          3957:
        !          3958:   foreach (split(m|/|, $pathname)) {
        !          3959:     $retval .= ' / ';
        !          3960:     $wherepath .= "/$_";
        !          3961:     my $last = "$wherepath/" eq "/$pathname" || $wherepath eq "/$pathname";
        !          3962:
        !          3963:     if ($clickLast || !$last) {
        !          3964:       $retval .= &link(htmlquote($_),
        !          3965:                        join ('',
        !          3966:                              $scriptname, uri_escape_path($wherepath),
        !          3967:                              (!$last || $lastslash ? '/' : ''), $query,
        !          3968:                              (!$last || $lastslash ? "#dirlist" : "")));
        !          3969:     } else {    # do not make a link to the current dir
        !          3970:       $retval .= htmlquote($_);
        !          3971:     }
        !          3972:   }
        !          3973:   return $retval;
        !          3974: }
        !          3975:
        !          3976:
        !          3977: sub chooseCVSRoot()
        !          3978: {
        !          3979:   print "<form method=\"get\" action=\"$scriptwhere\">\n<p>\n";
        !          3980:   if (2 <= @CVSROOT) {
        !          3981:     foreach my $k (keys %input) {
        !          3982:       printf("<input type=\"hidden\" name=\"%s\" value=\"%s\" />\n",
        !          3983:              htmlquote($k), htmlquote($input{$k}))
        !          3984:         if ($input{$k} && $k ne 'cvsroot');
        !          3985:     }
        !          3986:
        !          3987:     printf(<<EOF, $use_java_script ? ' onchange="this.form.submit()"' : '');
        !          3988: <label for="cvsroot" accesskey="C">CVS Root:
        !          3989: <select id="cvsroot" name="cvsroot"%s>
        !          3990: EOF
        !          3991:
        !          3992:     foreach my $k (@CVSROOT) {
        !          3993:       printf("<option value=\"%s\"%s>%s</option>\n",
        !          3994:              htmlquote($k),
        !          3995:              ($k eq $cvstree) ? ' selected="selected"' : '',
        !          3996:              htmlquote($CVSROOTdescr{$k} || $k));
        !          3997:     }
        !          3998:     print '</select></label>';
        !          3999:   } else {
        !          4000:
        !          4001:     # no choice -- but we need the form to select module/path,
        !          4002:     # at least for Netscape
        !          4003:     printf "CVS Root: <b>[%s]</b>",
        !          4004:       htmlquote($CVSROOTdescr{$cvstree} || $cvstree);
        !          4005:   }
        !          4006:
        !          4007:   print <<EOF;
        !          4008: <label for="mpath" accesskey="M">
        !          4009: Module path or alias:
        !          4010: <input type="text" id="mpath" name="path" value="" size="15" />
        !          4011: </label>
        !          4012: <input type="submit" value="Go" accesskey="O" />
        !          4013: </p>
        !          4014: </form>
        !          4015: EOF
        !          4016: }
        !          4017:
        !          4018:
        !          4019: sub chooseMirror()
        !          4020: {
        !          4021:   # This code comes from the original BSD-cvsweb
        !          4022:   # and may not be useful for your site; If you don't
        !          4023:   # set %MIRRORS this won't show up, anyway.
        !          4024:   scalar(%MIRRORS) or return;
        !          4025:
        !          4026:   # Should perhaps exclude the current site somehow...
        !          4027:   print "\n<p>\nThis CVSweb is mirrored in\n";
        !          4028:
        !          4029:   my @tmp = map(&link(htmlquote($_), $MIRRORS{$_}), sort keys %MIRRORS);
        !          4030:   my $tmp = pop (@tmp);
        !          4031:
        !          4032:   if (scalar(@tmp)) {
        !          4033:     print join (', ', @tmp), ' and ';
        !          4034:   }
        !          4035:
        !          4036:   print "$tmp.\n</p>\n";
        !          4037: }
        !          4038:
        !          4039:
        !          4040: sub fileSortCmp()
        !          4041: {
        !          4042:   (my $af = $a) =~ s/,v$//;
        !          4043:   (my $bf = $b) =~ s/,v$//;
        !          4044:   my ($rev1, $date1, $log1, $author1, $filename1) = @{$fileinfo{$af}}
        !          4045:     if (defined($fileinfo{$af}));
        !          4046:   my ($rev2, $date2, $log2, $author2, $filename2) = @{$fileinfo{$bf}}
        !          4047:     if (defined($fileinfo{$bf}));
        !          4048:
        !          4049:   my $comp = 0;
        !          4050:   if (defined($filename1) && defined($filename2) &&
        !          4051:       $af eq $filename1   && $bf eq $filename2)
        !          4052:   {
        !          4053:
        !          4054:     # Two files
        !          4055:     $comp = -revcmp($rev1, $rev2)             if ($byrev  && $rev1  && $rev2);
        !          4056:     $comp = ($date2   <=> $date1)             if ($bydate && $date1 && $date2);
        !          4057:     if ($input{ignorecase}) {
        !          4058:       $comp = (uc($log1)    cmp uc($log2))    if ($bylog && $log1 && $log2);
        !          4059:       $comp = (uc($author1) cmp uc($author2)) if ($byauthor &&
        !          4060:                                                   $author1 && $author2);
        !          4061:     } else {
        !          4062:       $comp = ($log1    cmp $log2)            if ($bylog && $log1 && $log2);
        !          4063:       $comp = ($author1 cmp $author2)         if ($byauthor &&
        !          4064:                                                   $author1 && $author2);
        !          4065:     }
        !          4066:   }
        !          4067:
        !          4068:   if ($comp == 0) {
        !          4069:
        !          4070:     # Directories first, then files under version control,
        !          4071:     # then other, "rogue" files.
        !          4072:     # Sort by filename if no other criteria available.
        !          4073:
        !          4074:     my $ad = (
        !          4075:       (-d "$fullname/$a")
        !          4076:       ? 'D'
        !          4077:       : (defined($fileinfo{$af}) ? 'F' : 'R')
        !          4078:     );
        !          4079:     my $bd = (
        !          4080:       (-d "$fullname/$b")
        !          4081:       ? 'D'
        !          4082:       : (defined($fileinfo{$bf}) ? 'F' : 'R')
        !          4083:     );
        !          4084:     (my $c = $a) =~ s|.*/||;
        !          4085:     (my $d = $b) =~ s|.*/||;
        !          4086:
        !          4087:     my ($l, $r) = ("$ad$c", "$bd$d");
        !          4088:     $comp = $input{ignorecase} ? (uc($l) cmp uc($r)) : ($l cmp $r);
        !          4089:
        !          4090:     # Parent dir is always first, then Attic.
        !          4091:     if ($comp != 0) {
        !          4092:       if ($l eq 'D..') {
        !          4093:         $comp = -1;
        !          4094:       } elsif ($r eq 'D..') {
        !          4095:         $comp = 1;
        !          4096:       } elsif ($l eq 'DAttic') {
        !          4097:         $comp = -1;
        !          4098:       } elsif ($r eq 'DAttic') {
        !          4099:         $comp = 1;
        !          4100:       }
        !          4101:     }
        !          4102:   }
        !          4103:   return $comp;
        !          4104: }
        !          4105:
        !          4106: #
        !          4107: # Returns a URL to download the selected revision.
        !          4108: # Expects the passed in URL to be URI escaped, relative, and without a query
        !          4109: # string.
        !          4110: #
        !          4111: sub download_url($$;$)
        !          4112: {
        !          4113:   my ($url, $revision, $mimetype) = @_;
        !          4114:   my @dots = $revision =~ /\./g;
        !          4115:   $revision =~ s/\b0\.(?=\d+$)// if (scalar(@dots) & 1);
        !          4116:
        !          4117:   if (!defined($mimetype) || $mimetype !~ CVSWEBMARKUP) {
        !          4118:     my $path = $where;
        !          4119:     $path =~ s|[^/]+$||;
        !          4120:     $url = "$scriptname/$CheckoutMagic/$path$url";
        !          4121:   }
        !          4122:   $url .= '?rev=' . uri_escape($revision);
        !          4123:   $url .= ';content-type=' . uri_escape($mimetype) if $mimetype;
        !          4124:
        !          4125:   return $url;
        !          4126: }
        !          4127:
        !          4128: #
        !          4129: # Returns a link to download the selected revision.
        !          4130: # Expects the passed in URL to be URI escaped, relative,
        !          4131: # and without a query string.
        !          4132: #
        !          4133: sub download_link($$$;$)
        !          4134: {
        !          4135:   my ($url, $revision, $textlink, $mimetype) = @_;
        !          4136:   return sprintf('<a href="%s" class="download-link">%s</a>',
        !          4137:                  download_url($url, $revision, $mimetype) . $barequery,
        !          4138:                  htmlquote($textlink));
        !          4139: }
        !          4140:
        !          4141: #
        !          4142: # Returns a URL to display the selected revision.
        !          4143: # Expects the passed in URL to be URI escaped, and without a query string.
        !          4144: #
        !          4145: sub display_url($$;$)
        !          4146: {
        !          4147:   my ($url, $revision, $mimetype) = @_;
        !          4148:   $url .= '?rev=' . uri_escape($revision);
        !          4149:   $url .= ';content-type=' . uri_escape($mimetype) if $mimetype;
        !          4150:   return $url;
        !          4151: }
        !          4152:
        !          4153: #
        !          4154: # Returns a link to display the selected revision.
        !          4155: # Expects the passed in URL to be URI escaped, and without a query string.
        !          4156: #
        !          4157: sub display_link($$;$$)
        !          4158: {
        !          4159:   my ($url, $revision, $textlink, $mtype) = @_;
        !          4160:   $textlink = $revision unless defined($textlink);
        !          4161:   return sprintf('<a href="%s" class="display-link">%s</a>',
        !          4162:                  display_url($url, $revision, $mtype) . $barequery,
        !          4163:                  htmlquote($textlink));
        !          4164: }
        !          4165:
        !          4166: #
        !          4167: # Expects the passed in URL to be URI escaped, and without a query string.
        !          4168: # The passed in link text should be already HTML escaped as appropriate.
        !          4169: #
        !          4170: sub graph_link($;$)
        !          4171: {
        !          4172:   my ($url, $text) = @_;
        !          4173:   $text ||= $graphicon;
        !          4174:   return sprintf('<a href="%s?graph=1%s">%s</a>', $url, $barequery, $text);
        !          4175: }
        !          4176:
        !          4177: #
        !          4178: # Returns a link to CVSHistory for the given directory and filename.
        !          4179: #
        !          4180: sub history_link($$;$)
        !          4181: {
        !          4182:   my ($dir, $file, $text) = @_;
        !          4183:   $dir  ||= '';
        !          4184:   $file ||= '';
        !          4185:   $text ||= 'History';
        !          4186:   return &link($text,
        !          4187:                sprintf('%s?cvsroot=%s;dsearch=%s;fsearch=%s;limit=1',
        !          4188:                        $cvshistory_url, uri_escape($input{cvsroot} || ''),
        !          4189:                        uri_escape($dir), uri_escape($file)));
1.1.1.1   knu      4190: }
                   4191:
                   4192: # Returns a Query string with the
                   4193: # specified parameter toggled
1.1.1.37! simon    4194: sub toggleQuery($;$)
        !          4195: {
        !          4196:   my ($toggle, $value) = @_;
        !          4197:
        !          4198:   my %vars = %input;
        !          4199:
        !          4200:   if (defined($value)) {
        !          4201:     $vars{$toggle} = $value;
        !          4202:   } else {
        !          4203:     $vars{$toggle} = $vars{$toggle} ? 0 : 1;
        !          4204:   }
        !          4205:
        !          4206:   # Build a new query of non-default paramenters
        !          4207:   my $newquery = "";
        !          4208:   foreach my $var (@stickyvars) {
        !          4209:     my ($value)   = defined($vars{$var})         ? $vars{$var}         : "";
        !          4210:     my ($default) = defined($DEFAULTVALUE{$var}) ? $DEFAULTVALUE{$var} : "";
        !          4211:
        !          4212:     if ($value ne $default) {
        !          4213:       $newquery .= ';' if ($newquery ne "");
        !          4214:       $newquery .= uri_escape($var) . '=' . uri_escape($value);
        !          4215:     }
        !          4216:   }
        !          4217:
        !          4218:   if ($newquery) {
        !          4219:     return '?' . $newquery;
        !          4220:   }
        !          4221:   return "";
        !          4222: }
        !          4223:
        !          4224: sub htmlquote($)
        !          4225: {
        !          4226:   local ($_) = @_;
        !          4227:   # Special Characters; RFC 1866
        !          4228:   s/&/&amp;/g;
        !          4229:   s/\"/&quot;/g;
        !          4230:   s/</&lt;/g;
        !          4231:   s/>/&gt;/g;
        !          4232:   return $_;
        !          4233: }
        !          4234:
        !          4235: sub htmlunquote($)
        !          4236: {
        !          4237:   local ($_) = @_;
        !          4238:   # Special Characters; RFC 1866
        !          4239:   s/&quot;/\"/g;
        !          4240:   s/&lt;/</g;
        !          4241:   s/&gt;/>/g;
        !          4242:   s/&amp;/&/g;
        !          4243:   return $_;
        !          4244: }
        !          4245:
        !          4246: sub uri_escape_path($)
        !          4247: {
        !          4248:   return join('/', map(uri_escape($_), split(m|/+|, shift, -1)));
        !          4249: }
        !          4250:
        !          4251: sub http_header(;$$)
        !          4252: {
        !          4253:   my ($content_type, $moddate) = @_;
        !          4254:   $content_type ||= 'text/html';
        !          4255:
        !          4256:   $content_type .= "; charset=$charset"
        !          4257:     if ($charset && $content_type =~ m,^text/,);
        !          4258:
        !          4259:   # Note that in the following, we explicitly join() and concatenate the
        !          4260:   # headers instead of printing them as an array.  This is because some
        !          4261:   # systems, eg. early versions of mod_perl 2 don't quite get it if the
        !          4262:   # last \r\n\r\n isn't included in the last "payload" header print().
        !          4263:
        !          4264:   my @headers = ();
        !          4265:   # TODO: ctime(3) from scalar gmtime() isn't HTTP compliant, see HTTP::Date.
        !          4266:   push(@headers, 'Last-Modified: ' . scalar gmtime($moddate) . ' GMT')
        !          4267:     if $moddate;
        !          4268:   push(@headers, 'Content-Type: ' . $content_type);
        !          4269:
        !          4270:   if ($allow_compress && $maycompress) {
        !          4271:     if (HAS_ZLIB
        !          4272:         || (defined($CMD{gzip}) && open(GZIP, "| $CMD{gzip} -1 -c")))
        !          4273:     {
        !          4274:
        !          4275:       push(@headers, 'Content-Encoding: x-gzip');
        !          4276:       push(@headers, 'Vary: Accept-Encoding');     # RFC 2616, 14.44
        !          4277:       print join("\r\n", @headers) . "\r\n\r\n";
        !          4278:
        !          4279:       $| = 1;
        !          4280:       $| = 0;                                      # Flush header output.
        !          4281:
        !          4282:       tie(*GZIP, __PACKAGE__, \*STDOUT) if HAS_ZLIB;
        !          4283:       select(GZIP);
        !          4284:       $gzip_open = 1;
        !          4285:
        !          4286:     } else {
        !          4287:
        !          4288:       print join("\r\n", @headers) . "\r\n\r\n";
        !          4289:       printf
        !          4290:         '<span style="font-size: smaller">Unable to find gzip binary in the <b>$command_path</b> (<code>%s</code>) to compress output</span><br />',
        !          4291:           htmlquote(join(':', @command_path));
        !          4292:     }
        !          4293:
        !          4294:   } else {
        !          4295:     print join("\r\n", @headers) . "\r\n\r\n";
        !          4296:   }
        !          4297: }
        !          4298:
        !          4299:
        !          4300: sub html_header($;$)
        !          4301: {
        !          4302:   my ($title, $moddate) = @_;
        !          4303:   $title  = htmlquote($title);
        !          4304:   my $l   = $logo || '';
        !          4305:   my $css = $CSS || '';
        !          4306:   http_header('text/html', $moddate);
        !          4307:   print <<EOH;
1.1.1.30  knu      4308: $HTML_DOCTYPE
1.1.1.1   knu      4309: <html>
1.1.1.13  knu      4310: <head>
1.1.1.1   knu      4311: <title>$title</title>
1.1.1.37! simon    4312: $HTML_META$css</head>
        !          4313: <body>
        !          4314: $l <h1>$title</h1>
1.1.1.1   knu      4315: EOH
                   4316: }
                   4317:
1.1.1.37! simon    4318: sub html_footer()
        !          4319: {
        !          4320:   print "<hr />\n<address>$address</address>\n" if $address;
        !          4321:   print "</body>\n</html>\n";
1.1.1.1   knu      4322: }
                   4323:
1.1.1.37! simon    4324: sub link_tags($)
        !          4325: {
        !          4326:   my ($tags) = @_;
1.1.1.28  knu      4327:
1.1.1.37! simon    4328:   (my $filename = $where) =~ s|^.*/||;
        !          4329:   my $fileurl = './' . uri_escape($filename);
1.1.1.28  knu      4330:
1.1.1.37! simon    4331:   my $ret = "";
        !          4332:   foreach my $sym (split(", ", $tags)) {
        !          4333:     $ret .= ",\n" if ($ret ne "");
        !          4334:     $ret .= &link(htmlquote($sym),
        !          4335:                   $fileurl . toggleQuery('only_with_tag', $sym));
        !          4336:   }
        !          4337:   return $ret;
1.1.1.1   knu      4338: }
                   4339:
1.1.1.37! simon    4340:
1.1.1.1   knu      4341: #
1.1.1.37! simon    4342: # See if a file/dir is listed in the config file's @ForbiddenFiles list.
        !          4343: # Takes a full file system path or one relative to $cvsroot, and strips the
        !          4344: # trailing ",v" if present, then compares.  Returns 1 if forbidden, else 0.
1.1.1.1   knu      4345: #
1.1.1.37! simon    4346: sub forbidden($)
        !          4347: {
        !          4348:   (my $path = canonpath(shift)) =~ s/,v$//;
        !          4349:   $path =~ s|^$cvsroot/+||;
        !          4350:   for my $forbidden_re (@ForbiddenFiles) {
        !          4351:     return 1 if ($path =~ $forbidden_re);
        !          4352:   }
        !          4353:   return 0;
        !          4354: }
1.1.1.2   knu      4355:
1.1.1.37! simon    4356:
        !          4357: #
        !          4358: # Starts a process using IPC::Run.  All arguments are passed to
        !          4359: # IPC::Run::start() as-is.  Returns an array ($harness, $error) where
        !          4360: # $harness is from IPC::Run if start() succeeds, undef otherwise.  In case
        !          4361: # of an error, $error contains the error message.
        !          4362: #
        !          4363: sub startproc(@)
        !          4364: {
        !          4365:   my $h = my $err = undef;
        !          4366:   eval {
        !          4367:     local $SIG{__DIE__};
        !          4368:     $h = IPC::Run::start(@_) or die("return code: $?");
        !          4369:   };
        !          4370:   if ($@) {
        !          4371:     $h->finish() if $h;
        !          4372:     $h = undef;
        !          4373:     $err = "'@{$_[0]}' failed: $@";
        !          4374:   }
        !          4375:   return ($h, $err);
1.1.1.28  knu      4376: }
1.1.1.1   knu      4377:
1.1.1.37! simon    4378: #
        !          4379: # Runs a process using IPC::Run.  All arguments are passed to
        !          4380: # IPC::Run::run() as-is.  Returns an array ($exitcode, $errormsg).
        !          4381: #
        !          4382: sub runproc(@)
        !          4383: {
        !          4384:   eval {
        !          4385:     local $SIG{__DIE__};
        !          4386:     IPC::Run::run(@_);
        !          4387:   };
        !          4388:   my $exitcode = $? >> 8;
        !          4389:   my $errormsg  = undef;
        !          4390:   if ($@) {
        !          4391:     $exitcode ||= -1;
        !          4392:     $errormsg = "'@{$_[0]}' failed: $@";
        !          4393:   }
        !          4394:   return ($exitcode, $errormsg);
1.1.1.7   knu      4395: }
                   4396:
1.1.1.37! simon    4397: #
        !          4398: # Check out a file to a temporary file.
        !          4399: #
        !          4400: sub checkout_to_temp($$$)
        !          4401: {
        !          4402:   my ($cvsroot, $cvsname, $rev) = @_;
        !          4403:
        !          4404:   # Pipe given cvs file into a temporary place.
        !          4405:   my ($temp_fh, $temp_fn) = tempfile('.cvsweb.XXXXXXXX', DIR => tmpdir());
        !          4406:
        !          4407:   my @cmd = ($CMD{cvs}, @cvs_options, '-Qd', $cvsroot,
        !          4408:              'co', '-p', "-r$rev", $cvsname);
        !          4409:
        !          4410:   local (*DIFF_OUT);
        !          4411:   my ($h, $err) = startproc(\@cmd, \"", '>pipe', \*DIFF_OUT);
        !          4412:   if ($h) {
        !          4413:     local $/ = undef;
        !          4414:     print $temp_fh <DIFF_OUT>;
        !          4415:     $h->finish();
        !          4416:     close($temp_fh);
        !          4417:   } else {
        !          4418:     close($temp_fh);
        !          4419:     unlink($temp_fn);
        !          4420:     fatal('500 Internal Error',
        !          4421:           'Checkout failure (exit status %s), output: <pre>%s</pre>',
        !          4422:           $? >> 8 || -1, $err);
        !          4423:   }
        !          4424:
        !          4425:   return $temp_fn;
        !          4426: }
1.1.1.7   knu      4427:
1.1.1.37! simon    4428: #
        !          4429: # Close the GZIP handle, and remove the tie.
        !          4430: #
        !          4431: sub gzipclose
        !          4432: {
        !          4433:   if ($gzip_open) {
        !          4434:     select(STDOUT);
        !          4435:     close(GZIP);
        !          4436:     untie *GZIP;
        !          4437:     $gzip_open = 0;
        !          4438:   }
1.1.1.6   knu      4439: }
                   4440:
                   4441: # implement a gzipped file handle via the Compress:Zlib compression
                   4442: # library.
                   4443:
                   4444: sub MAGIC1() { 0x1f }
                   4445: sub MAGIC2() { 0x8b }
1.1.1.28  knu      4446: sub OSCODE() { 3 }
1.1.1.6   knu      4447:
1.1.1.37! simon    4448: sub TIEHANDLE
        !          4449: {
        !          4450:   my ($class, $out) = @_;
        !          4451:   my ($d) = Compress::Zlib::deflateInit(
        !          4452:     -Level      => Compress::Zlib::Z_BEST_COMPRESSION(),
        !          4453:     -WindowBits => -Compress::Zlib::MAX_WBITS()
        !          4454:     )
        !          4455:     or return undef;
        !          4456:   my ($o) = { handle => $out,
        !          4457:               dh     => $d,
        !          4458:               crc    => 0,
        !          4459:               len    => 0,
        !          4460:             };
        !          4461:   my ($header) = pack("c10",
        !          4462:                       MAGIC1, MAGIC2, Compress::Zlib::Z_DEFLATED(),
        !          4463:                       0, 0, 0, 0, 0, 0, OSCODE);
        !          4464:   print {$o->{handle}} $header;
        !          4465:   return bless($o, $class);
        !          4466: }
        !          4467:
        !          4468: sub PRINT
        !          4469: {
        !          4470:   my ($o)   = shift;
        !          4471:   my ($buf) = join (defined($,) ? $, : "", @_);
        !          4472:   my ($len) = length($buf);
        !          4473:   my ($compressed, $status) = $o->{dh}->deflate($buf);
        !          4474:   print {$o->{handle}} $compressed if defined($compressed);
        !          4475:   $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});
        !          4476:   $o->{len} += $len;
        !          4477:   return $len;
        !          4478: }
        !          4479:
        !          4480: sub PRINTF
        !          4481: {
        !          4482:   my ($o)   = shift;
        !          4483:   my ($fmt) = shift;
        !          4484:   my ($buf) = sprintf($fmt, @_);
        !          4485:   my ($len) = length($buf);
        !          4486:   my ($compressed, $status) = $o->{dh}->deflate($buf);
        !          4487:   print {$o->{handle}} $compressed if defined($compressed);
        !          4488:   $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc});
        !          4489:   $o->{len} += $len;
        !          4490:   return $len;
        !          4491: }
        !          4492:
        !          4493: sub WRITE
        !          4494: {
        !          4495:   my ($o, $buf, $len, $off) = @_;
        !          4496:   my ($compressed, $status) = $o->{dh}->deflate(substr($buf, 0, $len));
        !          4497:   print {$o->{handle}} $compressed if defined($compressed);
        !          4498:   $o->{crc} = Compress::Zlib::crc32(substr($buf, 0, $len), $o->{crc});
        !          4499:   $o->{len} += $len;
        !          4500:   return $len;
1.1       jfieber  4501: }
1.1.1.37! simon    4502:
        !          4503: sub CLOSE
        !          4504: {
        !          4505:   my ($o) = @_;
        !          4506:   return if !defined($o->{dh});
        !          4507:   my ($buf) = $o->{dh}->flush();
        !          4508:   $buf .= pack("V V", $o->{crc}, $o->{len});
        !          4509:   print {$o->{handle}} $buf;
        !          4510:   undef $o->{dh};
        !          4511: }
        !          4512:
        !          4513: sub DESTROY
        !          4514: {
        !          4515:   my ($o) = @_;
        !          4516:   CLOSE($o);
        !          4517: }
        !          4518:
        !          4519: # Local variables:
        !          4520: # indent-tabs-mode: nil
        !          4521: # cperl-indent-level: 2
        !          4522: # End:

CVSweb