#!/usr/bin/perl -T # # cvsweb - a CGI interface to CVS trees. # # Written in their spare time by # Bill Fenner (original work) # extended by Henner Zeller , # Henrik Nordstrom # Ken Coar # Dick Balaska # Akinori MUSHA # Jens-Uwe Mager # Ville Skyttä # Vassilii Khachaturov # # Based on: # * Bill Fenners cvsweb.cgi revision 1.28 available from: # http://www.FreeBSD.org/cgi/cvsweb.cgi/www/en/cgi/cvsweb.cgi # # Copyright (c) 1996-1998 Bill Fenner # (c) 1998-1999 Henner Zeller # (c) 1999 Henrik Nordstrom # (c) 2000-2002 Akinori MUSHA # (c) 2002-2003 Ville Skyttä # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # 1. Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF # SUCH DAMAGE. # # $FreeBSD$ # $Id: cvsweb.cgi,v 3.207 2003/10/02 19:20:16 scop Exp $ # $Idaemons: /home/cvs/cvsweb/cvsweb.cgi,v 3.84 2001/10/07 20:50:10 knu Exp $ # ### require 5.006; use strict; use warnings; use filetest qw(access); use vars qw ( $VERSION $config $allow_version_select @CVSrepositories @CVSROOT %CVSROOT %CVSROOTdescr %MIRRORS %DEFAULTVALUE %ICONS %MTYPES @DIFFTYPES %DIFFTYPES @LOGSORTKEYS %LOGSORTKEYS %alltags %fileinfo %tags @branchnames %nameprinted %symrev %revsym @allrevisions %date %author @revdisplayorder @revisions %state %difflines %log %branchpoint @revorder $keywordsubstitution $prcgi @prcategories $re_prcategories $prkeyword $re_prkeyword $mancgi $checkoutMagic $doCheckout $scriptname $scriptwhere $where $pathinfo $Browser $nofilelinks $maycompress @stickyvars %funcline_regexp $is_links $is_lynx $is_w3m $is_msie $is_mozilla3 $is_textbased %input $query $barequery $sortby $bydate $byrev $byauthor $bylog $byfile $defaultDiffType $logsort $cvstree $cvsroot $charset $output_filter $command_path %CMD $allow_compress $backicon $diricon $fileicon $graphicon $fullname $newname $cvstreedefault $logo $defaulttitle $address $binfileicon $long_intro $short_instruction $shortLogLen $show_author $tablepadding $hr_breakable $showfunc $hr_ignwhite $hr_ignkeysubst $inputTextSize $mime_types $allow_annotate $allow_markup $allow_log_extra $allow_dir_extra $allow_source_extra $allow_cvsgraph $cvsgraph_config $use_java_script $open_extern_window $extern_window_width $extern_window_height $edit_option_form $show_subdir_lastmod $show_log_in_markup $preformat_in_markup $tabstop $state $annTable $sel $curbranch @HideModules @ForbiddenFiles $module $use_descriptions %descriptions @mytz $dwhere $use_moddate $has_zlib $gzip_open $file_list_len $allow_tar @tar_options @gzip_options @zip_options @cvs_options @annotate_options @rcsdiff_options $LOG_FILESEPARATOR $LOG_REVSEPARATOR $HTML_DOCTYPE $HTML_META $cssurl $CSS $CvsWebMarkupRE $allow_enscript @enscript_options %enscript_types $MimeTypes $Have_Ediff ); # TODO: # Maybe "use filetest 'access'" on perl >= 5.6 for better -X checks. #($] >= 5.006) and eval "use filetest 'access'"; use Cwd qw(abs_path cwd); use File::Basename qw(dirname); use File::Path qw(rmtree); use File::Spec::Functions qw(catdir catfile curdir devnull rootdir tmpdir updir); use File::Temp qw(tempdir); use IPC::Run qw(start finish timeout); use Time::Local qw(timegm); use URI::Escape qw(uri_escape uri_unescape); use constant VALID_PATH => qr/^([[:^cntrl:]]+)$/o; use constant VALID_TAG1 => qr/^([a-zA-Z][[:graph:]]*)$/o; use constant VALID_TAG2 => qr/^([^\$,.:;@]+)$/o; # ----------------------------------------------------------------------------- # All global initialization that can be done in compile time should go to # the BEGIN block. Persistent environments, such as mod_perl, will benefit # from this. BEGIN { $VERSION = '3.0-dev'; $HTML_DOCTYPE = ''; $HTML_META = < EOM # Check if the zlib C library interface is installed, and if yes, # we can avoid using the extra gzip process. eval { require Compress::Zlib; }; $has_zlib = !$@; # Use MIME::Types for MIME type lookups if it's available. eval { require MIME::Types; $MimeTypes = MIME::Types->new(); }; $MimeTypes = undef if $@; # Use String::Ediff for enhanced human readable diffs if available. eval { require String::Ediff; }; $Have_Ediff = !$@; $LOG_FILESEPARATOR = qr/^={77}$/o; $LOG_REVSEPARATOR = qr/^-{28}$/o; $CvsWebMarkupRE = qr/^text\/(x-cvsweb|vnd\.viewcvs)-markup$/io; } # ----------------------------------------------------------------------------- sub printDiffSelect($); sub printDiffSelectStickyVars(); sub printDiffLinks($$); sub printLogSortSelect($); sub findLastModifiedSubdirs(@); sub htmlify_sub(&$); sub htmlify($;$); sub spacedHtmlText($;$); sub link($$); sub revcmp($$); sub fatal($$@); sub redirect($); sub safeglob($); sub search_path($); sub getMimeType($;$); sub head($;$); sub scan_directives(@); sub openOutputFilter(); sub doAnnotate($); sub doCheckout($$); sub doEnscript($$$); sub doGraph(); sub doGraphView(); sub cvswebMarkup($$$;$); sub viewable($); sub doDiff($$$$$$); sub getDirLogs($$@); sub readLog($;$); sub printLog($;$$); sub doLog($); sub flush_diff_rows($$$$); sub human_readable_diff($$); sub navigateHeader($$$$$;$); sub plural_write($$); sub readableTime($$); sub clickablePath($$); sub chooseCVSRoot(); sub chooseMirror(); sub fileSortCmp(); sub download_url($$;$); sub download_link($$$;$); sub graph_link($;$); sub toggleQuery($;$); sub urlencode($); sub htmlquote($); sub htmlunquote($); sub hrefquote($); sub http_header(;$$); sub html_header($;$); sub html_footer(); sub link_tags($); sub forbidden_file($); sub forbidden_module($); sub startproc(@); ##### Start of Configuration Area ######## # Get rid of unsafe environment vars. Don't do this in BEGIN... # This will fail with mod_perl 1.99_X for X < 08. # http://marc.theaimsgroup.com/?l=apache-modperl-dev&m=103473352222344 delete(@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}); my ($mydir) = (dirname($0) =~ /(.*)/); # untaint # == EDIT this == # Locations to search for user configuration, in order: for (catfile($mydir, 'cvsweb.conf'), '/usr/local/etc/cvsweb/cvsweb.conf') { if (-r $_) { $config = $_; last; } } undef $mydir; # == Configuration defaults == # Defaults for configuration variables that shouldn't need # to be configured.. $allow_version_select = 1; $allow_log_extra = 1; ##### End of Configuration Area ######## ######## Configuration variables ######### # These are defined to allow checking with perl -cw @CVSrepositories = @CVSROOT = %CVSROOT = %MIRRORS = %DEFAULTVALUE = %ICONS = %MTYPES = %tags = %alltags = %fileinfo = (); $cvstreedefault = $logo = $defaulttitle = $address = $long_intro = $short_instruction = $shortLogLen = $show_author = $tablepadding = $hr_breakable = $showfunc = $hr_ignwhite = $hr_ignkeysubst = $inputTextSize = $mime_types = $allow_annotate = $allow_markup = $use_java_script = $open_extern_window = $extern_window_width = $extern_window_height = $edit_option_form = $show_subdir_lastmod = $show_log_in_markup = $tabstop = $use_moddate = $gzip_open = undef; @DIFFTYPES = qw(h H u c s); @DIFFTYPES{@DIFFTYPES} = ( { 'descr' => 'colored', 'opts' => ['-u'], 'colored' => 1, }, { 'descr' => 'long colored', 'opts' => ['--unified=15'], 'colored' => 1, }, { 'descr' => 'unified', 'opts' => ['-u'], 'colored' => 0, }, { 'descr' => 'context', 'opts' => ['-c'], 'colored' => 0, }, { 'descr' => 'side by side', 'opts' => ['--side-by-side', '--width=164'], 'colored' => 0, }, ); @LOGSORTKEYS = qw(cvs date rev); @LOGSORTKEYS{@LOGSORTKEYS} = ( {'descr' => 'Not sorted',}, {'descr' => 'Commit date',}, {'descr' => 'Revision',}, ); ##### End of configuration variables ##### if ($ENV{PATH_INFO}) { ($pathinfo) = ($ENV{PATH_INFO} =~ VALID_PATH) or fatal('500 Internal Error', 'Illegal PATH_INFO in environment: %s', $ENV{PATH_INFO}); } if ($ENV{SCRIPT_NAME}) { ($scriptname) = ($ENV{SCRIPT_NAME} =~ VALID_PATH) or fatal('500 Internal Error', 'Illegal SCRIPT_NAME in environment: %s', $ENV{SCRIPT_NAME}); } $pathinfo = '' unless defined($pathinfo); $scriptname = '' unless defined($scriptname); $checkoutMagic = "~checkout~"; $where = $pathinfo; $doCheckout = ($where =~ m|^/$checkoutMagic/|); $where =~ s|^/$checkoutMagic/|/|; $where =~ s|^/||; $scriptname =~ s|^/*|/|; # Let's workaround thttpd's stupidity.. if ($scriptname =~ m|/$|) { $pathinfo .= '/'; my $re = quotemeta $pathinfo; $scriptname =~ s/$re$//; } $scriptwhere = $scriptname; $scriptwhere .= '/' . urlencode($where); $where = '/' if ($where eq ''); # In text-based browsers, it's very annoying to have two links per file; # skip linking the image for them. $Browser = $ENV{HTTP_USER_AGENT} || ''; $is_links = ($Browser =~ m`^E?Links `); $is_lynx = ($Browser =~ m`^Lynx/`i); $is_w3m = ($Browser =~ m`^w3m/`i); $is_msie = ($Browser =~ m`MSIE`); $is_mozilla3 = ($Browser =~ m`^Mozilla/[3-9]`); $is_textbased = ($is_links || $is_lynx || $is_w3m); $nofilelinks = $is_textbased; # newer browsers accept gzip content encoding # and state this in a header # (netscape did always but didn't state it) # It has been reported that these # braindamaged MS-Internet Exploders claim that they # accept gzip .. but don't in fact and # display garbage then :-/ # Turn off gzip if running under mod_perl and no zlib is available, # piping does not work as expected inside the server. $maycompress = ( ((defined($ENV{HTTP_ACCEPT_ENCODING}) && $ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/) || $is_mozilla3) && !$is_msie && !(defined($ENV{MOD_PERL}) && !$has_zlib) ); # Variables that will be sticky in all constructed links/query strings. @stickyvars = qw(cvsroot hideattic ignorecase sortby logsort f only_with_tag ln); if (-f $config) { do "$config" or fatal("500 Internal Error", 'Error in loading configuration file: %s

