#!/usr/bin/perl -T
######################################################################
#
# source --	Present sourcecode as html, complete with references
#  the '/icons' images are available in any standard Apache installation
#
#	Arne Georg Gleditsch <argggh@ifi.uio.no>
#	Per Kristian Gjermshus <pergj@ifi.uio.no>
#
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
######################################################################

use strict;
use lib do { $0 =~ m{(.*)/} ? "$1/lib" : 'lib' };  # if LXR modules are in ./lib

=head1 source script

This script manages navigation across the source-tree and individual
file display.

=cut

use LXR::Common;
use LXR::Markup;
use LXR::Template;
use Local;


=head2 C<iconlink ($html_elt, $path)>

Internal function C<iconlink> is a support routine for
C<diricon> and C<fileicon>.
It works around the protection implemented in C<fileref>
which prevents from inserting HTML elements in the "description".

=over

=item 1

C<$templ>

a I<string> containing the HTML element without delimiters

=item 2

C<$path>

a I<string> containing the path of the icon file

=back

Custom delimiters are added to the HTML element
which is transformed into a file link by C<fileref>.
The custom delimiters are replaced by standard HTML
delimiters in the returned link which is then sent back
to caller.

=cut

sub iconlink {
	my ($html_elt, $path) = @_;
	my $link = fileref
				( "\0S$html_elt\0E"
				, ''
				, $path
				);
	$link =~ s/\0S/</g;	# Starting delimiter
	$link =~ s/\0E/>/g;	# Ending delimiter
	return $link;
}


=head2 C<diricon ($templ, $node, $dir)>

Function C<diricon> is a "$variable" substitution function.
It returns an HTML-string containing an C<E<lt> A E<gt>> block
surrounding an C<E<lt> IMG E<gt>> tag for a folder icon.
The link allows to jump to the directory.

=over

=item 1

C<$templ>

a I<string> containing the template (empty for a "variable")

=item 2

C<$node>

a I<string> containing the name of the directory

=item 3

C<$dir>

a I<string> containing the name of the parent directory

=back

If parameters C<'iconfolder'> and C<'diricon'> have been defined,
use the designated icon; otherwise revert to the default Apache icon.

=cut

sub diricon {
	my ($templ, $node, $dir) = @_;
	my $img;

	if ($node eq '../') {
		if	(exists $config->{'iconfolder'}
			&&  exists $config->{'parenticon'}
			) {
			$img = $config->{'iconfolder'} . $config->{'parenticon'};
		} else {
			$img = '/icons/back.gif';
		}
	} else {
		if	(exists $config->{'iconfolder'}
			&&  exists $config->{'diricon'}
			) {
			$img = $config->{'iconfolder'} . $config->{'diricon'};
		} else {
			$img = '/icons/folder.gif';
		}
	}

	return iconlink
				( "img src=\"$img\" alt=\"folder\""
				, $dir . $node
				);
}


=head2 C<dirname ($templ, $node, $dir)>

Function C<dirname> is a "$variable" substitution function.
It returns an HTML-string containing an C<E<lt> A E<gt>> tag
linking to the directory.

=over

=item 1

C<$templ>

a I<string> containing the template (empty for a "variable")

=item 2

C<$node>

a I<string> containing the name of the directory

=item 3

C<$dir>

a I<string> containing the name of the parent directory

=back

=cut

sub dirname {
	my ($templ, $node, $dir) = @_;

	if ($node eq '../') {
		return fileref('Parent directory', 'dirfolder', $dir . $node);
	} else {
		return fileref($node, 'dirfolder', $dir . $node);
	}
}


=head2 C<fileicon ($templ, $node, $dir)>

Function C<fileicon> is a "$variable" substitution function.
It returns an HTML-string containing an C<E<lt> A E<gt>> block
surrounding an C<E<lt> IMG E<gt>> tag for a file icon.
The link allows to jump to the file.

=over

=item 1

C<$templ>

a I<string> containing the template (empty for a "variable")

=item 2

C<$node>

a I<string> containing the name of the file

