RISC OS Open: Bugs and sources: Browsing repository

You are currently browsing the Subversion repository.
Changesets can be listed by changeset number.
The Git repository is here.

root
» rool
» perl
» cvsweb
» trunk
» cvsweb.cgi

Revision:: 158

Log:: Reconfigured all applications for use in the ROOL account with its
new layout. All files are set up for the development branch of the
filesystem. Caught up in this changeset is an unrelated modification
to the directory listing routine in Radiant, which now sorts the
entries alphabetically.

Author:: rool

Date:: Sun Dec 10 19:28:59 +0000 2006

Size:: 126713 Bytes

Show revision log

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

Download in other formats:

raw | text

Download in other formats:

Search tickets

Social

ROOL Store

Donate! Why?

RISC OS IPR

Options

RSS feeds