%s
', $config, $@); } else { fatal("500 Internal Error", 'Configuration not found. Set the variable $config in cvsweb.cgi to your cvsweb.conf configuration file first.'); } # Try to find a readable dir where we can cd into. Some abs_path() # implementations as well as various cvs operations require such a dir to # work properly. { local $^W = 0; if (!-r cwd()) { for my $dir (tmpdir(), rootdir()) { last if (-r $dir && chdir($dir)); } } } $CSS = $cssurl ? sprintf("\n", htmlquote($cssurl)) : ''; # --- input parameters my %query = (); if (defined($ENV{QUERY_STRING})) { for my $p (split(/[;&]+/, $ENV{QUERY_STRING})) { next unless $p; $p =~ y/+/ /; my ($key, $val) = split(/=/, $p, 2); next unless defined($key); $val = 1 unless defined($val); ($key = uri_unescape($key)) =~ /[[:graph:]]/o or next; ($val = uri_unescape($val)) =~ /[[:graph:]]/o or next; $query{$key} = $val; } } undef %input; my $t; for my $p (qw(graph hideattic hidecvsroot hidenonreadable ignorecase ln copt makeimage options tarball)) { $t = $query{$p}; if (defined($t)) { ($input{$p}) = ($t =~ /^([01]|on)$/o) or fatal('500 Internal Error', 'Invalid boolean value: %s=%s', $p, $t); } } for my $p (qw(annotate r1 r2 rev tr1 tr2)) { $t = $query{$p}; if (defined($t)) { if (($p eq 'r1' || $p eq 'r2') && $t eq 'text') { # Special case for the "Use text field" option in the log view diff form. $input{$p} = $t; next; } my ($rev, $tag) = split(/:/, $t, 2); ($input{$p}) = ($rev =~ /^(\d+(?:\.\d+)+)$/o) or fatal('500 Internal Error', 'Invalid revision: %s=%s', $p, $t); if (defined($tag)) { ($tag) = ($tag =~ VALID_TAG1) or fatal('500 Internal Error', 'Invalid revision: %s=%s', $p, $t); ($tag) = ($tag =~ VALID_TAG2) or fatal('500 Internal Error', 'Invalid revision: %s=%s', $p, $t); $input{$p} .= ':' . $tag; } } } $t = defined($query{only_with_tag}) ? $query{only_with_tag} : $query{only_on_branch}; # Backwards compatibility. if (defined($t)) { ($input{cvsroot}) = ($t =~ VALID_TAG1) or fatal('500 Internal Error', 'Invalid tag/branch name: %s', $t); ($input{cvsroot}) = ($t =~ VALID_TAG2) or fatal('500 Internal Error', 'Invalid tag/branch name: %s', $t); } $t = $query{logsort}; if (defined($t)) { ($input{logsort}) = ($t =~ /^(cvs|date|rev)$/o) or fatal('500 Internal Error', 'Unsupported log sort key: %s', $t); } $t = $query{f}; if (defined($t)) { ($input{f}) = ($t =~ /^([hH]|[ucs]c?)$/o) or fatal('500 Internal Error', 'Unsupported diff format: %s', $t); } $t = $query{sortby}; if (defined($t)) { ($input{sortby}) = ($t =~ /^(file|date|rev|author|log)$/o) or fatal('500 Internal Error', 'Unsupported dir sort key: %s', $t); } $t = $query{'content-type'}; if (defined($t)) { ($input{'content-type'}) = ($t =~ /^([-0-9A-Za-z]+\/[-0-9A-Za-z\.]+)$/o) or fatal('500 Internal Error', 'Unsupported content type: %s', $t); } $t = $query{cvsroot}; if (defined($t)) { ($input{cvsroot}) = ($t =~ /^([[:print:]]+)$/o) or fatal('500 Internal Error', 'Invalid symbolic CVS root name: %s', $t); } $t = $query{path}; if (defined($t)) { ($input{path}) = ($t =~ VALID_PATH) or fatal('500 Internal Error', 'Invalid path: %s', $t); } undef($t); undef(%query); # --- end input parameters # # CVS roots # my $rootfound = 0; for (my $i = 0; $i < scalar(@CVSrepositories); $i += 2) { my $key = $CVSrepositories[$i]; my ($descr, $cvsroot) = @{$CVSrepositories[$i+1]}; unless (-d $cvsroot) { warn("Root '$cvsroot' defined in \@CVSrepositories is not a directory, " . 'entry ignored'); next; } $rootfound ||= 1; $cvstreedefault = $key unless defined($cvstreedefault); $CVSROOTdescr{$key} = $descr; $CVSROOT{$key} = $cvsroot; push(@CVSROOT, $key); } unless ($rootfound) { fatal('500 Internal Error', 'No valid CVS roots found! See @CVSrepositories in ' . 'your configuration file (%s).', $config); } undef $rootfound; # # Default CVS root # if (!defined($CVSROOT{$cvstreedefault})) { fatal("500 Internal Error", '$cvstreedefault points to a repository (%s) not ' . 'defined in @CVSrepositories in your configuration ' . 'file (%s).', $cvstreedefault, $config); } $DEFAULTVALUE{'cvsroot'} = $cvstreedefault; while (my ($key, $defval) = each %DEFAULTVALUE) { # Replace not given parameters with defaults. next unless (defined($defval) && $defval =~ /\S/ && !defined($input{$key})); # Empty checkboxes in forms return nothing, so we define a helper variable # in these forms (copt) which indicates that we just set parameters with a # checkbox. if ($input{copt}) { # 'copt' is set -> the result of empty input checkbox # -> set to zero (disable) if default is a boolean (0|1). $input{$key} = 0 if ($defval eq '0' || $defval eq '1'); } else { # 'copt' isn't set --> empty input is not the result # of empty input checkbox --> set default. $input{$key} = $defval; } } $barequery = ""; my @barequery; foreach (@stickyvars) { # construct a query string with the sticky non default parameters set if (defined($input{$_}) && !(defined($DEFAULTVALUE{$_}) && $input{$_} eq $DEFAULTVALUE{$_})) { push(@barequery, join('=', uri_escape($_), uri_escape($input{$_}))); } } if ($allow_enscript) { push(@DIFFTYPES, qw(uc cc sc)); @DIFFTYPES{qw(uc cc sc)} = ( { 'descr' => 'unified, colored', 'opts' => ['-u'], 'colored' => 0, }, { 'descr' => 'context, colored', 'opts' => ['-c'], 'colored' => 0, }, { 'descr' => 'side by side, colored', 'opts' => ['--side-by-side', '--width=164'], 'colored' => 0, }, ); } else { # No Enscript -> respect difftype, but don't offer colorization. if ($input{f} && $input{f} =~ /^([ucs])c$/) { $input{f} = $1; } } # is there any query ? if (@barequery) { $barequery = join (';', @barequery); $query = "?$barequery"; $barequery = ";$barequery"; } else { $query = ""; } undef @barequery; if (defined($input{'path'})) { redirect("$scriptname/$input{path}$query"); } # get actual parameters { my $sortby = $input{sortby} || 'file'; $bydate = 0; $byrev = 0; $byauthor = 0; $bylog = 0; $byfile = 0; if ($sortby eq 'date') { $bydate = 1; } elsif ($sortby eq 'rev') { $byrev = 1; } elsif ($sortby eq 'author') { $byauthor = 1; } elsif ($sortby eq 'log') { $bylog = 1; } else { $byfile = 1; } } $defaultDiffType = $input{'f'}; $logsort = $input{'logsort'}; # alternate CVS-Tree, configured in cvsweb.conf if ($input{'cvsroot'} && $CVSROOT{$input{'cvsroot'}}) { $cvstree = $input{'cvsroot'}; } else { $cvstree = $cvstreedefault; } $cvsroot = $CVSROOT{$cvstree}; # create icons out of description foreach my $k (keys %ICONS) { my ($itxt, $ipath, $iwidth, $iheight) = @{$ICONS{$k}}; no strict 'refs'; if ($ipath) { ${"${k}icon"} = sprintf('%s', hrefquote($ipath), htmlquote($itxt), $iwidth, $iheight); } else { ${"${k}icon"} = $itxt; } } my $config_cvstree = "$config-$cvstree"; # Do some special configuration for cvstrees if (-f $config_cvstree) { do "$config_cvstree" or fatal("500 Internal Error", 'Error in loading configuration file: %s

%s
', $config_cvstree, $@); } undef $config_cvstree; $re_prcategories = '(?:' . join ('|', @prcategories) . ')' if @prcategories; $re_prkeyword = quotemeta($prkeyword) if defined($prkeyword); $prcgi .= '%s' if defined($prcgi) && $prcgi !~ /%s/; $fullname = "$cvsroot/$where"; my $rewrite = 0; if ($pathinfo =~ m|//|) { $pathinfo =~ y|/|/|s; $rewrite = 1; } if (-d $fullname) { if ($pathinfo !~ m|/$|) { $pathinfo .= '/'; $rewrite = 1; } } else { if ($pathinfo =~ m|/$|) { chop $pathinfo; $rewrite = 1; } } if ($rewrite) { redirect($scriptname . urlencode($pathinfo) . $query); } undef $rewrite; if (!-d $cvsroot) { fatal("500 Internal Error", '$CVSROOT not found!

The server on which the CVS tree lives is probably down. Please try again in a few minutes.'); } # # See if the module is in our forbidden list. # $where =~ m:([^/]*):; $module = $1; if ($module && &forbidden_module($module)) { fatal("403 Forbidden", 'Access to %s forbidden.', $where); } # # Handle tarball downloads before any headers are output. # if ($input{tarball}) { fatal('403 Forbidden', 'Downloading tarballs is prohibited.') unless $allow_tar; my ($module) = ($where =~ m,^/?(.*),); # untaint $module =~ s,/([^/]*)$,,; my ($ext) = ($1 =~ /(\.t(?:ar\.)?gz|\.zip)$/); my ($basedir) = ($module =~ m,([^/]+)$,); if ($basedir eq '' || $module eq '') { fatal('500 Internal Error', 'You cannot download the top level directory.'); } my $istar = ($ext eq '.tar.gz' || $ext eq '.tgz'); if ($istar) { fatal('500 Internal Error', 'tar command not found.') unless $CMD{tar}; fatal('500 Internal Error', 'gzip command not found.') unless $CMD{gzip}; } my $iszip = ($ext eq '.zip'); if ($iszip && !$CMD{zip}) { fatal('500 Internal Error', 'zip command not found.'); } my $tmpexportdir; eval { local $SIG{__DIE__}; # Don't use the CLEANUP argument to tempdir() here, since we might be under # mod_perl (the process runs for a long time), unlink explicitly later. $tmpexportdir = tempdir('.cvsweb.XXXXXXXX', TMPDIR => 1); }; if ($@) { fatal('500 Internal Error', 'Unable to make temporary directory: %s', $@); } if (!chdir($tmpexportdir)) { fatal('500 Internal Error', "Can't cd to temporary directory %s: %s", $tmpexportdir, $!); } my @fatal; my $tag = $input{only_with_tag} || 'HEAD'; $tag = 'HEAD' if ($tag eq 'MAIN'); if (system($CMD{cvs}, @cvs_options, '-Qd', $cvsroot, 'export', '-r', $tag, $module)) { @fatal = ('500 Internal Error', 'cvs export failure: %s: %s', $!, $module); } elsif ($istar || $iszip) { $| = 1; # Essential to get the buffering right. local (*TAR_OUT); my (@cmd, $ctype); if ($istar) { my @tar = ($CMD{tar}, @tar_options, '-cf', '-', $basedir); my @gzip = ($CMD{gzip}, @gzip_options, '-c'); push(@cmd, \@tar, '|', \@gzip); $ctype = 'application/x-gzip'; } elsif ($iszip) { my @zip = ($CMD{zip}, @zip_options, '-r', '-', $basedir); push(@cmd, \@zip, \''); $ctype = 'application/zip'; } push(@cmd, '>pipe', \*TAR_OUT, timeout(30)); my ($h, $err) = startproc(@cmd); if ($h) { print "Content-Type: $ctype\r\n\r\n"; local $/ = undef; print ; finish($h); } else { @fatal = ('500 Internal Error', $err); } } else { @fatal = ('500 Internal Error', 'unsupported file type'); } # Clean up. rmtree($tmpexportdir); &fatal(@fatal) if @fatal; exit; } ############################## # View a directory ############################### if (-d $fullname) { my $dh = do { local (*DH); }; opendir($dh, $fullname) or fatal("404 Not Found", '%s: %s', $where, $!); my @dir = readdir($dh); closedir($dh); my @subLevelFiles = findLastModifiedSubdirs(@dir) if ($show_subdir_lastmod); my @unreadable = getDirLogs($cvsroot, $where, @subLevelFiles); if ($where eq '/') { html_header($defaulttitle); $long_intro =~ s/!!CVSROOTdescr!!/$CVSROOTdescr{$cvstree}/g; print $long_intro; } else { html_header($where); print $short_instruction; } if ($use_descriptions && open(DESC, '<', catfile($cvsroot, 'CVSROOT', 'descriptions'))) { while () { chomp; my ($dir, $description) = /(\S+)\s+(.*)/; $descriptions{$dir} = $description; } close(DESC); } print "

\n"; # give direct access to dirs if ($where eq '/') { chooseMirror(); chooseCVSRoot(); } else { print "

Current directory: ", &clickablePath($where, 0), "

\n"; print "

Current tag: ", htmlquote($input{only_with_tag}), "

