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:: 62

Log:: Configured for RISC OS Open site, including CSS changes. Small
change to CGI script to ensure that a title heading in the page
is always produced, even in the CVS root directory.

Author:: adh

Date:: Sun Aug 06 17:53:18 +0100 2006

Size:: 126705 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/adh/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'), '/usr/local/etc/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