=item 3

C<$dir>

a I<string> containing the name of the parent directory

=back

If parameters C<'iconfolder'> and various icon descriptors have been defined,
use the designated icon; otherwise revert to the default Apache icon.

=cut

sub fileicon {
	my ($templ, $node, $dir) = @_;
	my $img;
	my $link;
	my $graphic = $config->{'graphicfile'};
	my $icons = $config->{'icons'};

	if (exists $config->{'iconfolder'}) {
		if ($node =~ m/(\.([^.]+)?)$/) {
			my $ext = $2;

			while (my ($pat, $iconfile) = each %$icons) {
				if ($ext =~ m/^($pat)$/i) {
					$img = $config->{'iconfolder'} . $iconfile;
					keys %$icons;	# reset iterator
					return iconlink
							( "img src=\"$img\" alt=\"file\""
							, $dir . $node
							);
				}
			}
			if ($ext =~ m/^($graphic)$/) {
				return iconlink
							( 'img src="'
								. $config->{'iconfolder'}
								. $config->{'graphicicon'}
								. "\" alt=\"graphic file\""
							, $dir . $node);
			}
		}

		return iconlink	( 'img src="'
							. $config->{'iconfolder'}
							. $config->{'defaulticon'}
							. '" alt="file"'
						, $dir . $node
						);
	}

# Fallback to some generally universally available icons
# in case the above feature is not defined
# but they are usually not appealing.
	if (!defined $img) {
		if ($node =~ /\.[ch]$/) {
			$img = '/icons/c.gif';
		} elsif ($node =~ /\.(cpp|cc|java)$/) {
			$img = '/icons/c.gif';
		} elsif (substr($node, -4) eq '.txt') {
			$img = '/icons/text.gif';
		} elsif ($node =~ /\.(jar|war|ear|zip|tar|gz|tgz|cab)$/) {
			$img = '/icons/compressed.gif';
		} elsif ($node =~ /\.($graphic)$/) {
			$img = '/icons/image2.gif';
		} else {
			$img = '/icons/generic.gif';
		}
	}
	return iconlink	( "img src=\"$img\" alt=''",
					, $dir . $node
					);
}


=head2 C<filename ($templ, $node, $dir)>

Function C<filename> is a "$variable" substitution function.
It returns a HTML-string containing an C<E<lt> A E<gt>> tag
linking to the file.

=over

=item 1

C<$templ>

a I<string> containing the template (empty for a "variable")

=item 2

C<$node>

a I<string> containing the name of the file

=item 3

C<$dir>

a I<string> containing the name of the parent directory

=back

=cut

sub filename {
	my ($templ, $node, $dir) = @_;
	return fileref($node, 'dirfile', $dir . $node);
}


=head2 C<filesize ($templ, $node, $dir)>

Function C<filesize> is a "$function" substitution function.
It returns its expanded argument, inserting the file size
where appropriate.

=over

=item 1

C<$templ>

a I<string> containing the template (i.e. the function argument)

=item 2

C<$node>

a I<string> containing the name of the file

=item 3

C<$dir>

a I<string> containing the name of the parent directory

=back

In the present implementation, specifying a size unit in the
argument makes no difference. The size is "scaled" according
to its textual length.

=cut

sub filesize {
	my ($templ, $node, $dir) = @_;

	my $s = $files->getfilesize($dir . $node, $releaseid);
	my $str;

	$str = $s . ' ';
	if (length($s) > 6) {
		$s >>= 10;
		$str = ${s} . 'ki';
		if (length($s) > 7) {
			$s >>= 10;
			$str = ${s} . 'Mi';
		}
	}
# 	if ($s < 1 << 10) {
# 		$str = "$s";
# 	} else {
# 
# 		#      if ($s < 1<<20) {
# 		$str = ($s >> 10) . "k";
# 
# 		#      } else {
# 		#          $str = ($s>>20) . "M";
# 		#      }
# 	}
	return expandtemplate(
		$templ,
		(
			'bytes'  => sub { return $str },
			'kbytes' => sub { return $str },
			'mbytes' => sub { return $str }
		)
	);
}