\n" if $input{only_with_tag}; } print "
\n"; my $infocols = 1; printf(< EOF printf('', ($byfile ? ' class="sorted"' : '')); if ($byfile) { print 'File'; } else { print &link('File', sprintf('./%s#dirlist', toggleQuery('sortby', 'file'))); } print "\n"; # Do not display the other column headers if we do not have any files # with revision information. if (scalar(%fileinfo)) { $infocols++; printf('', ($byrev ? ' class="sorted"' : '')); if ($byrev) { print 'Rev.'; } else { print &link('Rev.', sprintf('./%s#dirlist', toggleQuery('sortby', 'rev'))); } print "\n"; $infocols++; printf('', ($bydate ? ' class="sorted"' : '')); if ($bydate) { print 'Age'; } else { print &link('Age', sprintf('./%s#dirlist', toggleQuery('sortby', 'date'))); } print "\n"; if ($show_author) { $infocols++; printf('', ($byauthor ? ' class="sorted"' : '')); if ($byauthor) { print 'Author'; } else { print &link('Author', sprintf('./%s#dirlist', toggleQuery('sortby', 'author'))); } print "\n"; } $infocols++; printf('', ($bylog ? ' class="sorted"' : '')); if ($bylog) { print 'Last log entry'; } else { print &link('Last log entry', sprintf('./%s#dirlist', toggleQuery('sortby', 'log'))); } print "\n"; } elsif ($use_descriptions) { print "Description\n"; $infocols++; } print "\n"; my $dirrow = 0; my $i; lookingforattic: for ($i = 0; $i <= $#dir; $i++) { if ($dir[$i] eq "Attic") { last lookingforattic; } } if (!$input{'hideattic'} && ($i <= $#dir) && opendir($dh, $fullname . '/Attic')) { splice(@dir, $i, 1, grep((s|^|Attic/|, !m|/\.|), readdir($dh))); closedir($dh); } my $hideAtticToggleLink = $input{'hideattic'} ? '' : &link('[Hide]', sprintf('./%s#dirlist', &toggleQuery('hideattic'))); # Sort without the Attic/ pathname. # place directories first my $attic; my $url; my $fileurl; my $filesexists; my $filesfound; foreach my $file (sort { &fileSortCmp } @dir) { next if ($file eq curdir()); # ignore CVS lock and stale NFS files next if ($file =~ /^\#cvs\.|^,|^\.nfs/); # \# for XEmacs cperl-mode... # Check whether to show the CVSROOT path next if ($input{'hidecvsroot'} && $file eq 'CVSROOT'); # Check whether the module is in the restricted list next if ($file && &forbidden_module($file)); # Is it a directory? my $isdir = -d "$fullname/$file"; # Ignore non-readable files and directories? next if ($input{'hidenonreadable'} && (! -r _ || ($isdir && ! -x _))); if ($file =~ s|^Attic/||) { $attic = ' (in the Attic) ' . $hideAtticToggleLink; } else { $attic = ''; } if ($file eq updir() || $isdir) { next if ($file eq updir() && $where eq '/'); my ($rev, $date, $log, $author, $filename, $keywordsubst) = @{$fileinfo{$file}} if (defined($fileinfo{$file})); printf "\n", ($dirrow % 2) ? 'even' : 'odd'; if ($file eq updir()) { $url = "../$query"; if ($nofilelinks) { print $backicon; } else { print &link($backicon, $url); } print ' ', &link("Parent Directory", $url); } else { $url = './' . urlencode($file) . "/$query"; print ''; if ($nofilelinks) { print $diricon; } else { print &link($diricon, $url); } print ' ', &link(htmlquote("$file/"), $url), $attic; if ($file eq "Attic") { print "  "; print &link('[Don\'t hide]', sprintf('./%s#dirlist', &toggleQuery('hideattic'))); } } # Show last change in dir if ($filename) { print "\n \n"; print readableTime(time() - $date, 0) if $date; print "\n", htmlquote($author) if $show_author; print "\n"; $filename =~ s%^[^/]+/%%; print &link(htmlquote("$filename/$rev"), sprintf('%s/%s%s#rev%s', uri_escape($file), uri_escape($filename), $query, $rev)), '
'; if ($log) { print htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra); print '...' if (length($log) > 80); } } else { my $dwhere = ($where ne '/' ? $where : '') . $file; if ($use_descriptions && defined $descriptions{$dwhere}) { print ''; print $descriptions{$dwhere}; } elsif ($infocols > 1) { # close the row with the appropriate number of # columns, so that the vertical seperators are visible my ($cols) = $infocols; while ($cols > 1) { print "\n "; $cols--; } } } print "\n\n"; $dirrow++; } elsif ($file =~ s/,v$//) { # Skip forbidden files now so we'll give no hint # about their existence. This should probably have # been done earlier, but it's straightforward here. next if forbidden_file("$fullname/$file"); $fileurl = ($attic ? 'Attic/' : '') . urlencode($file); $url = './' . $fileurl . $query; $filesexists++; next if (!defined($fileinfo{$file})); my ($rev, $date, $log, $author, $filename, $keywordsubst) = @{$fileinfo{$file}}; my $isbinary = $keywordsubst eq 'b' ? 1 : 0; $filesfound++; printf "\n", ($dirrow % 2) ? 'even' : 'odd'; printf '', $allow_cvsgraph ? '' : ' colspan="2"'; my $icon = $isbinary ? $binfileicon : $fileicon; if ($nofilelinks) { print $icon; } else { print &link($icon, $url); } print ' ', &link(htmlquote($file), $url), $attic; print '', graph_link($fileurl) if $allow_cvsgraph; print "\n"; download_link($fileurl, $rev, $rev, viewable(getMimeType($file, $isbinary)) ? 'text/x-cvsweb-markup' : undef); print "\n"; print readableTime(time() - $date, 0) if $date; print "\n", htmlquote($author) if $show_author; print "\n"; if ($log) { print htmlify(substr($log, 0, $shortLogLen), $allow_dir_extra); print '...' if (length $log > 80); } print "\n"; $dirrow++; } print "\n"; } print "\n"; if ((my $num = scalar(@unreadable)) && ! $input{hidenonreadable}) { printf(< NOTE: The following %d unreadable files were ignored:
%s

EOF } if ($filesexists && !$filesfound) { my $currtag = defined($input{only_with_tag}) ? sprintf(' (%s)', htmlquote($input{only_with_tag})) : ''; printf(< NOTE: There are %d files, but none matches the current tag%s.

EOF } if ($input{only_with_tag} && (!%tags || !$tags{$input{only_with_tag}})) { %tags = %alltags; } if (scalar %tags || $input{only_with_tag} || $edit_option_form || defined($input{"options"})) { print "
\n"; } if (scalar %tags || $input{only_with_tag}) { print "
\n"; foreach my $var (@stickyvars) { printf("\n", htmlquote($input{$var})) if (defined($input{$var}) && (!defined($DEFAULTVALUE{$var}) || $input{$var} ne $DEFAULTVALUE{$var}) && $var ne 'only_with_tag'); } print "

\n"; print "\n"; print ' \n"; printf "\n", htmlquote($where); print "

\n"; print "
\n"; } if ($allow_tar && $filesfound) { my ($basefile) = ($where =~ m,(?:.*/)?([^/]+),); my $havetar = $CMD{tar} && $CMD{gzip}; my $havezip = $CMD{zip}; if (defined($basefile) && $basefile ne '' && ($havetar || $havezip)) { my $q = ($query ? "$query;" : '?') . 'tarball=1'; print "
\n", '
Download this directory in '; # Mangle the filename so browsers show a reasonable filename to download. my @types = (); push(@types, &link('tarball', "$basefile.tar.gz$q")) if $havetar; push(@types, &link('zip archive', "$basefile.zip$q")) if $havezip; print join(' or ', @types), "
\n"; } } if ($edit_option_form || defined($input{"options"})) { my $formwhere = $scriptwhere; $formwhere =~ s|Attic/?$|| if ($input{'hideattic'}); print <
General options EOF if ($cvstree ne $cvstreedefault) { print "\n"; } print < \n"; print < EOF print '\n"; print < EOF printLogSortSelect(0); print < EOF print '\n"; print < EOF printDiffSelect(0); print <
EOF } html_footer(); } ############################### # View Files ############################### elsif (-f $fullname . ',v') { if (forbidden_file($fullname)) { fatal('403 Forbidden', 'Access forbidden. This file is mentioned in @ForbiddenFiles'); return; } if (defined($input{'rev'}) || $doCheckout) { &doCheckout($fullname, $input{'rev'}); gzipclose(); exit; } if (defined($input{'annotate'}) && $allow_annotate) { &doAnnotate($input{'annotate'}); gzipclose(); exit; } if (defined($input{'r1'}) && defined($input{'r2'})) { &doDiff($fullname, $input{'r1'}, $input{'tr1'}, $input{'r2'}, $input{'tr2'}, $input{'f'}); gzipclose(); exit; } if ($allow_cvsgraph && $input{graph}) { if ($input{makeimage}) { doGraph(); } else { doGraphView(); } gzipclose(); exit; } &doLog($fullname); ############################## # View Diff ############################## } elsif ($fullname =~ s/\.diff$// && -f $fullname . ",v" && $input{'r1'} && $input{'r2'}) { # $where-diff-removal if 'cvs rdiff' is used # .. but 'cvs rdiff'doesn't support some options # rcsdiff does (-w and -p), so it is disabled # $where =~ s/\.diff$//; # Allow diffs using the ".diff" extension so that browsers that default # to the filename in the URL when saving don't save diffs as eg. foo.c. &doDiff($fullname, $input{'r1'}, $input{'tr1'}, $input{'r2'}, $input{'tr2'}, $input{'f'}); gzipclose(); exit; } elsif (($newname = $fullname) =~ s|/([^/]+)$|/Attic/$1| && -f $newname . ",v") { # The file has been removed and is in the Attic. # Send a redirect pointing to the file in the Attic. (my $newplace = $scriptwhere) =~ s|/([^/]+)$|/Attic/$1|; if ($ENV{QUERY_STRING} ne "") { redirect("${newplace}?$ENV{QUERY_STRING}"); } else { redirect($newplace); } exit; } elsif (0 && (my @files = &safeglob($fullname . ",v"))) { http_header("text/plain"); print "You matched the following files:\n"; print join ("\n", @files); # Find the tags from each file # Display a form offering diffs between said tags } else { my $fh = do { local (*FH); }; my ($xtra, $module); # Assume it's a module name with a potential path following it. $xtra = (($module = $where) =~ s|/.*||) ? $& : ''; # Is there an indexed version of modules? if (open($fh, "< $cvsroot/CVSROOT/modules")) { while (<$fh>) { if (/^(\S+)\s+(\S+)/o && $module eq $1 && -d "$cvsroot/$2" && $module ne $2) { redirect("$scriptname/$2$xtra$query"); } } } fatal("404 Not Found", '%s: no such file or directory', $where); } gzipclose(); ## End MAIN sub printDiffSelect($) { my ($use_java_script) = @_; print '"; } sub printDiffSelectStickyVars() { while (my ($key, $val) = each %input) { next if ($key eq 'f'); next if (defined($DEFAULTVALUE{$key}) && $DEFAULTVALUE{$key} eq $val); print "\n"; } } sub printLogSortSelect($) { my ($use_java_script) = @_; print '"; } # # Find the last modified, version controlled files in the given directories. # Compares solely based on modification timestamps. Files in the returned list # are without the ,v suffix, and unreadable files have been filtered out. # sub findLastModifiedSubdirs(@) { my (@dirs) = @_; my @files; foreach my $dirname (@dirs) { next if ($dirname eq curdir() || $dirname eq updir()); my $dir = catdir($fullname, $dirname); next if (!-d $dir); my $dh = do { local (*DH); }; opendir($dh, $dir) or next; my (@filenames) = readdir($dh); closedir($dh); my $lastmod = undef; my $lastmodtime = undef; foreach my $filename (@filenames) { ($filename) = (catfile($dirname, $filename) =~ VALID_PATH) or next; # untaint my ($file) = catfile($fullname, $filename); next if ($filename !~ /,v$/o || !-f $file || !-r _); # Skip forbidden files. (my $f = $file) =~ s/,v$//; next if forbidden_file($f); $filename =~ s/,v$//; my $modtime = -M _; if (!defined($lastmod) || $modtime < $lastmodtime) { $lastmod = $filename; $lastmodtime = $modtime; } } push(@files, $lastmod) if (defined($lastmod)); } return @files; } sub htmlify_sub(&$) { (my $proc, local $_) = @_; my @a = split (m`(]+>[^<]*)`i); my $linked; my $result = ''; while (($_, $linked) = splice(@a, 0, 2)) { &$proc(); $result .= $_ if defined($_); $result .= $linked if defined($linked); } return $result; } sub htmlify($;$) { (local $_, my $extra) = @_; $_ = htmlquote($_); # get URL's as link s{ ((https?|ftp)://.+?)([\s\']|&(quot|[lg]t);) }{ &link($1, htmlunquote($1)) . $3 }egx; # get e-mails as link $_ = htmlify_sub { s< [\w+=\-.!]+@[\w\-]+(\.[\w\-]+)+ >< &link($&, "mailto:$&") >egix; } $_; if ($extra) { # get PR #'s as link: "PR#nnnn" "PR: nnnn, ..." "PR nnnn, ..." "bin/nnnn" if (defined($prcgi) && defined($re_prkeyword)) { my $prev; do { $prev = $_; $_ = htmlify_sub { s{ (\b$re_prkeyword[:\#]?\s* (?: \#? \d+[,\s]\s* )* \#?) (\d+)\b }{ $1 . &link($2, sprintf($prcgi, $2)) }egix; } $_; } while ($_ ne $prev); if (defined($re_prcategories)) { $_ = htmlify_sub { s{ (\b$re_prcategories/(\d+)\b) }{ &link($1, sprintf($prcgi, $2)) }egox; } $_; } } # get manpage specs as link: "foo.1" "foo(1)" if (defined($mancgi)) { $_ = htmlify_sub { s{ ( \b ( \w[\w+\-.]* (?: ::\w[\w+\-.]*)* ) (?: \( ([0-9n]) \) \B | \. ([0-9n]) \b ) ) }{ my($text, $name, $section) = ($1, $2, defined($3) ? $3 : $4); ($name =~ /[A-Za-z]/ && $name !~ /\.(:|$)/) ? &link($text, sprintf($mancgi, $section, $name)) : $text; }egx; } $_; } } return $_; } sub spacedHtmlText($;$) { (local $_, my $ts) = @_; $ts ||= $tabstop; # Cut trailing spaces and tabs s/[ \t]+$//; if (defined($ts)) { # Expand tabs 1 while s/\t+/' ' x (length($&) * $ts - length($`) % $ts)/e; } # replace and (\001 is to protect us from htmlify) # gzip can make excellent use of this repeating pattern :-) if ($hr_breakable) { # make every other space 'breakable' s/ / \001nbsp;/g; # 2 * # leave single space as it is } else { s/ /\001nbsp;/g; } $_ = htmlify($_, $allow_source_extra); # unescape y/\001/&/; return $_; } # Note that this doesn't htmlquote the first argument... sub link($$) { my ($name, $url) = @_; $url =~ s/:/sprintf("%%%02x", ord($&))/eg if $url =~ /^[^a-z]/; # relative sprintf '%s', hrefquote($url), $name; } sub revcmp($$) { my ($rev1, $rev2) = @_; # make no comparison for a tag or a branch return 0 if $rev1 =~ /[^\d.]/ || $rev2 =~ /[^\d.]/; my (@r1) = split (/\./, $rev1); my (@r2) = split (/\./, $rev2); my ($a, $b); while (($a = shift (@r1)) && ($b = shift (@r2))) { if ($a != $b) { return $a <=> $b; } } if (@r1) { return 1; } if (@r2) { return -1; } return 0; } sub fatal($$@) { my ($errcode, $format, @args) = @_; print "Status: $errcode\r\n"; html_header('Error'); print "

Error: ", sprintf($format, map(htmlquote($_), @args)), "

\n"; html_footer(); exit(1); } sub redirect($) { my ($url) = @_; print "Status: 301 Moved\r\n", "Location: $url\r\n"; html_header('Moved'); print "

This document is located ", &link('here', $url), "

\n"; html_footer(); exit(1); } sub safeglob($) { my ($filename) = @_; (my $dirname = $filename) =~ s|/[^/]+$||; $filename =~ s|.*/||; my @results; my $dh = do { local (*DH); }; if (opendir($dh, $dirname)) { my $glob = $filename; my $t; # transform filename from glob to regex. Deal with: # [, {, ?, * as glob chars # make sure to escape all other regex chars $glob =~ s/([\.\(\)\|\+])/\\$1/g; $glob =~ s/\*/.*/g; $glob =~ s/\?/./g; $glob =~ s/{([^}]+)}/($t = $1) =~ s-,-|-g; "($t)"/eg; foreach (readdir($dh)) { if (/^${glob}$/ && $_ =~ VALID_PATH) { push(@results, catfile($dirname, $1)); # untaint } } closedir($dh); } return @results; } sub search_path($) { my ($command) = @_; for my $d (split (/:/, $command_path)) { return "$d/$command" if -x "$d/$command"; } return ''; } sub getMimeType($;$) { my ($fullname, $binary) = @_; $binary = ($keywordsubstitution && $keywordsubstitution =~ /b/) unless defined($binary); (my $suffix = $fullname) =~ s/^.*\.([^.]*)$/$1/; my $mimetype = $MTYPES{$suffix}; $mimetype ||= $MimeTypes->mimeTypeOf($fullname) if defined($MimeTypes); if (!$mimetype && $suffix ne '*' && -f $mime_types && -r _) { my $fh = do { local (*FH); }; if (open($fh, $mime_types)) { my $re = sprintf('^\s*(\S+\/\S+)\s.+\b%s\b', quotemeta($suffix)); while (my $line = <$fh>) { if ($line =~ $re) { $mimetype = $1; $MTYPES{$suffix} = $mimetype; last; } } close($fh); } else { warn("Can't open MIME types file $mime_types for reading: $!"); } } $mimetype ||= $MTYPES{'*'}; $mimetype ||= $binary ? 'application/octet-stream' : 'text/plain'; return $mimetype; } ############################### # read first lines like head(1) ############################### sub head($;$) { my ($fh, $linecount) = @_; $linecount ||= 10; my @buf; if ($linecount > 0) { for (my $i = 0; !eof($fh) && $i < $linecount; $i++) { push @buf, scalar <$fh>; } } else { @buf = <$fh>; } return @buf; } ############################### # scan vim and Emacs directives ############################### sub scan_directives(@) { my $ts = undef; for (@_) { $ts = $1 if /\b(?:ts|tabstop|tab-width)[:=]\s*([1-9]\d*)\b/; } ('tabstop' => $ts); } sub openOutputFilter() { return unless $output_filter; open(STDOUT, "|-") and return; # child of child open(STDERR, '>', devnull()); exec($output_filter) or exit -1; } ############################### # show Annotation ############################### sub doAnnotate($) { my ($rev) = @_; (my $pathname = $where) =~ s/(Attic\/)?[^\/]*$//; (my $filename = $where) =~ s/^.*\///; # This annotate version is based on the cvs annotate-demo Perl script by # Cyclic Software. It was written by Cyclic Software, # http://www.cyclic.com/, and is in the public domain. # We could abandon the use of rlog, rcsdiff and co using # the cvs server in a similiar way one day (..after rewrite). local (*CVS_IN, *CVS_OUT); my ($h, $err) = startproc([ $CMD{cvs}, @annotate_options, 'server' ], 'pipe', \*CVS_OUT, timeout(30)); fatal('500 Internal Error', $err) unless $h; # OK, first send the request to the server. A simplified example is: # Root /home/kingdon/zwork/cvsroot # Argument foo/xx # Directory foo # /home/kingdon/zwork/cvsroot/foo # Directory . # /home/kingdon/zwork/cvsroot # annotate # although as you can see there are a few more details. print CVS_IN "Root $cvsroot\n"; print CVS_IN "Valid-responses ok error Valid-requests Checked-in Updated Merged Removed M E\n"; # Don't worry about sending valid-requests, the server just needs to # support "annotate" and if it doesn't, there isn't anything to be done. print CVS_IN "UseUnchanged\n"; print CVS_IN "Argument -r\n"; print CVS_IN "Argument $rev\n"; print CVS_IN "Argument $where\n"; # The protocol requires us to fully fake a working directory (at # least to the point of including the directories down to the one # containing the file in question). # So if $where is "dir/sdir/file", then dirs will be ("dir","sdir","file") my $path = ''; foreach my $dir (split('/', $where)) { if ($path eq "") { # In our example, $dir is "dir". $path = $dir; } else { print CVS_IN "Directory $path\n"; print CVS_IN "$cvsroot/$path\n"; # In our example, $_ is "sdir" and $path becomes "dir/sdir" # And the next time, "file" and "dir/sdir/file" (which then gets # ignored, because we don't need to send Directory for the file). $path .= "/$dir"; } } undef $path; # And the last "Directory" before "annotate" is the top level. print CVS_IN "Directory .\n"; print CVS_IN "$cvsroot\n"; print CVS_IN "annotate\n"; # OK, we've sent our command to the server. Thing to do is to # close the writer side and get all the responses. If "cvs server" # were nicer about buffering, then we could just leave it open, I think. close(CVS_IN) or die "cannot close: $!"; navigateHeader($scriptwhere, $pathname, $filename, $rev, 'annotate'); print '

Annotation of ', htmlquote("$pathname$filename"), ", revision $rev

\n"; # Ready to get the responses from the server. # For example: # E Annotations for foo/xx # E *************** # M 1.3 (kingdon 06-Sep-97): hello # ok my ($lineNr) = 0; my ($oldLrev, $oldLusr) = ("", ""); my ($revprint, $usrprint); if ($annTable) { print < EOF } else { print "
";
  }

  # prefetch several lines
  my @buf = head(*CVS_OUT);

  my %d = scan_directives(@buf);

  while (@buf || !eof(*CVS_OUT)) {

    $_ = @buf ? shift @buf : ;
    my @words = split;

    # Adding one is for the (single) space which follows $words[0].
    my $rest = substr($_, length($words[0]) + 1);
    if ($words[0] eq "E") {
      next;
    } elsif ($words[0] eq "M") {
      $lineNr++;
      (my $lrev = substr($_, 2,  13)) =~ y/ //d;
      (my $lusr = substr($_, 16, 9))  =~ y/ //d;
      my $line = substr($_, 36);
      my $isCurrentRev = ($rev eq $lrev);

      # we should parse the date here ..
      if ($lrev eq $oldLrev) {
        $revprint = sprintf('%-8s', '');
      } else {
        $revprint = sprintf('%-8s', $lrev);
        $revprint =~ s`\S+`&link($&, "$scriptwhere$query#rev$&")`e;    # `
        $oldLusr = '';
      }

      if ($lusr eq $oldLusr) {
        $usrprint = '';
      } else {
        $usrprint = $lusr;
      }
      $oldLrev = $lrev;
      $oldLusr = $lusr;

      # Set bold for text-based browsers only - graphical
      # browsers show bold fonts a bit wider than regular fonts,
      # so it looks irregular.
      print "" if ($isCurrentRev && $is_textbased);

      $usrprint = sprintf('%-8s', $usrprint);
      printf '%s%s %s %4d:', $revprint, $isCurrentRev ? '!' : ' ',
        htmlquote($usrprint), $lineNr;
      print spacedHtmlText($line, $d{'tabstop'});

      print "" if ($isCurrentRev && $is_textbased);
    } elsif ($words[0] eq "ok") {

      # We could complain about any text received after this, like the
      # CVS command line client.  But for simplicity, we don't.
    } elsif ($words[0] eq "error") {
      fatal("500 Internal Error",
            'Error occured during annotate: %s', $_);
    }
  }

  if ($annTable) {
    print "";
  } else {
    print "
"; } html_footer(); finish($h); } ############################### # make Checkout ############################### sub doCheckout($$) { my ($fullname, $rev) = @_; $rev = undef if ($rev eq 'HEAD' || $rev eq '.'); # get mimetype my $mimetype = defined($input{'content-type'}) ? $input{'content-type'} : getMimeType($fullname); my $moddate = undef; my $revopt; if (defined($rev)) { $revopt = "-r$rev"; if ($use_moddate) { readLog($fullname, $rev); $moddate = $date{$rev}; } } else { $revopt = "-rHEAD"; if ($use_moddate) { readLog($fullname); $moddate = $date{$symrev{HEAD}}; } } my $cr = abs_path($cvsroot) || $cvsroot; # abs_path() taints when run as a CGI... if ($cr =~ VALID_PATH) { $cr = $1; } else { fatal('500 Internal Error', 'Illegal CVS root: %s', $cr); } # Use abs_path() to work around a bug of cvs -p; expand symlinks if we can. my @cmd = ($CMD{cvs}, @cvs_options, '-d', $cr, 'co', '-p', $revopt, $where); local (*CVS_OUT, *CVS_ERR); my ($h, $err) = startproc(\@cmd, \"", '>pipe', \*CVS_OUT, '2>pipe', \*CVS_ERR,timeout(30)); fatal('500 Internal Error', $err) unless $h; if (eof(CVS_ERR)) { finish($h); fatal("404 Not Found", '%s is not (any longer) pertinent', $where); } #=================================================================== #Checking out squid/src/ftp.c #RCS: /usr/src/CVS/squid/src/ftp.c,v #VERS: 1.1.1.28.6.2 #*************** # Parse CVS header my ($revision, $filename, $cvsheader); $filename = ""; while () { last if (/^\*\*\*\*/); $revision = $1 if (/^VERS: (.*)$/); if (/^Checking out (.*)$/) { $filename = $1; $filename =~ s/^\.\/*//; } $cvsheader .= $_; } if ($filename ne $where) { finish($h); fatal("500 Internal Error", 'Unexpected output from cvs co: %s', $cvsheader); } if ($mimetype =~ $CvsWebMarkupRE) { # Here we know the last modified date, but don't know if tags have been # added since: no last-modified (for now). cvswebMarkup(\*CVS_OUT, $fullname, $revision); } else { http_header($mimetype, $moddate); local $/ = undef; print ; } finish($h); } sub cvswebMarkup($$$;$) { my ($filehandle, $fullname, $revision, $mod) = @_; (my $pathname = $where) =~ s/(Attic\/)?[^\/]*$//; (my $filename = $where) =~ s/^.*\///; my $fileurl = urlencode($filename); my $mimetype = getMimeType($filename); navigateHeader($scriptwhere, $pathname, $filename, $revision, 'view', $mod); print <
File:  EOF print &clickablePath($where, 1), ' - ('; &download_link($fileurl, $revision, 'download'); if ($mimetype ne 'text/plain') { print ' / '; &download_link($fileurl, $revision, "as text", "text/plain"); } print ')'; print ' - ', &link('annotate', "?annotate=$revision$barequery") if $allow_annotate; print ' - ', &graph_link('', 'graph') if $allow_cvsgraph; print "
\n"; if ($show_log_in_markup) { readLog($fullname); #,$revision); printLog($revision, 0); } else { print "Version: $revision
\n"; print "Tag: ", $input{only_with_tag}, "
\n" if $input{only_with_tag}; } print "
\n
"; my $url = download_url($fileurl, $revision, $mimetype); if ($mimetype =~ /^image/) { printf '%s
', hrefquote("$url$barequery"), htmlquote($filename); } elsif ($mimetype =~ m%^application/pdf%) { printf '
', hrefquote("$url$barequery"); } else { my $enscript_hl = undef; if ($allow_enscript) { while (my ($hl, $regex) = each %enscript_types) { if ($filename =~ $regex) { $enscript_hl = $hl; last; } } } print '
';
    my $linenumbers = $input{ln} || 0;

    if ($enscript_hl) {
      doEnscript($filehandle, $enscript_hl, $linenumbers);

    } else {
      my $ln  = 0;
      my @buf = ();
      my $ts  = undef;

      if ($preformat_in_markup) {
        # prefetch several lines
        @buf = head($filehandle);
        my %d = scan_directives(@buf);
        $ts = $d{tabstop};
      }

      while (@buf || !eof($filehandle)) {
        $_ = @buf ? shift @buf : <$filehandle>;
        if ($linenumbers) {
          $ln++;
          printf '%5d: ', ($ln) x 2;
        }
        print $preformat_in_markup ? spacedHtmlText($_, $ts) : htmlquote($_);
      }
    }

    print "