=head2 C<modtime ($templ, $node, $dir)>

Function C<modtime> is a "$variable" substitution function.
It returns a human-readable date/time string for the file
last-modification date.

=over

=item 1

C<$templ>

a I<string> containing the template (empty for a "variable")

=item 2

C<$node>

a I<string> containing the name of the file

=item 3

C<$dir>

a I<string> containing the name of the parent directory

=back

The last-modification date is extracted from the database.

=cut

sub modtime {
	my ($templ, $node, $dir) = @_;

	my $file_time = $files->getfiletime($dir . $node, $releaseid);
	return '-' unless defined($file_time);
	return _edittime($file_time);
}


=head2 C<indextime ($templ, $node, $dir)>

Function C<indextime> is a "$variable" substitution function.
It returns a human-readable date/time string for the file
indexation date by I<genxref>.

=over

=item 1

C<$templ>

a I<string> containing the template (empty for a "variable")

=item 2

C<$node>

a I<string> containing the name of the file

=item 3

C<$dir>

a I<string> containing the name of the parent directory

=back

The indexation date is extracted from the database.

If it does not exist (file was never indexed or modified
since indexation), a single dash is return.

=cut

sub indextime {
	my ($templ, $node, $dir) = @_;

	my $index_time = $index->filetimestamp
						( $dir . $node
						, $files->filerev($dir . $node, $releaseid)
						);
	return '-' if !$index_time;
	return _edittime($index_time);
}


=head2 C<descexpand ($templ, $node, $dir, $releaseid)>

Function C<descexpand> is a "$function" substitution function.
It returns a short description for a file or a subdirectory
in a directory listing.
If no description can be extracted, the called support routines
MUST return the string "&nbsp;" to keep the table looking pretty.

=over

=item 1

C<$templ>

a I<string> containing the template (empty for a "variable")

=item 2

C<$node>

a I<string> containing the name of the file

=item 3

C<$dir>

a I<string> containing the name of the parent directory

=item 4

C<$releaseid>

a I<string> containing the version name

Presently, not used.

=back

Control is passed to custom function located in F<Local.pm>.

=cut

sub descexpand {
	my ($templ, $node, $dir, $releaseid) = @_;
	if (substr($node, -1) eq '/') {
		return expandtemplate
			( $templ
			, ('desctext' => sub { return dirdesc($dir . $node, $releaseid); }
			  )
			);
	} elsif (LXR::Lang::parseable($dir.$node, $releaseid)) {
		return expandtemplate
			( $templ
			, ('desctext' => sub { return filedesc($node, $dir, $releaseid); }
			  )
			);
	} else {
		return '&nbsp;';
	}
}


=head2 C<rowclass ($templ, $line)>

Function C<indextime> is a "$variable" substitution function.
It returns a CSS class name depending on line parity.

=over

=item 1

C<$templ>

a I<string> containing the template (empty for a "variable")

=item 2

C<$line>

an I<integer> containing the line number of the display

=back

=cut

sub rowclass {
	my ($templ, $line) = @_;
	return ((($line - 1) / 3) % 2) ? 'dirrow2' : 'dirrow1';
}


=head2 C<direxpand ($templ, $dir)>

Function C<direxpand> is a "$function" substitution function.
It returns its template argument expanded for every node in
the directory.

=over

=item 1

C<$templ>

a I<string> containing the template

=item 2

C<$dir>

a I<string> containing the directory name

=back

The directory content is obtained from the storage engine.

The template is expanded depending on the nature of the node,
file or directory, because processing of the nested substitutions
is slightly different in each case.

=cut