\n"; } html_footer(); } sub viewable($) { my $mimetype = shift || ''; return ($allow_markup && $mimetype =~ m%^((text|image)/|application/pdf)%); } ############################### # Show Colored Diff ############################### sub doDiff($$$$$$) { my ($fullname, $r1, $tr1, $r2, $tr2, $f) = @_; if (&forbidden_file($fullname)) { fatal("403 Forbidden", 'Access forbidden. This file is mentioned in @ForbiddenFiles'); } my ($rev1, $sym1); if ($r1 =~ /([^:]+)(:(.+))?/) { $rev1 = $1; $sym1 = $3; } if ($r1 eq 'text') { $rev1 = $tr1; $sym1 = ""; } my ($rev2, $sym2); if ($r2 =~ /([^:]+)(:(.+))?/) { $rev2 = $1; $sym2 = $3; } if ($r2 eq 'text') { $rev2 = $tr2; $sym2 = ""; } # # rev1 and rev2 are now both numeric revisions. # Thus we do a DWIM here and swap them if rev1 is after rev2. # XXX should we warn about the fact that we do this? if (&revcmp($rev1, $rev2) > 0) { my ($tmp1, $tmp2) = ($rev1, $sym1); ($rev1, $sym1) = ($rev2, $sym2); ($rev2, $sym2) = ($tmp1, $tmp2); } my $difftype = $DIFFTYPES{$f}; if (!$difftype) { fatal("400 Bad arguments", 'Diff format %s not understood', $f); } my @difftype = @{$difftype->{'opts'}}; my $human_readable = $difftype->{'colored'}; # apply special options if ($showfunc) { push @difftype, '-p' if $f ne 's'; my ($re1, $re2); while (($re1, $re2) = each %funcline_regexp) { if ($fullname =~ /$re1/) { push @difftype, '-F', $re2; last; } } } if ($human_readable) { if ($hr_ignwhite) { push @difftype, '-w'; } if ($hr_ignkeysubst) { push @difftype, '-kk'; } } my $fh = do { local (*FH); }; if (!open($fh, "-|")) { # child open(STDERR, ">&STDOUT"); # Redirect stderr to stdout openOutputFilter(); exec($CMD{rcsdiff}, @rcsdiff_options, @difftype, "-r$rev1", "-r$rev2", $fullname) or exit -1; } if ($human_readable) { # # Human readable diff. # human_readable_diff($fh, $rev2); html_footer(); gzipclose(); exit; } elsif ($f =~ /^([ucs])c$/) { # # Enscript colored diff. # my $hl = 'diff'; $hl .= $1 if ($1 eq 'u' || $1 eq 's'); (my $where_nd = $where) =~ s/\.diff$//; (my $pathname = $where_nd) =~ s|(Attic\/)?[^/]*$||; (my $filename = $where_nd) =~ s|^.*/||; (my $swhere = $scriptwhere) =~ s|\.diff$||; navigateHeader($swhere, $pathname, $filename, $rev2, 'diff'); printf(<Diff for /%s between versions %s and %s
EOF
    doEnscript(\$fh, $hl, 0);
    print <

EOF printDiffSelectStickyVars(); print 'Diff format: '; printDiffSelect($use_java_script); print "\n
\n"; html_footer(); gzipclose(); exit; } else { # # Plain diff. # http_header("text/plain"); } # #=================================================================== #RCS file: /home/ncvs/src/sys/netinet/tcp_output.c,v #retrieving revision 1.16 #retrieving revision 1.17 #diff -c -r1.16 -r1.17 #*** /home/ncvs/src/sys/netinet/tcp_output.c 1995/11/03 22:08:08 1.16 #--- /home/ncvs/src/sys/netinet/tcp_output.c 1995/12/05 17:46:35 1.17 # # Ideas: # - nuke the stderr output if it's what we expect it to be # - Add "no differences found" if the diff command supplied no output. # #*** src/sys/netinet/tcp_output.c 1995/11/03 22:08:08 1.16 #--- src/sys/netinet/tcp_output.c 1995/12/05 17:46:35 1.17 RELENG_2_1_0 # (bogus example, but...) # my ($f1, $f2); if (grep { $_ eq '-u' } @difftype) { $f1 = '---'; $f2 = '\+\+\+'; } else { $f1 = '\*\*\*'; $f2 = '---'; } while (<$fh>) { if (m|^$f1 $cvsroot|o) { s|$cvsroot/||o; if ($sym1) { chop; $_ .= " $sym1\n"; } } elsif (m|^$f2 $cvsroot|o) { s|$cvsroot/||o; if ($sym2) { chop; $_ .= " $sym2\n"; } } print $_; } close($fh); } ############################### # Show Logs .. ############################### sub getDirLogs($$@) { my ($cvsroot, $dirname, @otherFiles) = @_; my $tag = $input{only_with_tag}; my $DirName = catdir($cvsroot, $where); my @files = &safeglob("$DirName/*,v"); push (@files, &safeglob("$DirName/Attic/*,v")) if (!$input{'hideattic'}); foreach my $file (@otherFiles) { push(@files, catfile($DirName, $file)); } # Weed out unreadable files. my $i = 0; my @unreadable = (); while ($i < scalar(@files)) { # Note: last modified files from subdirs returned by # findLastModifiedSubdirs() come without the ,v suffix so they're not # found here, but have already been checked for readability. *cough* if (-r $files[$i] || !-e _) { $i++; } else { push(@unreadable, splice(@files, $i, 1)); } } # If there are no files, we're done. return @unreadable unless @files; my @cmd = ($CMD{rlog}); # Can't use -r as '-' is allowed in tagnames, # but misinterpreted by rlog. push(@cmd, '-r') unless defined($tag); my $fh = do { local (*FH); }; if (!open($fh, '-|')) { # Child open(STDERR, '>', devnull()); # Ignore rlog's complaints. openOutputFilter(); if ($file_list_len && $file_list_len > 1) { while (scalar(@files) > $file_list_len) { # Process files in chunks. system(@cmd, splice(@files, 0, $file_list_len)) == 0 or exit -1; } } exec(@cmd, @files) or exit -1; } undef @cmd; my $state = 'start'; my ($date, $branchpoint, $branch, $log, @filetags); my ($rev, $revision, $revwanted, $filename, $head, $author, $keywordsubst); while (<$fh>) { if ($state eq "start") { #Next file. Initialize file variables $rev = ''; $revwanted = ''; $branch = ''; $branchpoint = ''; $filename = ''; $log = ''; $revision = ''; %symrev = (); @filetags = (); $keywordsubst= ''; #jump to head state $state = "head"; } again: if ($state eq "head") { #$rcsfile = $1 if (/^RCS file: (.+)$/); #not used (yet) if (/^Working file: (.+)$/) { $filename = $1; } elsif (/^head: (.+)$/) { $head = $1; } elsif (/^branch: (.+)$/) { $branch = $1; } elsif (/^keyword substitution: (.+)$/) { $keywordsubst = $1; } elsif (/^symbolic names:/) { $state = "tags"; ($branch = $head) =~ s/\.\d+$// if $branch eq ''; $branch =~ s/(\d+)$/0.$1/; $symrev{MAIN} = $branch; $symrev{HEAD} = $branch; $alltags{MAIN} = 1; $alltags{HEAD} = 1; push (@filetags, "MAIN", "HEAD"); } elsif (/$LOG_REVSEPARATOR/o) { $state = "log"; $rev = ''; $date = ''; $log = ''; # Try to reconstruct the relative filename if RCS spits out a full path $filename =~ s%^\Q$DirName\E/%%; } next; } if ($state eq "tags") { if (/^\s+([^:]+):\s+([\d\.]+)\s*$/) { push (@filetags, $1); $symrev{$1} = $2; $alltags{$1} = 1; next; } elsif (/^\S/) { if (defined($tag)) { if (defined($symrev{$tag}) || $tag eq "HEAD") { $revwanted = $symrev{$tag eq "HEAD" ? "MAIN" : $tag}; ($branch = $revwanted) =~ s/\b0\.//; ($branchpoint = $branch) =~ s/\.?\d+$//; $revwanted = '' if ($revwanted ne $branch); } elsif ($tag ne "HEAD") { $state = "skip"; next; } } foreach my $tagfound (@filetags) { $tags{$tagfound} = 1; } $state = "head"; goto again; } } if ($state eq "log") { if (/$LOG_REVSEPARATOR/o || /$LOG_FILESEPARATOR/o) { # End of a log entry. my $revbranch = $rev; $revbranch =~ s/\.\d+$//; if ($revwanted eq '' && $branch ne '' && $branch eq $revbranch || !defined($tag)) { $revwanted = $rev; } if ($revwanted ne '' ? $rev eq $revwanted : $branchpoint ne '' ? $rev eq $branchpoint : 0 && ($rev eq $head)) { # Don't think head is needed here.. my @finfo = ($rev, $date, $log, $author, $filename, $keywordsubst); (my $name = $filename) =~ s%/.*%%; $fileinfo{$name} = [@finfo]; $state = "done" if ($rev eq $revwanted); } $rev = ''; $date = ''; $log = ''; } elsif ($date eq '' && m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);|) { my $yr = $1; $yr -= 1900 if ($yr > 100); # Damn 2-digit year routines :-) $date = timegm($6, $5, $4, $3, $2 - 1, $yr); ($author) = /author: ([^;]+)/; $state = 'log'; $log = ''; next; } elsif ($rev eq '' && /^revision (\d+(?:\.\d+)+).*$/) { $rev = $1; # .*$ eats up the locker(lockers?) info, if any next; } else { $log .= $_; } } if (/$LOG_FILESEPARATOR/o) { $state = "start"; next; } } my $linesread = $. || 0; close($fh); if ($linesread == 0) { fatal('500 Internal Error', 'Failed to spawn GNU rlog on "%s".

Did you set the $command_path in your configuration file correctly? (Currently: "%s")', htmlquote(join(', ', @files)), $command_path); } return @unreadable; } sub readLog($;$) { my ($fullname, $revision) = @_; my ($symnames, $head, $rev, $br, $brp, $branch, $branchrev); $revision = defined($revision) ? "-r$revision" : ''; undef %symrev; undef %revsym; undef @allrevisions; undef %date; undef %author; undef %state; undef %difflines; undef %log; $keywordsubstitution = ''; my $fh = do { local (*FH); }; if (!open($fh, "-|")) { # child if ($revision ne '') { openOutputFilter(); exec($CMD{rlog}, $revision, $fullname) or exit -1; } else { openOutputFilter(); exec($CMD{rlog}, $fullname) or exit -1; } } while (<$fh>) { if ($symnames) { if (/^\s+([^:]+):\s+([\d\.]+)/) { $symrev{$1} = $2; next; } else { $symnames = 0; } } if (/^head:\s+([\d\.]+)/) { $head = $1; } elsif (/^branch:\s+([\d\.]+)/) { $curbranch = $1; } elsif (/^symbolic names/) { $symnames = 1; } elsif (/^keyword substitution: (.+)$/) { $keywordsubstitution = $1; } elsif (/^-----/) { last; } } ($curbranch = $head) =~ s/\.\d+$// if (!defined($curbranch)); # each log entry is of the form: # ---------------------------- # revision 3.7.1.1 # date: 1995/11/29 22:15:52; author: fenner; state: Exp; lines: +5 -3 # log info # ---------------------------- # For a locked revision, the first line after the separator # becomes smth like # revision 9.19 locked by: vassilii; logentry: while (!/$LOG_FILESEPARATOR/o) { $_ = <$fh>; last logentry if (!defined($_)); # EOF if (/^revision (\d+(?:\.\d+)+)/) { $rev = $1; unshift (@allrevisions, $rev); } elsif (/$LOG_FILESEPARATOR/o || /$LOG_REVSEPARATOR/o) { next logentry; } else { # The rlog output is syntactically ambiguous. We must # have guessed wrong about where the end of the last log # message was. # Since this is likely to happen when people put rlog output # in their commit messages, don't even bother keeping # these lines since we don't know what revision they go with # any more. next logentry; } $_ = <$fh>; if ( m|^date:\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+);\s+author:\s+(\S+);\s+state:\s+(\S+);\s+(lines:\s+([0-9\s+-]+))?| ) { my $yr = $1; $yr -= 1900 if ($yr > 100); # Damn 2-digit year routines :-) $date{$rev} = timegm($6, $5, $4, $3, $2 - 1, $yr); $author{$rev} = $7; $state{$rev} = $8; $difflines{$rev} = $10; } else { fatal("500 Internal Error", 'Error parsing RCS output: %s', $_); } line: while (<$fh>) { next line if (/^branches:\s/); last line if (/$LOG_FILESEPARATOR/o || /$LOG_REVSEPARATOR/o); $log{$rev} .= $_; } } close($fh); @revorder = reverse sort { revcmp($a, $b) } @allrevisions; # # HEAD is an artificial tag which is simply the highest tag number on the main # branch, unless there is a branch tag in the RCS file in which case it's the # highest revision on that branch. Find it by looking through @revorder; it # is the first commit listed on the appropriate branch. # This is not neccesary the same revision as marked as head in the RCS file. my $headrev = $curbranch || "1"; ($symrev{"MAIN"} = $headrev) =~ s/(\d+)$/0.$1/; foreach $rev (@revorder) { if ($rev =~ /^(\S*)\.\d+$/ && $headrev eq $1) { $symrev{"HEAD"} = $rev; last; } } ($symrev{"HEAD"} = $headrev) =~ s/\.\d+$// if (!defined($symrev{"HEAD"})); # # Now that we know all of the revision numbers, we can associate # absolute revision numbers with all of the symbolic names, and # pass them to the form so that the same association doesn't have # to be built then. # undef @branchnames; undef %branchpoint; undef $sel; foreach (reverse sort keys %symrev) { $rev = $symrev{$_}; if ($rev =~ /^((.*)\.)?\b0\.(\d+)$/) { push (@branchnames, $_); # # A revision number of A.B.0.D really translates into # "the highest current revision on branch A.B.D". # # If there is no branch A.B.D, then it translates into # the head A.B . # # This reasoning also applies to the main branch A.B, # with the branch number 0.A, with the exception that # it has no head to translate to if there is nothing on # the branch, but I guess this can never happen? # # (the code below gracefully forgets about the branch # if it should happen) # $head = defined($2) ? $2 : ""; $branch = $3; $branchrev = $head . ($head ne "" ? "." : "") . $branch; my $regex; $regex = quotemeta $branchrev; $rev = $head; foreach my $r (@revorder) { if ($r =~ /^${regex}\b/) { $rev = $branchrev; last; } } next if ($rev eq ""); if ($rev ne $head && $head ne "") { $branchpoint{$head} .= ', ' if ($branchpoint{$head}); $branchpoint{$head} .= $_; } } $revsym{$rev} .= ", " if ($revsym{$rev}); $revsym{$rev} .= $_; $sel .= sprintf("\n", htmlquote($rev), (htmlquote($_)) x 2); } my ($onlyonbranch, $onlybranchpoint); if ($onlyonbranch = $input{'only_with_tag'}) { $onlyonbranch = $symrev{$onlyonbranch}; if ($onlyonbranch =~ s/\b0\.//) { ($onlybranchpoint = $onlyonbranch) =~ s/\.\d+$//; } else { $onlybranchpoint = $onlyonbranch; } if (!defined($onlyonbranch) || $onlybranchpoint eq "") { fatal("404 Tag not found", 'Tag %s not defined', $input{'only_with_tag'}); } } undef @revisions; foreach (@allrevisions) { ($br = $_) =~ s/\.\d+$//; ($brp = $br) =~ s/\.\d+$//; next if ($onlyonbranch && $br ne $onlyonbranch && $_ ne $onlybranchpoint); unshift (@revisions, $_); } if ($logsort eq "date") { # Sort the revisions in commit order an secondary sort on revision # (secondary sort needed for imported sources, or the first main # revision gets before the same revision on the 1.1.1 branch) @revdisplayorder = sort { $date{$b} <=> $date{$a} || -revcmp($a, $b) } @revisions; } elsif ($logsort eq "rev") { # Sort the revisions in revision order, highest first @revdisplayorder = reverse sort { revcmp($a, $b) } @revisions; } else { # No sorting. Present in the same order as rlog / cvs log @revdisplayorder = @revisions; } } sub printDiffLinks($$) { my ($text, $url) = @_; my @extra; for my $difftype ($DIFFTYPES{$defaultDiffType}{colored} ? qw(u) : qw(h)) { my $f = $difftype eq $defaultDiffType ? '' : $difftype; push(@extra, &link(lc($DIFFTYPES{$difftype}{descr}), "$url;f=$f")); } print &link($text, $url), ' (', join (', ', @extra), ')'; } sub printLog($;$$) { ($_, my $link, my $isSelected) = @_; (my $br = $_) =~ s/\.\d+$//; (my $brp = $br) =~ s/\.?\d+$//; $link = 1 if (!defined($link)); my $isDead = ($state{$_} eq 'dead'); if ($link && !$isDead) { (my $filename = $where) =~ s/^.*\///; my $fileurl = urlencode($filename); my $mimetype = getMimeType($filename); my $viewable = viewable($mimetype); print ""; if (defined($revsym{$_})) { foreach my $sym (split (", ", $revsym{$_})) { print ''; } } if (defined($revsym{$br}) && $revsym{$br} && !defined($nameprinted{$br})) { foreach my $sym (split (", ", $revsym{$br})) { print ''; } $nameprinted{$br} = 1; } print "\n Revision "; &download_link($fileurl, $_, $_, $viewable ? 'text/x-cvsweb-markup' : undef); print ' / ('; if ($viewable) { &download_link($fileurl, $_, "download", $mimetype); } if ($mimetype ne 'text/plain') { print ' / ' if $viewable; &download_link($fileurl, $_, "as text", "text/plain"); } if (!$viewable) { print ' / ' if ($mimetype ne 'text/plain'); &download_link($fileurl, $_, "view", "text/x-cvsweb-markup"); } print ')'; if ($allow_annotate) { print " - "; print &link('annotate', sprintf('%s/%s?annotate=%s%s', $scriptname, urlencode($where), $_, $barequery)); } # Plus a select link if enabled, and this version isn't selected if ($allow_version_select) { print ' - '; if ($isSelected) { print '[selected]'; } else { print &link('select for diffs', sprintf('%s?r1=%s%s#rev%s', $scriptwhere, $_, $barequery, $_)); } } } else { print "Revision $_"; } if (/^1\.1\.1\.\d+$/) { print " (vendor branch)"; } if (defined @mytz) { my ($est) = $mytz[(localtime($date{$_}))[8]]; print ", ", scalar localtime($date{$_}), " $est ("; } else { print ", ", scalar gmtime($date{$_}), " UTC ("; } print readableTime(time() - $date{$_}, 1), ' ago)'; print ' by ', htmlquote($author{$_}), "
\n"; if ($revsym{$br}) { printf "Branch: %s
\n", $link ? link_tags($revsym{$br}) : htmlquote($revsym{$br}); } if ($revsym{$_}) { printf "CVS Tags: %s
\n", $link ? link_tags($revsym{$_}) : htmlquote($revsym{$_}); } if ($branchpoint{$_}) { printf "Branch point for: %s
\n", $link ? link_tags($branchpoint{$_}) : htmlquote($branchpoint{$_}); } # Find the previous revision my $prev; my @prevrev = split (/\./, $_); do { if (--$prevrev[$#prevrev] <= 0) { # If it was X.Y.Z.1, just make it X.Y pop (@prevrev); pop (@prevrev); } $prev = join (".", @prevrev); } until (defined($date{$prev}) || $prev eq ""); if ($prev ne "") { if ($difflines{$_}) { print "Changes since $prev: $difflines{$_} lines
"; } } if ($isDead) { print "FILE REMOVED\n"; } elsif ($link) { my %diffrev = (); $diffrev{$_} = 1; $diffrev{""} = 1; my $diff = 'Diff'; # # Offer diff to previous revision if ($prev) { $diffrev{$prev} = 1; my $url = sprintf('%s.diff?r1=%s;r2=%s%s', $scriptwhere, $prev, $_, $barequery); print $diff, " to previous "; $diff = ''; printDiffLinks($prev, $url); } # # Plus, if it's on a branch, and it's not a vendor branch, # offer a diff with the branch point. if ($revsym{$brp} && !/^1\.1\.1\.\d+$/ && !defined($diffrev{$brp})) { my $url = sprintf('%s.diff?r1=%s;r2=%s%s', $scriptwhere, $brp, $_, $barequery); print $diff, " to branchpoint "; $diff = ''; printDiffLinks($brp, $url); } # # Plus, if it's on a branch, and it's not a vendor branch, # offer to diff with the next revision of the higher branch. # (e.g. change gets committed and then brought # over to -stable) if (/^\d+\.\d+\.\d+/ && !/^1\.1\.1\.\d+$/) { my ($i, $nextmain); for ($i = 0; $i < $#revorder && $revorder[$i] ne $_; $i++) { } my @tmp2 = split (/\./, $_); for ($nextmain = ""; $i > 0; $i--) { my $next = $revorder[$i - 1]; my @tmp1 = split (/\./, $next); if (@tmp1 < @tmp2) { $nextmain = $next; last; } # Only the highest version on a branch should have # a diff for the "next main". last if (@tmp1 - 1 <= @tmp2 && join (".", @tmp1[0 .. $#tmp1 - 1]) eq join (".", @tmp2[0 .. $#tmp1 - 1])); } if (!defined($diffrev{$nextmain})) { $diffrev{$nextmain} = 1; my $url = sprintf('%s.diff?r1=%s;r2=%s%s', $scriptwhere, $nextmain, $_, $barequery); print $diff, " next main "; $diff = ''; printDiffLinks($nextmain, $url); } } # Plus if user has selected only r1, then present a link # to make a diff to that revision if (defined($input{"r1"}) && !defined($diffrev{$input{"r1"}})) { $diffrev{$input{"r1"}} = 1; my $url = sprintf('%s.diff?r1=%s;r2=%s%s', $scriptwhere, $input{'r1'}, $_, $barequery); print $diff, " to selected "; $diff = ''; printDiffLinks($input{'r1'}, $url); } } print "\n
\n";
  print &htmlify($log{$_}, $allow_log_extra);
  print "
\n"; } # # Generates the HTML view for CvsGraph. # sub doGraphView() { (my $pathname = $where) =~ s|[^/]*$||; (my $filename = $where) =~ s|^.*/||; navigateHeader($scriptwhere, $pathname, $filename, undef, 'graph'); my $title = 'Revision graph of ' . htmlquote($pathname . $filename); my $mapname = 'CvsGraphMap'; my $ctype = viewable(getMimeType($filename)) ? ';content-type=text/x-cvsweb-markup' : ''; printf(<%s
%s
EOF my $qquery = hrefquote($barequery); my @graph_cmd = ($CMD{cvsgraph}, '-r', $cvsroot, '-i', '-M', $mapname, '-x', 4, "-Omap_branch_href=\"href=\\\"./?only_with_tag=%(%t%)$qquery\\\"\"", "-Omap_rev_href=\"href=\\\"?rev=%(%R%)$qquery$ctype\\\"\"", "-Omap_diff_href=\"href=\\\"%(%F%).diff" . "?r1=%(%P%);r2=%(%R%)$qquery\\\"\"", ); push(@graph_cmd, '-c', $cvsgraph_config) if $cvsgraph_config; push(@graph_cmd, catfile($pathname, $filename . ',v')); local *CVSGRAPH_OUT; my ($h, $err) = startproc(\@graph_cmd, \"", '>pipe', \*CVSGRAPH_OUT, timeout(30)); fatal('500 Internal Error', $err) unless $h; { local $/ = undef; print ; } finish($h); html_footer(); } # # Generates a graph using CvsGraph. # sub doGraph() { (my $pathname = $where) =~ s|[^/]*$||; (my $filename = $where) =~ s|^.*/||; http_header('image/png'); my @graph_cmd = ($CMD{cvsgraph}, '-r', $cvsroot); push(@graph_cmd, '-c', $cvsgraph_config) if $cvsgraph_config; push(@graph_cmd, catfile($pathname, $filename . ',v')); local *CVSGRAPH_OUT; my ($h, $err) = startproc(\@graph_cmd, \"", '>pipe', \*CVSGRAPH_OUT, timeout(30)); fatal('500 Internal Error', $err) unless $h; { local $/ = undef; binmode(\*STDOUT); print ; } finish($h); } sub doLog($) { my ($fullname) = @_; readLog($fullname); html_header("CVS log for $where"); (my $upwhere = $where) =~ s|(Attic/)?[^/]+$||; (my $filename = $where) =~ s|^.*/||; my $backurl = $scriptname . "/" . urlencode($upwhere) . $query; print "

\n "; print &link($backicon, "$backurl#$filename"), " Up to ", &clickablePath($upwhere, 1), "\n

\n"; print "

\n "; print &link('Request diff between arbitrary revisions', '#diff'); if ($allow_cvsgraph) { print ' / ', &graph_link('', 'Display revisions graphically'); } print "\n

\n
\n"; print "

\n"; my $explain = $keywordsubstitution =~ /b/ ? ' (i.e.: CVS considers this a binary file)' : ''; print "Keyword substitution: $keywordsubstitution$explain
\n"; print $curbranch ? ("Default branch: ", ($revsym{$curbranch} || $curbranch)) : "No default branch"; print "
\n"; print 'Current tag: ', htmlquote($input{only_with_tag}), "
\n" if $input{only_with_tag}; print "