sub direxpand {
	my ($templ, $dir) = @_;
	my $direx = '';
	my $line  = 1;
	my %index;
	my @nodes;
	my $node;

#	Since CVS does not manage directory version,
#	ensure we always request 'head' for directories.
	@nodes = $files->getdir
		( $dir
		, $files->isa('LXR::Files::CVS')
			? 'head'
			: $releaseid
		);
	unless (@nodes) {
		print(  "<p class=\"error\">\n<i>The directory " . $dir
			  . " does not exist, is empty or is hidden by an exclusion rule.</i>\n</p>\n");
		if	(  $files->isa('LXR::Files::CVS')
			&& !$HTTP->{'param'}{'_showattic'}
			) {
			print("<p class=\"error\">\n");
			print("<i>This directory might exist in other versions,");
			print	( " try 'Show attic files' or select a different",
					, $config->{'variables'}{'v'}{'name'}
					, ".</i>\n"
					);
			print("</p>\n");
		}
		return;
	}

	unshift(@nodes, '../') unless $dir eq '/';
	foreach $node (@nodes) {
		if (substr($node, -1) eq '/') {
			$direx .= expandtemplate
				(	$templ
				,	( 'iconlink' => sub { diricon(@_, $node, $dir) }
					, 'namelink' => sub { dirname(@_, $node, $dir) }
					, 'filesize' => sub { '-' }
					, 'modtime'  => sub { modtime(@_, $node, $dir) }
					, 'indextime'=> sub { '' }
					, 'dirclass' => sub { rowclass(@_, $line++) }
					, 'dirindexclass' => sub { 'dirindex' }
					, 'description' =>
						sub { descexpand(@_, $node, $dir, $releaseid) }
					)
				);
		} else {
			$direx .= expandtemplate
				(	$templ
				,	( 'iconlink'    => sub { fileicon(@_, $node, $dir) }
					, 'namelink'    => sub { filename(@_, $node, $dir) }
					, 'filesize'    => sub { filesize(@_, $node, $dir) }
					, 'modtime'     => sub { modtime(@_,  $node, $dir) }
					, 'indextime'   => sub {
						my $t = indextime(@_,  $node, $dir);
						if ('-' eq $t) {
							if (LXR::Lang::parseable($dir.$node, $releaseid)) {
								return 'Not valid'
							};
							return '-';
						}
						$t }
					, 'dirclass'    => sub { rowclass(@_, $line++) }
					, 'dirindexclass' =>
						sub	{	if	(	!$index->filetimestamp
											( $dir.$node
											, $files->filerev
												( $dir.$node
												, $releaseid
												)
											)
									&&	LXR::Lang::parseable($dir.$node, $releaseid)
									) {
									'dirindexinvalid'
								} else {
									'dirindex'
								}
							}
					, 'description' => sub {
						( $files->isa('LXR::Files::CVS')
								&& 0 <= index	( $files->toreal($dir . $node, $releaseid)
												, 'Attic'
												)
							? '<i>In Attic</i>  '
							: ''
						) . descexpand(@_, $node, $dir, $releaseid);
						}
					)
				);
		}
	}
	return ($direx);
}


=head2 C<printdir ($dir)>

Procedure C<printdir> retrieves the C<'htmldir'> template
and launches template expansion.

=over

=item 1

C<$dir>

a I<string> containing the directory name

=back

The procedure dispatches to C<dirdesc> (located in
I<Local.pm>) for a description of the directory and
to C<direxpand> for content edition.

=cut

sub printdir {
	my $dir = shift;
	my $templ;

	$templ = gettemplate
				( 'htmldir'
				, "<ul>\n\$files{\n<li>\$iconlink \$namelink\n}</ul>\n"
				);

	# print the listing itself
	print(expandtemplate
			( $templ
			,	( 'files' => sub { direxpand(@_, $dir) }
				, 'description' => sub { dirdesc($dir, $releaseid) }
				, 'indexstate'	=> sub { displayindexstate('source') }
				)
			)
	);
}


=head2 C<next_annot ($currev, $r, $bg)>

Function C<next_annot> returns an HTML C<E<lt> SPAN E<gt>> block
containing revision and author information for the next file line.

=over

=item 1

C<$currev>

a I<string> containing the requested version for the file

=item 2

C<$r>

a I<reference> to a I<string> containing the revision of the previous line

=item 3

C<$bg>

a I<reference> to a flag toggling between 0 and 1

=back

I<References allow to keep values between calls.>

It returns an empty string if the repository manager has no annotation
(either by design, I<e.g.> plain files, or disabled by configuration
parameters).

The returned block is a blank string if the line is part of the
same change set as the previous line (to have a cleaner screen).

Revision information is checked for space overflow and eventually
truncated as per repository rule.

Finally, a CSS class is computed (latest revision or alternating
styles).

=cut

sub next_annot {
	my ($currev, $r, $bg) = @_;

	# Get annotations from the storage engine and prepare their
	# layout in order to prefix every source line with its
	# associated annotation.
	my $rev = $files->getnextannotation($pathname, $releaseid);
	return '' if !defined($rev);
	my $auth = $files->getauthor($pathname, $releaseid, $rev);

	if ($rev eq $$r) {
		$rev = ' ' x 16;
		if ($$r eq $currev) {
			$rev = "<span class='annot-cur'>$rev</span>";
		} else {
			$rev = "<span class='annot$$bg'>$rev</span>";
		}
		return $rev;
	}

	$$r = $rev;
	# NOTE: modern VCSes return their annotations in Unicode, but user
	# may have requested another display encoding (e.g. ISO-8859-x).
	# We don't try to transcode since this may be time-consuming for
	# little benefit. We just hope that, on average, truncation will
	# not occur too frequently in the middle of an UTF-8 sequence.
	# UTF-8-aware length computation and truncation is attempted only
	# on author's name. Nothing is done on the revision id because
	# it usually does not contain fancy characters (read it is numeric
	# with eventual ASCII punctuation). svn allows more freedom in
	# revision naming and may conflict with this choice. You'll also
	# be in trouble when displaying UTF-8 with CVS returning ISO-8859.
	my $la;
	my $pat;
	if ('utf-8' ne $config->{'encoding'}) {
		$la = length($auth);
	} else {
		use utf8;
		$la = length($auth);
	};
	my $lr = length($rev);
	# After this call to length, $rev may be edited to contain
	# HTML element and $lr will be different from length($rev).
	# $lr reflects the number of character positions necessary
	# to display $rev on screen, not its content.
	if ($la > 0) {
		if ($lr+$la > 15) {	# sum of 2 fields too long
			if	( $la > 4
				&& $la > 14-$lr
				) {	# truncate first author
				$la = 14 - $lr;
				$la = 4 if $la < 4;
				$auth = pack('(U)'.$la, unpack('U*', $auth));
				$auth .= '<span class="error">*</span>';
				$la++;
			}
			if ($lr+$la >15) { # now truncate revision
				$lr = 14 - $la;
				$lr = $files->truncateannotation(\$rev, $lr);
			}
		}
		if ($lr+$la < 15) {	# some space to distribute
			if ($la >= 8) {
				$rev  .= ' ' x (15-$lr-$la);
			} elsif ($lr >= 7) {
				$auth .= ' ' x (15-$lr-$la);
			} else {
				$rev  .= ' ' x (7-$lr);
				$auth .= ' ' x (8-$la);
			}
		}
		$rev .= ' ' . $auth;
	} else {
		if ($lr > 16) {
			$lr = $files->truncateannotation(\$rev, 15);
		} else {
			$rev .= ' ' x (16 - $lr);
		}
	}
	if ($$r eq $currev) {
		$rev = "<span class='annot-cur'>$rev</span>";
	} else {
		$$bg = 1 - $$bg;
		$rev = "<span class='annot$$bg'>$rev</span>";
	}
	return $rev;
}


=head2 C<printfile ($raw)>

Procedure C<printfile> is the main driver for node display.

=over

=item 1

C<$raw>

a I<"boolean"> requesting I<raw mode> if non zero

=back

It checks first for a directory described by global variable
C<$pathname> to be handled by C<printdir>.

In I<raw mode>, source file is output "as is", without any
editing or highlighting.

Various information related to the source file are retrieved
(last indexation time, VCS annotations, ...). They are checked
and/or prepared for mixed output with source lines.

If possible, links with other development tools are created
and placed in the resulting HTML page.


=cut

sub printfile {
	my $raw = shift;

	if (substr($pathname, -1) eq '/') {
		printdir($pathname);
	} else {

		# Avoid UTF-8 sanity errors with non-text files
		# when tree is stored in a Git repository
		if	(	$files->isa('LXR::Files::GIT')
			&&	! LXR::Lang::parseable($pathname, $releaseid)
			) {
			$files->{'git-annotations'} = 0;
			$files->{'git_blame'} = 0;
		}
		# Request annotated content (through defined third argument)
		my $fileh = $files->getfilehandle($pathname, $releaseid, !$raw);

		if ($fileh) {
			if ($raw) {
				print($fileh->getlines );

			#	} elsif ($node =~ /README$/) {
			#		print("<pre>",
			#		      markupstring($fileh, $node, $index), # FIXME
			#		      "</pre>");
			#	}
			} else {
				# Check for a discrepancy between file and database states
				if (! LXR::Lang::parseable($pathname, $releaseid)) {
					print(
						"<p class=\"indexstate warning\">\n<i class=error>Warning, </i>$pathname<i class=error> is written in an unsupported language."
						, " File is not indexed.</i>\n</p>\n"
					);
				} else {
					my $t = indextime(@_,  '', $pathname);
					if ('-' eq $t) {
						print(
							"<p class=\"indexstate warning\">\n<i class=error>Warning, file </i>$pathname<i class=error> was not indexed"
							, "\nor was modified since last indexation"
							, " (in which case cross-reference links may be missing, inaccurate or erroneous).</i></p>\n"
						);
					} else {
						print(
							"<p class=indexstate>\nFile indexing completed on $t\n</p>\n"
						);
					}
				}

				if (exists($config->{'cvswebprefix'})) {
					my $revtarget = '';
					$revtarget = "#rev$releaseid" if lc($releaseid) ne 'head';
					print '<a class="cvsweb" href="'
					  . $config->{'cvswebprefix'}
					  . $pathname
					  . $config->{'cvswebpostfix'}
					  . $revtarget
					  . '">View CVS Log</a>';
				}

				# Markup and output the source file
				my $currev = $files->filerev($pathname, $releaseid);
				my $bg = 1;
				my $oldrev;
				my $outfun = sub {
					my $l;
					$l = shift;
					$l =~ s/(\n)/$1.next_annot($currev, \$oldrev, \$bg)/ge;
					print $l;
				};
				print '<pre class="filecontent">';
				markupfile($fileh, $outfun);
				print "</pre>\n";
			}
		} else {
			print(
				"<p class=\"error\">\n<i>The file $pathname does not exist.</i>\n</p>\n"
			);
			if	(  $files->isa('LXR::Files::CVS')
				&& !$HTTP->{'param'}{'_showattic'}
				) {
				print("<p class=\"error\">\n");
				print('<i>This file might exist in other versions,');
				print	( ' try \'Show attic files\' or select a different',
						, $config->{'variables'}{'v'}{'name'}
						, ".</i>\n"
						);
				print("</p>\n");
			}
		}
	}
}


=head2 Script entry point

Selects the correct header and footer and launches C<printfile>
for the real job.

=cut

httpinit;
std_http_headers('source');

if (exists($config->{'filter'}) && $pathname !~ $config->filter) {
	makeheader('source');
	print("<p class=\"error\">\n<i>Filename $pathname is discarded by the present <code>'filter'</code> rule.</i>\n</p>\n");
	makefooter('source');
	exit;
}

# Formerly, if the file was html, it was sent out as is.
# Now, since we want to parse HTML files too, use URL parameter _raw
# to interpret it through the browser, the same as for other files.
if ($HTTP->{'param'}{'_raw'}) {
	printfile(1);
} else {
	my $type = ((substr($pathname, -1) ne '/') ? 'source' : 'sourcedir');

	makeheader($type);
	printfile(0);
	makefooter($type);
}

httpclean;