\n"; undef %nameprinted; for my $r (@revdisplayorder) { print "
\n"; my $sel = (defined($input{r1}) && $input{r1} eq $r); print "
\n" if $sel; printLog($r, undef, $sel); print "
\n" if $sel; } printf(<
Diff request

This form allows you to request diffs between any two revisions of a file. You may select a symbolic revision name using the selection box or you may type in a numeric name using the type-in text box.

EOF foreach (@stickyvars) { printf("\n", $_, htmlquote($input{$_})) if (defined($input{$_}) && (!defined($DEFAULTVALUE{$_}) || $input{$_} ne $DEFAULTVALUE{$_})); } print < \n"; my $diffrev = defined($input{r1}) ? $input{r1} : $revdisplayorder[$#revdisplayorder]; printf(< \n"; $diffrev = defined($input{r2}) ? $input{r2} : $revdisplayorder[0]; printf(<
Log view options EOF if (@branchnames) { printf(< EOF } print <
EOF printDiffSelect($use_java_script); print <
EOF printLogSortSelect($use_java_script); print <
EOF foreach (@stickyvars) { next if ($_ eq "f"); next if ($_ eq "only_with_tag"); next if ($_ eq "logsort"); printf("\n", htmlquote($input{$_})) if (defined($input{$_}) && (!defined($DEFAULTVALUE{$_}) || $input{$_} ne $DEFAULTVALUE{$_})); } print "
\n
\n"; html_footer(); } sub flush_diff_rows($$$$) { my ($leftColRef, $rightColRef, $leftRow, $rightRow) = @_; return unless defined($state); if ($state eq "PreChangeRemove") { # we just got remove-lines before for (my $j = 0; $j < $leftRow; $j++) { printf(<  %s   EOF } } elsif ($state eq "PreChange") { # state eq "PreChange" # we got removes with subsequent adds if ($Have_Ediff) { # construct the suffix tree my $left_diff = join("\n", @$leftColRef[0..$leftRow-1]); my $right_diff = join("\n", @$rightColRef[0..$rightRow-1]); my $diff_str = String::Ediff::ediff($left_diff, $right_diff); my @diff_str = split(/ /, $diff_str); my $INFINITY = 10000000; push(@diff_str, ($INFINITY) x 8); my ($idx, $b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) = (0, @diff_str[0..7]); my ($l_cul, $r_cul) = (0, 0); my ($ldx, $rdx) = (0, 0); my (@left_html, @right_html); for (my $j = 0; $j < $leftRow; $j++) { my $line_len = length(@$leftColRef[$j]); my $line = @$leftColRef[$j]; $l_cul += length($line) + 1; # includes "\n" my $l_culx = $l_cul - 1; # not includes "\n" if ($j < $lb1) { $line = spacedHtmlText($line); push(@left_html, "$line"); } elsif ($lb1 == $j) { my $html_line; while ($lb1 == $j) { my $begin_char = $l_culx - $b1; $line =~ /^(.*)(.{$begin_char})$/; $html_line .= spacedHtmlText($1) . ''; $line = $2; last if ($j != $le1); my $end_char = $l_culx - $e1; $line =~ /^(.*)(.{$end_char})$/; $html_line .= spacedHtmlText($1) . ''; $line = $2; $idx++; my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) = ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2); ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) = @diff_str[$idx*8..($idx+1)*8-1]; $lb1 = $INFINITY if ($lb1 < 0); $lb2 = $INFINITY if ($lb2 < 0); $le1 = $INFINITY if ($le1 < 0); $le2 = $INFINITY if ($le2 < 0); if ($te1 > $b1) { ($b1, $lb1) = ($te1, $tle1); } if ($te2 > $b2) { ($b2, $lb2) = ($te2, $tle2); } } push(@left_html, sprintf('%s%s', 'diff-changed', $html_line, spacedHtmlText($line))); } elsif ($le1 == $j) { my $html_line; while ($le1 == $j) { my $end_char = $l_culx - $e1; $line =~ /^(.*)(.{$end_char})$/; $html_line .= spacedHtmlText($1) . ''; $line = $2; $idx++; my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) = ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2); ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) = @diff_str[$idx*8..($idx+1)*8-1]; $lb1 = $INFINITY if ($lb1 < 0); $lb2 = $INFINITY if ($lb2 < 0); $le1 = $INFINITY if ($le1 < 0); $le2 = $INFINITY if ($le2 < 0); if ($te1 > $b1) { ($b1, $lb1) = ($te1, $tle1); } if ($te2 > $b2) { ($b2, $lb2) = ($te2, $tle2); } last if ($lb1 != $j); my $begin_char = $l_culx - $b1; $line =~ /^(.*)(.{$begin_char})$/; $html_line .= spacedHtmlText($1) . ''; $line = $2; } push(@left_html, sprintf('%s%s', 'diff-unchanged', $html_line, spacedHtmlText($line))); } else { $line = spacedHtmlText($line); push(@left_html, "$line"); } } ($idx, $b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) = (0, @diff_str[0..7]); $lb1 = $INFINITY if ($lb1 < 0); $lb2 = $INFINITY if ($lb2 < 0); $le1 = $INFINITY if ($le1 < 0); $le2 = $INFINITY if ($le2 < 0); for (my $j = 0; $j < $rightRow; $j++) { my $line_len = length(@$rightColRef[$j]); my $line = @$rightColRef[$j]; $r_cul += length($line) + 1; # includes "\n" my $r_culx = $r_cul - 1; # not includes "\n" if ($j < $lb2) { $line = spacedHtmlText($line); push(@right_html, "$line"); } elsif ($lb2 == $j) { my $html_line; while ($lb2 == $j) { my $begin_char = $r_culx - $b2; $line =~ /^(.*)(.{$begin_char})$/; $html_line .= spacedHtmlText($1) . ''; $line = $2; last if ($j != $le2); my $end_char = $r_culx - $e2; $line =~ /^(.*)(.{$end_char})$/; $html_line .= spacedHtmlText($1) . ''; $line = $2; $idx++; my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) = ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2); ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) = @diff_str[$idx*8..($idx+1)*8-1]; $lb1 = $INFINITY if ($lb1 < 0); $lb2 = $INFINITY if ($lb2 < 0); $le1 = $INFINITY if ($le1 < 0); $le2 = $INFINITY if ($le2 < 0); if ($te1 > $b1) { ($b1, $lb1) = ($te1, $tle1); } if ($te2 > $b2) { ($b2, $lb2) = ($te2, $tle2); } } push(@right_html, sprintf('%s%s', 'diff-changed', $html_line, spacedHtmlText($line))); } elsif ($le2 == $j) { my $html_line; while ($le2 == $j) { my $end_char = $r_culx - $e2; $line =~ /^(.*)(.{$end_char})$/; $html_line .= spacedHtmlText($1) . ''; $line = $2; $idx++; my ($tb1, $te1, $tlb1, $tle1, $tb2, $te2, $tlb2, $tle2) = ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2); ($b1, $e1, $lb1, $le1, $b2, $e2, $lb2, $le2) = @diff_str[$idx*8..($idx+1)*8-1]; $lb1 = $INFINITY if ($lb1 < 0); $lb2 = $INFINITY if ($lb2 < 0); $le1 = $INFINITY if ($le1 < 0); $le2 = $INFINITY if ($le2 < 0); if ($te1 > $b1) { ($b1, $lb1) = ($te1, $tle1); } if ($te2 > $b2) { ($b2, $lb2) = ($te2, $tle2); } last if ($lb2 != $j); my $begin_char = $r_culx - $b2; $line =~ /^(.*)(.{$begin_char})$/; $html_line .= spacedHtmlText($1) . ''; $line = $2; } push(@right_html, sprintf('%s%s', 'diff-unchanged', $html_line, spacedHtmlText($line))); } else { $line = spacedHtmlText ($line); push @right_html, "$line"; } } for (my $j = 0; $j < $leftRow || $j < $rightRow ; $j++) { # dump out both cols print ''; if ($j < $leftRow) { print $left_html[$j]; } else { print ' '; } if ($j < $rightRow) { print $right_html[$j]; } else { print ' '; } print "\n"; } } else { for (my $j = 0; $j < $leftRow || $j < $rightRow; $j++) { # dump both cols print "\n"; if ($j < $leftRow) { print ' ' . spacedHtmlText(@$leftColRef[$j]) . ''; } else { print ' '; } print "\n"; if ($j < $rightRow) { print ' ' . spacedHtmlText(@$rightColRef[$j]) . ''; } else { print ' '; } print "\n\n"; } } } } ## # Function to generate Human readable diff-files # human_readable_diff(String revision_to_return_to); ## sub human_readable_diff($$) { my ($fh, $rev) = @_; (my $where_nd = $where) =~ s|\.diff$||; (my $filename = $where_nd) =~ s|^.*/||; (my $pathname = $where_nd) =~ s|(Attic/)?[^/]*$||; (my $scriptwhere_nd = $scriptwhere) =~ s|\.diff$||; navigateHeader($scriptwhere_nd, $pathname, $filename, $rev, 'diff'); # Read header to pick up read revision and date, if possible. my ($r1d, $r1r, $r2d, $r2r); while (<$fh>) { ($r1d, $r1r) = /\t(.*)\t(.*)$/ if (/^--- /); ($r2d, $r2r) = /\t(.*)\t(.*)$/ if (/^\+\+\+ /); last if (/^\+\+\+ /); } my ($rev1, $date1); if (defined($r1r) && $r1r =~ /^(\d+\.)+\d+$/) { $rev1 = $r1r; $date1 = $r1d; } my ($rev2, $date2); if (defined($r2r) && $r2r =~ /^(\d+\.)+\d+$/) { $rev2 = $r2r; $date2 = $r2d; } $rev1 = 'unknown-left' unless defined($rev1); $rev2 = 'unknown-right' unless defined($rev2); $date1 = defined($date1) ? ', ' . htmlquote($date1) : ''; $date2 = defined($date2) ? ', ' . htmlquote($date2) : ''; # Using Diff for /%s between versions %s and %s
EOF # Process diff text # prefetch several lines my @buf = head($fh); my %d = scan_directives(@buf); my $leftRow = 0; my $rightRow = 0; my ($difftxt, @rightCol, @leftCol, $oldline, $newline, $funname); my ($diffcode, $rest); while (@buf || !eof($fh)) { $difftxt = @buf ? shift @buf : <$fh>; if ($difftxt =~ /^@@/) { ($oldline, $newline, $funname) = $difftxt =~ /@@ \-([0-9]+).*\+([0-9]+).*@@(.*)/; $funname = htmlquote($funname); $funname =~ s/\s/ /go; $funname &&= " $funname"; printf(< EOF $state = "dump"; $leftRow = 0; $rightRow = 0; } else { ($diffcode, $rest) = $difftxt =~ /^([-+ ])(.*)/; $_ = $rest; ######### # little state machine to parse unified-diff output (Hen, zeller@think.de) # in order to get some nice 'ediff'-mode output # states: # "dump" - just dump the value # "PreChangeRemove" - we began with '-' .. so this could be the start of a 'change' area or just remove # "PreChange" - okey, we got several '-' lines and moved to '+' lines -> this is a change block ########## if ($diffcode eq '+') { if ($state eq "dump") { # 'change' never begins with '+': just dump out value $_ = spacedHtmlText($rest, $d{'tabstop'}); printf(< EOF } else { # we got minus before $state = "PreChange"; $rightCol[$rightRow++] = $_; } } elsif ($diffcode eq '-') { $state = "PreChangeRemove"; $leftCol[$leftRow++] = $_; } else { # empty diffcode flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow; $_ = spacedHtmlText($rest, $d{'tabstop'}); printf(< EOF $state = "dump"; $leftRow = 0; $rightRow = 0; } } } close($fh); flush_diff_rows \@leftCol, \@rightCol, $leftRow, $rightRow; # state is empty if we didn't have any change if (!$state) { print < EOF } printf(<
version %s%s version %s%s
Line %s%s Line %s%s    %s
 %s  %s
 
- No viewable change -
Removed from v.%s  
changed lines
  Added in v.%s

EOF } sub doEnscript($$$) { my ($filehandle, $highlight, $linenumbers) = @_; my @cmd = ($CMD{enscript}, @enscript_options, qw(-q --language=cvsweb -o -), "--highlight=$highlight"); local *ENSCRIPT_OUT; my ($h, $err) = startproc(\@cmd, $filehandle, '>pipe', \*ENSCRIPT_OUT, timeout(30)); fatal('500 Internal Error', $err) unless $h; # We could short-circuit and have enscript output directly to STDOUT above, # but that doesn't work with mod_perl (at least some 1.99 versions). if ($linenumbers) { my $ln = 0; while () { printf '%5d: ', (++$ln) x 2; print $_; } } else { local $/ = undef; print ; } finish($h); } sub navigateHeader($$$$$;$) { my ($swhere, $path, $filename, $rev, $title, $moddate) = @_; $swhere = "" if ($swhere eq $scriptwhere); $swhere = './' . urlencode($filename) if ($swhere eq ""); my $qfile = htmlquote($filename); my $qpath = htmlquote($path); my $trev = $rev ? " - $rev" : ''; http_header('', $moddate); print < $qpath$qfile - $title$trev $HTML_META$CSS "; printf(<%s Up to %s EOF } sub plural_write($$) { my ($num, $text) = @_; if ($num != 1) { $text .= "s"; } if ($num > 0) { return join (' ', $num, $text); } else { return ""; } } ## # print readable timestamp in terms of # '..time ago' # H. Zeller ## sub readableTime($$) { my ($secs, $long) = @_; # This function works correctly for time >= 2 seconds. return 'very little time' if ($secs < 2); my %desc = ( 1 => 'second', 60 => 'minute', 3600 => 'hour', 86400 => 'day', 604800 => 'week', 2628000 => 'month', 31536000 => 'year' ); my @breaks = sort { $a <=> $b } keys %desc; my $i = 0; while ($i <= $#breaks && $secs >= 2 * $breaks[$i]) { $i++; } $i--; my $break = $breaks[$i]; my $retval = plural_write(int($secs / $break), $desc{$break}); if ($long == 1 && $i > 0) { my $rest = $secs % $break; $i--; $break = $breaks[$i]; my $resttime = plural_write(int($rest / $break), $desc{$break}); if ($resttime) { $retval .= ", $resttime"; } } return $retval; } ## # clickablePath(String pathname, boolean last_item_clickable) # # returns a html-ified path whereas each directory is a link for # faster navigation. last_item_clickable controls whether the # basename (last directory/file) is a link as well ## sub clickablePath($$) { my ($pathname, $clickLast) = @_; my $root = '[' . htmlquote($CVSROOTdescr{$cvstree} || $cvstree) . ']'; # This should never happen (see chooseCVSRoot()), but let's be sure... return $root if ($pathname eq '/'); my $retval = ' ' . &link($root, sprintf('%s/%s#dirlist', $scriptname, $query)); my $wherepath = ''; my ($lastslash) = $pathname =~ m|/$|; foreach (split (/\//, $pathname)) { $retval .= ' / '; $wherepath .= "/$_"; my $last = "$wherepath/" eq "/$pathname" || $wherepath eq "/$pathname"; if ($clickLast || !$last) { $retval .= &link(htmlquote($_), join ('', $scriptname, urlencode($wherepath), (!$last || $lastslash ? '/' : ''), $query, (!$last || $lastslash ? "#dirlist" : ""))); } else { # do not make a link to the current dir $retval .= htmlquote($_); } } return $retval; } sub chooseCVSRoot() { print "
\n"; if (2 <= @CVSROOT) { foreach my $k (keys %input) { printf("\n", htmlquote($k), htmlquote($input{$k})) if ($input{$k} && $k ne 'cvsroot'); } # Form-Elements look wierd in Netscape if the background # isn't gray and the form elements are not placed # within a table ... printf(< \n\n"; } else { # no choice -- but we need the form to select module/path, # at least for Netscape printf "

\nCVS Root: [%s]", htmlquote($CVSROOTdescr{$cvstree} || $cvstree); } print < Module path or alias: EOF print 2 <= @CVSROOT ? "\n\n" : '

'; print "\n"; } sub chooseMirror() { # This code comes from the original BSD-cvsweb # and may not be useful for your site; If you don't # set %MIRRORS this won't show up, anyway. scalar(%MIRRORS) or return; # Should perhaps exclude the current site somehow... print "\n

\nThis CVSweb is mirrored in\n"; my @tmp = map(&link(htmlquote($_), $MIRRORS{$_}), sort keys %MIRRORS); my $tmp = pop (@tmp); if (scalar(@tmp)) { print join (', ', @tmp), ' and '; } print "$tmp.\n

\n"; } sub fileSortCmp() { (my $af = $a) =~ s/,v$//; (my $bf = $b) =~ s/,v$//; my ($rev1, $date1, $log1, $author1, $filename1) = @{$fileinfo{$af}} if (defined($fileinfo{$af})); my ($rev2, $date2, $log2, $author2, $filename2) = @{$fileinfo{$bf}} if (defined($fileinfo{$bf})); my $comp = 0; if (defined($filename1) && defined($filename2) && $af eq $filename1 && $bf eq $filename2) { # Two files $comp = -revcmp($rev1, $rev2) if ($byrev && $rev1 && $rev2); $comp = ($date2 <=> $date1) if ($bydate && $date1 && $date2); if ($input{ignorecase}) { $comp = (uc($log1) cmp uc($log2)) if ($bylog && $log1 && $log2); $comp = (uc($author1) cmp uc($author2)) if ($byauthor && $author1 && $author2); } else { $comp = ($log1 cmp $log2) if ($bylog && $log1 && $log2); $comp = ($author1 cmp $author2) if ($byauthor && $author1 && $author2); } } if ($comp == 0) { # Directories first, then files under version control, # then other, "rogue" files. # Sort by filename if no other criteria available. my $ad = ( (-d "$fullname/$a") ? 'D' : (defined($fileinfo{$af}) ? 'F' : 'R') ); my $bd = ( (-d "$fullname/$b") ? 'D' : (defined($fileinfo{$bf}) ? 'F' : 'R') ); (my $c = $a) =~ s|.*/||; (my $d = $b) =~ s|.*/||; my ($l, $r) = ("$ad$c", "$bd$d"); $comp = $input{ignorecase} ? (uc($l) cmp uc($r)) : ($l cmp $r); # Parent dir is always first, then Attic. if ($comp != 0) { if ($l eq 'D..') { $comp = -1; } elsif ($r eq 'D..') { $comp = 1; } elsif ($l eq 'DAttic') { $comp = -1; } elsif ($r eq 'DAttic') { $comp = 1; } } } return $comp; } # make A url for downloading sub download_url($$;$) { my ($url, $revision, $mimetype) = @_; $revision =~ s/\b0\.//; if (defined($checkoutMagic) && (!defined($mimetype) || $mimetype !~ $CvsWebMarkupRE)) { my $path = $where; $path =~ s|[^/]+$||; $url = "$scriptname/$checkoutMagic/${path}$url"; } $url .= "?rev=$revision"; $url .= ';content-type=' . uri_escape($mimetype) if (defined($mimetype)); return $url; } # # Presents a link to download the selected revision. # sub download_link($$$;$) { my ($url, $revision, $textlink, $mimetype) = @_; my $fullurl = download_url($url, $revision, $mimetype); $fullurl =~ s/:/sprintf("%%%02x", ord($&))/eg; printf '$textlink"; } sub graph_link($;$) { my ($url, $text) = @_; $text ||= $graphicon; return sprintf('%s', hrefquote($url), hrefquote($barequery), $text); } # Returns a Query string with the # specified parameter toggled sub toggleQuery($;$) { my ($toggle, $value) = @_; my %vars = %input; if (defined($value)) { $vars{$toggle} = $value; } else { $vars{$toggle} = $vars{$toggle} ? 0 : 1; } # Build a new query of non-default paramenters my $newquery = ""; foreach my $var (@stickyvars) { my ($value) = defined($vars{$var}) ? $vars{$var} : ""; my ($default) = defined($DEFAULTVALUE{$var}) ? $DEFAULTVALUE{$var} : ""; if ($value ne $default) { $newquery .= ';' if ($newquery ne ""); $newquery .= uri_escape($var) . '=' . uri_escape($value); } } if ($newquery) { return '?' . $newquery; } return ""; } sub urlencode($) { local ($_) = @_; s/[\000-+{-\377]/sprintf("%%%02x", ord($&))/ge; return $_; } sub htmlquote($) { local ($_) = @_; # Special Characters; RFC 1866 s/&/&/g; s/\"/"/g; s//>/g; return $_; } sub htmlunquote($) { local ($_) = @_; # Special Characters; RFC 1866 s/"/\"/g; s/<//g; s/&/&/g; return $_; } sub hrefquote($) { local ($_) = @_; y/ /+/; htmlquote($_); } sub http_header(;$$) { my ($content_type, $moddate) = @_; $content_type ||= 'text/html'; $content_type .= "; charset=$charset" if ($charset && $content_type =~ m,^text/,); # Note that in the following, we explicitly join() and concatenate the # headers instead of printing them as an array. This is because some # systems, eg. early versions of mod_perl 2 don't quite get it if the # last \r\n\r\n isn't included in the last "payload" header print(). my @headers = (); # TODO: ctime(3) from scalar gmtime() isn't HTTP compliant, see HTTP::Date. push(@headers, 'Last-Modified: ' . scalar gmtime($moddate) . ' GMT') if $moddate; push(@headers, 'Content-Type: ' . $content_type); if ($allow_compress && $maycompress) { if ($has_zlib || (defined($CMD{gzip}) && open(GZIP, "| $CMD{gzip} -1 -c"))) { push(@headers, 'Content-Encoding: x-gzip'); push(@headers, 'Vary: Accept-Encoding'); # RFC 2616, 14.44 print join("\r\n", @headers) . "\r\n\r\n"; $| = 1; $| = 0; # Flush header output. if ($has_zlib) { tie *GZIP, __PACKAGE__, \*STDOUT; } select(GZIP); $gzip_open = 1; } else { print join("\r\n", @headers) . "\r\n\r\n"; print "Unable to find gzip binary in the \$command_path ($command_path) to compress output
"; } } else { print join("\r\n", @headers) . "\r\n\r\n"; } } sub html_header($;$) { my ($title, $moddate) = @_; $title = htmlquote($title); my $l = $logo || ''; http_header('text/html', $moddate); print < $title $HTML_META$CSS $l

$title

EOH } sub html_footer() { print "
\n
$address
\n" if $address; print "\n\n"; } sub link_tags($) { my ($tags) = @_; my ($ret) = ""; my ($fileurl, $filename); ($filename = $where) =~ s/^.*\///; $fileurl = './' . urlencode($filename); foreach my $sym (split (", ", $tags)) { $ret .= ",\n" if ($ret ne ""); $ret .= &link(htmlquote($sym), $fileurl . toggleQuery('only_with_tag', $sym)); } return "$ret\n"; } # # See if a module is listed in the config file's @HideModules list. # sub forbidden_module($) { my ($module) = @_; for my $hidden_re (@HideModules) { return 1 if ($module =~ $hidden_re); } return 0; } sub forbidden_file($) { my ($path) = @_; $path = substr($path, length($cvsroot) + 1); for my $forbidden_re (@ForbiddenFiles) { return 1 if ($path =~ $forbidden_re); } return 0; } # # Starts a process using IPC::Run. All arguments are passed to # IPC::Run::start() as-is. Returns an array ($harness, $error) where # $harness is from IPC::Run if start() succeeds, undef otherwise. In case # of an error, $error contains the error message. # sub startproc(@) { my $h = undef; eval { local $SIG{__DIE__}; $h = start(@_) or die("return code: $?"); }; my $err = $@ ? "Failed to run '@{$_[0]}': $@" : undef; return ($h, $err); } # Close the GZIP handle, and remove the tie. sub gzipclose { if ($gzip_open) { select(STDOUT); close(GZIP); untie *GZIP; $gzip_open = 0; } } # implement a gzipped file handle via the Compress:Zlib compression # library. sub MAGIC1() { 0x1f } sub MAGIC2() { 0x8b } sub OSCODE() { 3 } sub TIEHANDLE { my ($class, $out) = @_; my ($d) = Compress::Zlib::deflateInit( -Level => Compress::Zlib::Z_BEST_COMPRESSION(), -WindowBits => -Compress::Zlib::MAX_WBITS() ) or return undef; my ($o) = { handle => $out, dh => $d, crc => 0, len => 0, }; my ($header) = pack("c10", MAGIC1, MAGIC2, Compress::Zlib::Z_DEFLATED(), 0, 0, 0, 0, 0, 0, OSCODE); print {$o->{handle}} $header; return bless($o, $class); } sub PRINT { my ($o) = shift; my ($buf) = join (defined($,) ? $, : "", @_); my ($len) = length($buf); my ($compressed, $status) = $o->{dh}->deflate($buf); print {$o->{handle}} $compressed if defined($compressed); $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc}); $o->{len} += $len; return $len; } sub PRINTF { my ($o) = shift; my ($fmt) = shift; my ($buf) = sprintf($fmt, @_); my ($len) = length($buf); my ($compressed, $status) = $o->{dh}->deflate($buf); print {$o->{handle}} $compressed if defined($compressed); $o->{crc} = Compress::Zlib::crc32($buf, $o->{crc}); $o->{len} += $len; return $len; } sub WRITE { my ($o, $buf, $len, $off) = @_; my ($compressed, $status) = $o->{dh}->deflate(substr($buf, 0, $len)); print {$o->{handle}} $compressed if defined($compressed); $o->{crc} = Compress::Zlib::crc32(substr($buf, 0, $len), $o->{crc}); $o->{len} += $len; return $len; } sub CLOSE { my ($o) = @_; return if !defined($o->{dh}); my ($buf) = $o->{dh}->flush(); $buf .= pack("V V", $o->{crc}, $o->{len}); print {$o->{handle}} $buf; undef $o->{dh}; } sub DESTROY { my ($o) = @_; CLOSE($o); } # Local variables: # indent-tabs-mode: nil # cperl-indent-level: 2 # End: