lxr-commits — Don't use, CVS commits

[Lxr-commits] CVS: lxr/lib/LXR/Files CVS.pm,1.48,1.49

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Files
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv30680/lib/LXR/Files

Modified Files:
	CVS.pm 
Log Message:
CVS.pm: fix for bug #246

Check for rcsdiff version should be done against rcsdiff insted of diff

Index: CVS.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Files/CVS.pm,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -d -r1.48 -r1.49
--- CVS.pm	21 Sep 2013 12:54:52 -0000	1.48
+++ CVS.pm	27 Sep 2013 09:53:25 -0000	1.49
@@ -56,7 +56,7 @@
 
 		# the rcsdiff command (used in getdiff) uses parameters only supported by GNU diff
 		$ENV{'PATH'} = $self->{'path'};
-		if (index (`diff --version 2>/dev/null`, 'GNU') >= 0) {
+		if (index (`rcsdiff --version 2>/dev/null`, 'GNU') >= 0) {
 			$gnu_diff = 1;
 		} else {
 			$gnu_diff = 0;

[Lxr-commits] CVS: lxr/scripts Tagger.pm,1.1,1.2

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/scripts
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv26802/scripts

Modified Files:
	Tagger.pm 
Log Message:
Lang/Generic.pm, scripts/Tagger.pm: remove log printing from parsers

Indexing log printing transfered into Tagger.pm where it logically belongs (also in preparation for future modifications to genxref processing)

Index: Tagger.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/scripts/Tagger.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- Tagger.pm	22 Sep 2012 07:49:17 -0000	1.1
+++ Tagger.pm	24 Sep 2013 15:35:38 -0000	1.2
@@ -85,7 +85,18 @@
 			print(STDERR " ${VTgreen}$fileid${VTnorm} ");
 
 			my $path = $files->realfilename($pathname, $releaseid);
-			$lang->referencefile($pathname, $path, $fileid, $index, $config);
+			
+			print	( STDERR
+					  '+++ '
+					, $lang->referencefile
+						(	$pathname
+						, $path
+						, $fileid
+						, $index
+						, $config
+						)
+					, "\n"
+					);
 			$index->setfilereferenced($fileid);
 			$index->flushcache();
 			$index->commit;

[Lxr-commits] CVS: lxr/lib/LXR/Lang Generic.pm,1.42,1.43

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Lang
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv26802/lib/LXR/Lang

Modified Files:
	Generic.pm 
Log Message:
Lang/Generic.pm, scripts/Tagger.pm: remove log printing from parsers

Indexing log printing transfered into Tagger.pm where it logically belongs (also in preparation for future modifications to genxref processing)

Index: Generic.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Lang/Generic.pm,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -d -r1.42 -r1.43
--- Generic.pm	21 Sep 2013 12:54:53 -0000	1.42
+++ Generic.pm	24 Sep 2013 15:35:38 -0000	1.43
@@ -671,7 +671,7 @@
 		}
 		($btype, $frag) = &LXR::SimpleParse::nextfrag;
 	}
-	print(STDERR "+++ $linenum\n");
+	return $linenum;
 }
 
 

[Lxr-commits] CVS: lxr/scripts VTescape.pm,1.1,1.2

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/scripts
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv26315/scripts

Modified Files:
	VTescape.pm 
Log Message:
scripts/VTescape.pm: more ANSI escape functions

Index: VTescape.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/scripts/VTescape.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- VTescape.pm	22 Sep 2012 08:50:33 -0000	1.1
+++ VTescape.pm	24 Sep 2013 15:24:07 -0000	1.2
@@ -35,7 +35,8 @@
 	$VTred  $VTyellow $VTgreen $VTcyan $VTblue $VTmagenta
 	$VTblack          $VTwhite
 	VTCUU VTCUD VTCUF VTCUB VTCNL VTCPL VTCHA VTCUP
-	VTED  VTEL  VTSU  VTSD  VTHVP
+	VTDL  VTDSR VTED  VTEL  VTHVP VTICH VTIL  VTRCP
+	VTSCP VTSD  VTSSR VTSU
 );
 
 # Some ANSI escape sequences to highlight error messages in output
@@ -55,46 +56,68 @@
 our $VTblack  = "${VTbold}${CSI}30m";
 our $VTwhite  = "${VTbold}${CSI}37m";
 
+# ICH = Insert blank CHaracters
+sub VTICH {
+	my $n = shift;
+	return $CSI
+		. ($n>1 ? $n : '')
+		. '@';
+}
+
 # CUU = CUrsor Up
 sub VTCUU {
 	my $n = shift;
-	return $CSI . $n . 'A';
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'A';
 }
 
 # CUD = CUrsor Down
 sub VTCUD {
 	my $n = shift;
-	return $CSI . $n . 'B';
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'B';
 }
 
 # CUF = CUrsor Forward
 sub VTCUF {
 	my $n = shift;
-	return $CSI . $n . 'C';
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'C';
 }
 
 # CUB = CUrsor Backward
 sub VTCUB {
 	my $n = shift;
-	return $CSI . $n . 'D';
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'D';
 }
 
 # CNL = Cursor beginning of Next Line
 sub VTCNL {
 	my $n = shift;
-	return $CSI . $n . 'E';
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'E';
 }
 
 # CPL = Cursor beginning of Previous Line
 sub VTCPL {
 	my $n = shift;
-	return $CSI . $n . 'F';
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'F';
 }
 
 # CHA = Cursor Horizontal Absolute
 sub VTCHA {
 	my $n = shift;
-	return $CSI . $n . 'G';
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'G';
 }
 
 # CUP = CUrsor Position
@@ -107,26 +130,50 @@
 sub VTED {
 	my $n = shift;
 	$n = 0 if $n > 2;
-	return $CSI . $n . 'J';
+	return $CSI
+		. ($n>0 ? $n : '')
+		. 'J';
 }
 
 # EL = Erase Line (0->EOL, BOL->1, 2:line)
 sub VTEL {
 	my $n = shift;
 	$n = 0 if $n > 2;
-	return $CSI . $n . 'K';
+	return $CSI
+		. ($n>0 ? $n : '')
+		. 'K';
+}
+
+# IL = Insert Lines
+sub VTIL {
+	my $n = shift;
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'L';
+}
+
+# DL = Delete Lines
+sub VTDL {
+	my $n = shift;
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'M';
 }
 
 # SU = Scroll Up
 sub VTSU {
 	my $n = shift;
-	return $CSI . $n . 'S';
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'S';
 }
 
 # SD = Scroll Down
 sub VTSD {
 	my $n = shift;
-	return $CSI . $n . 'T';
+	return $CSI
+		. ($n>1 ? $n : '')
+		. 'T';
 }
 
 # HVP = Horizontal and Vertical Position (= CUP)
@@ -135,6 +182,49 @@
 	return $CSI . $row . ';' . $col . 'f';
 }
 
+# DSR = Device Status Report
+#	Returns: (row, column) of cursor current position
+#
+# CAUTION! may be very Linux specific, portability not tested
+# NOTE: to be used as a function outside any print statement
+sub VTDSR {
+	# Put terminal in transparent mode (otherwise a manual
+	# <return> is necessary to report back the string.
+	# Suppress echo, so that status report is not displayed
+	system('stty -icanon min 1 time 0 -echo');
+	# Cause transmission on last character of status report
+	my $oldinpsep = $/;
+	$/ = 'R';
+	# Better be that STDOUT and STDERR point to the same device!!!
+	print STDERR $CSI, '6n';
+	my $status = <STDIN>;
+	# Revert everything
+	$/ = $oldinpsep;
+	system ('stty icanon echo');
+	$status =~ m/\[(\d+);(\d+)R/;
+	return ($1, $2);
+}
+
+# SSR (non-standardized name) = Set Scrolling Region
+# CAUTION! $top <= $bottom not checked!
+sub VTSSR {
+	my ($top, $bottom) = @_;
+	return $CSI
+		. $top . ';' . $bottom
+		. 'r';
+}
+
+
+# SCP = Save Cursor Position
+sub VTSCP {
+	return $CSI . 's';
+}
+
+# RCP = Restore Cursor Position
+sub VTRCP {
+	return $CSI . 'u';
+}
+
 # SGR = Select Graphic Rendition, see $VTxxx
 
 

[Lxr-commits] CVS: lxr genxref,1.66,1.67

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv26147

Modified Files:
	genxref 
Log Message:
genxref: upgrade to tree designation variants and new features

Take into account the new tree designation variants
New test on ctags (against Ubuntu shortcoming)
Use a cleanly separated global configuration section
New 'magicmime' configuration parameter
Generate a .glimpse_exclude file for glimpseindex to try and scan the same files as LXR
Various Perl syntax optimisations

Index: genxref
===================================================================
RCS file: /cvsroot/lxr/lxr/genxref,v
retrieving revision 1.66
retrieving revision 1.67
diff -u -d -r1.66 -r1.67
--- genxref	7 Dec 2012 12:27:35 -0000	1.66
+++ genxref	24 Sep 2013 15:21:36 -0000	1.67
@@ -37,18 +37,19 @@
 use VTescape;
 use Tagger;
 
-my $lxrconf = 'lxr.conf';	# TODO: allow override through an option
+my $lxrconf = $LXR::Config::confname;	# TODO: allow override through an option
 
 my %option;
 GetOptions	(\%option
-			, "help!"
-			, "url=s"
-			, "version=s"
-			, "allurls"
-			, "allversions:s"
-			, "reindexall"
-			, "checkonly"
-			, "accept"
+			, 'help!'
+			, 'url=s'
+			, 'tree=s'
+			, 'version=s'
+			, 'allurls'
+			, 'allversions:s'
+			, 'reindexall'
+			, 'checkonly'
+			, 'accept'
 			);
 
 if ($option{'help'}) {
@@ -67,6 +68,8 @@
 Valid options are:
   --help             Print a summary of the options.
   --url=URL          Generate tokens for the given URL configuration block.
+  --tree=TREE_NAME   To be used in addition to --url in multiple-trees context
+                     if LXR configured to identify trees through 'argument'.
   --allurls          Generate tokens for all URL configuration blocks.
   --version=VERSION  Generate tokens for the given version of the code.
   --allversions      Generate tokens for all versions of the code (default).
@@ -100,6 +103,7 @@
 sub readfile {}
 
 my @config;
+my $global;		# Global section in configuration file
 if (open(CONFIG, $lxrconf)) {
 	my $oldsep = $/;
 	$/ = undef;
@@ -111,7 +115,7 @@
 	@config = eval("\n#line 1 \"configuration file\"\n" . $config_contents);
 	die($@) if $@;
 
-	$config = shift(@config);
+	$global = shift(@config);	# Global parameters
 } else {
 	print "${VTred}ERROR:${VTnorm} could not open configuration file ${VTred}$lxrconf${VTnorm}\n";
 	exit(1) unless $option{'checkonly'};
@@ -144,19 +148,19 @@
 #	.	2	everything fine
 
 sub check_tool {
-	my ($tl_param, $tl_name, $tl_option, $tl_version) = @_;
+	my ($tl_param, $tl_name, $tl_option, $tl_version, $name_constraint) = @_;
 	my $tool;
 	my $toolloc;
 	my $toolforced = 0;
 	my $version;
 
-	if ($config && $config->{$tl_param}) {
-		$tool = $config->{$tl_param};
+	if ($global && $global->{$tl_param}) {
+		$tool = $global->{$tl_param};
 			# Make further tests on designated tool
 		$toolloc = `command -v $tool 2>/dev/null`;
 		if ($toolloc !~ s/\n$//s) {
 			print "${VTred}'$tl_param' does not name an existing $tl_name utility${VTnorm}\n";
-			delete $config->{$tl_param};
+			delete $global->{$tl_param};
 		} else {
 			my $systoolloc = `command -v $tl_name 2>/dev/null`;
 			if ($systoolloc =~ s/\n$//s) {
@@ -175,14 +179,14 @@
 	}
 	if (!$toolloc) {
 		print "${VTred}$tl_name not found,${VTnorm} `command -v $tl_name` returned a null string\n";
-		if ($config) {
-			delete $config->{$tl_param};
+		if ($global) {
+			delete $global->{$tl_param};
 		}
 		return 0;
 	}
-	if ($config) {
-		if (!$config->{$tl_param}) {
-			$config->{$tl_param} = $toolloc;
+	if ($global) {
+		if (!$global->{$tl_param}) {
+			$global->{$tl_param} = $toolloc;
 			$toolforced = 1;
 			$tool = $toolloc;
 			print "$tl_name found at ${VTyellow}$toolloc${VTnorm}\n";
@@ -196,8 +200,15 @@
 	my $nmwidth = 14;
 	print "Checking", ' 'x(($nmwidth-length($tl_name)+1)/2);
 	print $tl_name, ' 'x(($nmwidth-length($tl_name))/2);
-	print "version ... ";
 	$version = `$tool $tl_option`;
+	if 	(	defined($name_constraint)
+		&&	$version !~ $name_constraint
+		) {
+		print "name constraint  ... $name_constraint\n";
+		print VTCUU(1), "${VTred}[${VTslow}FAILED${VTnorm}${VTred}]${VTnorm}\n";
+		return -1 - $toolforced;
+	}
+	print "version ... ";
 	if ($version =~ m/.*$tl_name .*?((\d+\.)*\d+)/i) {
 		$version = $1;
 	} else {
@@ -223,7 +234,11 @@
 my $foundglimpse = 0;
 my $foundswishe = 0;
 
-my $ct = check_tool('ectagsbin', 'ctags', '--version', '5');
+my $ct = check_tool	( 'ectagsbin'
+					, 'ctags'
+					, '--version', '5'
+					, qr/exuberant/i
+					);
 if ($ct == 0) {
 	print "genxref can't index source-tree without ctags\n";
 	print "Find its location or install it and fix 'ectagsbin'\n";
@@ -246,8 +261,8 @@
 	# No engine defined - propose to go on without
 	print "${VTyellow}Neither 'glimpsebin' nor 'swishbin' defined${VTnorm}\n";
 	print "${VTyellow}Disabling free-text search${VTnorm}\n";
-	if ($config) {
-		$config->{'glimpsebin'} = '/usr/bin/true';
+	if ($global) {
+		$global->{'glimpsebin'} = '/usr/bin/true';
 	}
 	$failure |= 2;
 } elsif ($foundglimpse == 2 && $foundswishe == 2) {
@@ -260,10 +275,10 @@
 	# (either not found or version too low)
 	# But check if user disabled free-text search with suggested tip
 	if	(	$foundglimpse < 0	# true has no version
-			&& $config->{'glimpsebin'} =~ m:(^|/)true$:
+			&& $global->{'glimpsebin'} =~ m:(^|/)true$:
 			&& $foundswishe == 0
 		||	$foundswishe < 0
-			&& $config->{'swishbin'} =~ m:(^|/)true$:
+			&& $global->{'swishbin'} =~ m:(^|/)true$:
 			&& $foundglimpse == 0
 		) {
 	#	Leave $failure "as is" when user disables search
@@ -273,19 +288,19 @@
 } elsif ($foundglimpse == 1 && $foundswishe <= 1) {
 	# glimpse has been forced, but glimpse is prefered if both
 	print "${VTyellow}Warning:${VTnorm} using existing ${VTbold}glimpse${VTnorm}\n";
-	delete $config->{'swishbin'} if ($config);
+	delete $global->{'swishbin'} if ($global);
 	$failure |= 2;
 } elsif ($foundswishe == 1 && $foundglimpse <= 0) {
 	# swish-e has been forced, but glimpse is prefered if both
 	print "${VTyellow}Warning:${VTnorm} using existing ${VTbold}swish-e${VTnorm}\n";
-	delete $config->{'glimpsebin'} if ($config);
+	delete $global->{'glimpsebin'} if ($global);
 	$failure |= 2;
 } elsif ($foundglimpse == 2) {
 	# Standard glimpse selection, but for the case of both
 	# engines present and swish-e has too low a version
 	if ($foundswishe == -1) {
 		print "${VTyellow}Warning:${VTnorm} forcing use of ${VTbold}glimpse${VTnorm}\n";
-		delete $config->{'swishbin'} if ($config);
+		delete $global->{'swishbin'} if ($global);
 		$failure |= 2;
 	}
 } elsif ($foundswishe == 2) {
@@ -293,7 +308,7 @@
 	# engines present and glimpse has too low a version
 	if ($foundglimpse == -1) {
 		print "${VTyellow}Warning:${VTnorm} forcing use of ${VTbold}swish-e${VTnorm}\n";
-	delete $config->{'glimpsebin'} if ($config);
+	delete $global->{'glimpsebin'} if ($global);
 		$failure |= 2;
 	}
 }
@@ -336,25 +351,40 @@
 my $repeatbannerevery = 25;
 my $repeatbannercountdown = $repeatbannerevery;
 
-our $filetype = File::MMagic->new(-f 'lib/magic.mime'? ('lib/magic.mime') : ());
+my $magicfile = $global->{'magicmime'};
+our $filetype = File::MMagic->new
+		( -f $magicfile ? ($magicfile)
+		: -f 'lib/magic.mime'? ('lib/magic.mime') : ()
+		);
 
-my $hostname = $config->{'host_names'}[0];
+my $hostname = $global->{'host_names'}[0];	# Global host name
 if ($option{'url'}) {	# Single 'url'
 	@config = (1);		# Fake list to prevent looping
 }
 
+#	Loop on tree sections (global section already removed)
 foreach my $treedescr (@config) {
 	my $url;
-	if ($option{'url'}) {
-		$url = $option{'url'};
-		$config = LXR::Config->new($url);
+	my $host;
+	my $virtroot;
+	if ($url = $option{'url'}) {
+		($host, $virtroot) = $url =~ m!^(.*//[^/]+)(/.*)?!;
+		$config = LXR::Config->new	( $host
+									, $virtroot
+									, $option{'tree'}
+									);
 	} else {
 		if (defined($hostname)) {
-			$url = $hostname . $treedescr->{'virtroot'};
+			$host = $hostname;
+			$virtroot = $treedescr->{'virtroot'} // $global->{'virtroot'};
 		} else {
-			$url = $treedescr->{'baseurl'};
+			($host, $virtroot)
+				= $treedescr->{'baseurl'} =~ m!^(.*//[^/]+)(/.*)?!;
 		}
-		$config = LXR::Config->new($url);
+		$config = LXR::Config->new	( $host
+									, $virtroot
+									, $treedescr->{'treename'}
+									);
 		print STDERR "\n${CSI}44m${VTwhite}Processing $url${VTnorm}\n";
 	}
 
@@ -372,10 +402,14 @@
 			. " - Can't run${VTnorm}\n";
 	}
 
-	$files = LXR::Files->new($$config{'sourceroot'}, $$config{'sourceparams'});
-	die "${VTred}Can't create file access object ${VTnorm}" . $$config{'sourceroot'}
+	$files = LXR::Files->new	( $config->{'sourceroot'}
+								, $config->{'sourceparams'}
+								);
+	die "${VTred}Can't create file access object ${VTnorm}" . $config->{'sourceroot'}
 		if !defined($files);
-	$index = LXR::Index->new($config->{'dbname'}, O_RDWR | O_CREAT);
+	$index = LXR::Index->new	( $config->{'dbname'}
+								, $config->{'dbprefix'}
+								);
 	die "${VTred}Can't create Index ${VTnorm}" . $config->{'dbname'}
 		if !defined($index);
 
@@ -387,8 +421,8 @@
 
 
 	if (exists($option{'allversions'}) || !exists($option{'version'})) {
-		if	(  $files->isa("LXR::Files::CVS")
-			&& ref($config->{'variables'}{'v'}{'range'}) eq "CODE"
+		if	(  $files->isa('LXR::Files::CVS')
+			&& ref($config->{'variables'}{'v'}{'range'}) eq 'CODE'
 			) {
 			print STDERR "Using automatic CVS version enumeration\n";
 			$autoversionflag = 1;
@@ -403,7 +437,7 @@
 	}
 
 	%versionset = ();
-	if ($files->isa("LXR::Files::CVS") && scalar(@versions)<=0) {
+	if ($files->isa('LXR::Files::CVS') && scalar(@versions)<=0) {
 		$index->purgeall;
 		$$LXR::Common::HTTP{'param'}{'_showattic'} = 1;
 		$printdirbanner = 1;
@@ -419,9 +453,9 @@
 								, '/'
 								);
 		if ( exists($option{'allversions'})
-			&& $option{'allversions'} ne "noauto"
+			&& $option{'allversions'} ne 'noauto'
 			) {
-			dump_versionset("CVS", \%versionset);
+			dump_versionset('CVS', \%versionset);
 		}
 
 	} else {
@@ -436,7 +470,7 @@
 		my $docareful = 0;
 		if (exists($option{'reindexall'})) {
 			if	( exists($option{'allversions'})
-				|| exists($option{'version'}) && (1 == $config->varrange('v'))
+		# 		|| exists($option{'version'}) && (1 == $config->varrange('v'))
 				|| !exists($option{'version'})
 				) {
 				$index->purgeall;
@@ -449,7 +483,7 @@
 
 		foreach my $version (@versions) {
 			print STDERR "\n${CSI}44m${VTwhite}Processing $url ${VTnorm}"
-					, " == "
+					, ' == '
 					, "${CSI}41m${VTwhite}Version $version ${VTnorm}\n" ;
 			if ($dopurge) {
 				print STDERR "\nSelective database purge ... ${VTyellow}${VTslow}in progress${VTnorm}\n";
@@ -459,7 +493,7 @@
 			if ($docareful) {
 				cleanindex($version);
 			}
-			if ($files->isa("LXR::Files::Plain")) {
+			if ($files->isa('LXR::Files::Plain')) {
 				if ($foundglimpse > 0 || $foundswishe > 0) {
 					gensearch($version);
 				} else {
@@ -500,7 +534,7 @@
 	my ($head, $releaseid, $dirname, $filename) = @_;
 	my $editpos = 3 + length($head) + length($releaseid) + length($dirname);
 
-	if ($printdirbanner ) {
+	if ($printdirbanner) {
 		print(STDERR "${VTmagenta}$head $releaseid $dirname");
 		$printdirbanner = undef;
 	} else {
@@ -514,19 +548,17 @@
 	my ($process_sub, $releaseid, $dirname, $filename) = @_;
 	my $pathname = $dirname . $filename;
 
-	if ($filename =~ m|/$|) {
+	if (substr($filename, -1) eq '/') {
 		dirbannerprint('***', $releaseid, $dirname, $filename);
 		my $needbanner;
 		map {	my $node = $_;
 				my $type = substr($node, -1);
 				$needbanner //= $type eq '/';
 				if	(	$type ne '/'
-					&&	(  $needbanner && $printdirbanner
-# 						|| $repeatbannercountdown <= 0
-						)
+					&&	$needbanner
 					) {
-					$needbanner = undef;# if $repeatbannercountdown <=0;
-					dirbannerprint("***", $releaseid, $dirname, $filename);
+					$needbanner = undef;
+					dirbannerprint('***', $releaseid, $dirname, $filename);
 				}
 				directorytreetraversal	( $process_sub
 										, $releaseid
@@ -535,7 +567,7 @@
 										);
 			} $files->getdir($pathname, $releaseid);
 		$index->forcecommit();
-	} elsif (!exists  $binaryfiles{$pathname}) {
+	} elsif (!exists $binaryfiles{$pathname}) {
 		my $didprocess;
 		if	($autoversionflag) {
 		# Some 'Files' objects need this variable properly set to
@@ -546,7 +578,7 @@
 			foreach my $releaseid (@versions) {
 				if ($repeatbannercountdown <=0) {
 					$printdirbanner = 1;
-					dirbannerprint("***", $releaseid, $dirname, '');
+					dirbannerprint('***', $releaseid, $dirname, '');
 				}
 				$versionset{$releaseid} = '';	# remember this version
 				my $didoneprocess = &$process_sub($pathname, $releaseid, $config, $files, $index);
@@ -556,7 +588,7 @@
 		} else {
 			if ($repeatbannercountdown <=0) {
 				$printdirbanner = 1;
-				dirbannerprint("***", $releaseid, $dirname, '');
+				dirbannerprint('***', $releaseid, $dirname, '');
 			}
 			$didprocess = &$process_sub($pathname, $releaseid, $config, $files, $index);
 			$repeatbannercountdown-- if $didprocess;
@@ -568,7 +600,7 @@
 sub feedswish {
 	my ($pathname, $releaseid, $swish, $filelist) = @_;
 
-	if ($pathname =~ m|/$|) {
+	if (substr($pathname, -1) eq '/') {
 		print(STDERR "&&& $pathname $releaseid \n");
 		map { feedswish($pathname . $_, $releaseid, $swish, $filelist) }
 		  $files->getdir($pathname, $releaseid);
@@ -580,12 +612,12 @@
 				print(STDERR "&&> $pathname $releaseid \n");
 				print $filelist "$pathname\n";
 				my $contents = $files->getfile($pathname, $releaseid);
-				$swish->print(
-					"Path-Name: $pathname\n",
-					"Content-Length: " . length($contents) . "\n",
-					"Document-Type: TXT\n",
-					"\n", $contents
-				);
+				$swish->print
+					( "Path-Name: $pathname\n"
+					, 'Content-Length: ' . length($contents) . "\n"
+					, "Document-Type: TXT\n"
+					, "\n", $contents
+					);
 			} else {
 				$binaryfiles{$pathname} = 1;
 			}
@@ -600,44 +632,63 @@
 
 	if ($config->{'glimpsedir'} && $config->{'glimpseindex'}) {
 
-		$string = $config->glimpsedir . "/" . $releaseid;
+		$string = $config->{'glimpsedir'} . '/' . $releaseid;
 		mkdir $string;
 		system("chmod 755 $string");   # TODO - fix Unix specific call?
+		# Create the exclusion file only if it does not exist
+		$string .= '/.glimpse_exclude';
+		if	(	exists($config->{'ignoredirs'})
+			&&	!-e $string
+			) {
+			if (open (EXCLUDE, '>', $string)) {
+				foreach (@{$config->{'ignoredirs'}}) {
+					print EXCLUDE '/', $_, "/\n"
+				}
+				close(EXCLUDE);
+			} else {
+				print STDERR $VTred , "Can't create "
+					, $VTnorm, $VTbold, $string
+					, $VTnorm, "\n"
+					, $VTyellow, 'No automatic directory exclusion from parameter'
+					, $VTnorm, $VTbold, "'ignoredirs'"
+					, $VTnorm, "\n";
+			}
+		}
 		my $glimpse = IO::Handle->new();
-		my $pid = open($glimpse, "|-");
+		my $pid = open($glimpse, '|-');
 		if ($pid == 0) {
-			exec($config->glimpseindex, "-n", "-o", "-H",
-				$config->glimpsedir . "/$releaseid",
-				$config->sourceroot . "/" . $releaseid
-			);
-			print(STDERR "Couldn't exec " . $config->glimpseindex . ": $!\n");
+			exec( $config->{'glimpseindex'}
+				, '-n', '-o', '-H'
+				, $config->{'glimpsedir'} . '/' . $releaseid
+				, $config->{'sourceroot'} . '/' . $releaseid
+				);
+			print(STDERR "Couldn't exec " . $config->{'glimpseindex'} . ": $!\n");
 			kill(9, $$);
 		}
 		$glimpse->close();
 
 		# Need to chmod the glimpse files so everybody can read them.
-		$string = $config->glimpsedir . "/" . $releaseid . "/.glimpse\*";
+		$string = $config->{'glimpsedir'} . '/' . $releaseid . '/.glimpse*';
 		system("chmod 644 $string");
 	}
 
 	if ($config->{'swishdir'} && $config->{'swishbin'}) {
 		my $swish = IO::Handle->new();
-		die ${VTred} . $config->swishdir . " does not exist${VTnorm}"
-			unless -d $config->swishdir;
-		my $filelist = IO::File->new($config->swishdir . "/$releaseid.filenames", "w")
+		die ${VTred} . $config->{'swishdir'} . " does not exist${VTnorm}"
+			unless -d $config->{'swishdir'};
+		my $filelist = IO::File->new($config->{'swishdir'} . "/$releaseid.filenames", 'w')
 		  or die "${VTred}can't open $releaseid.filenames for writing${VTnorm}";
 
 		# execute swish, as a pipe we can write to
 
-		open($swish,
-			    "| "
-			  . $config->swishbin
-			  . " -S prog -i stdin -v 1 -c ".$config->{'swishconf'}
-			  . " -f ".$config->swishdir."/".$releaseid.".index"
+		open( $swish
+			, '|' . $config->{'swishbin'}
+			  . ' -S prog -i stdin -v 1 -c '.$config->{'swishconf'}
+			  . ' -f '.$config->{'swishdir'}.'/'.$releaseid.'.index'
 			)
-		  or die ${VTred} . "Couldn't exec " . $config->swishbin . ":${VTnorm $!}\n";
+		  or die ${VTred} . "Couldn't exec " . $config->{'swishbin'} . ":${VTnorm $!}\n";
 
-		feedswish("/", $releaseid, $swish, $filelist);
+		feedswish('/', $releaseid, $swish, $filelist);
 
 		$swish->close();
 		$filelist->close();
@@ -648,10 +699,10 @@
 	my ($prefix, $versionset) = @_;
 	my $vfh;
 
-	my $virtroot = $config->{'virtroot'};
-	$virtroot =~ s|([^-a-zA-Z0-9.\@_])|sprintf("%%%02X", ord($1))|ge;
-	my $versionfile = "custom.d/$prefix$virtroot";
-	if (!open($vfh, ">", $versionfile)) {
+	my $treeid = $config->{'virtroot'} . '_' . $config->{'treename'};
+	$treeid =~ s|([^-a-zA-Z0-9.\@_])|sprintf('%%%02X', ord($1))|ge;
+	my $versionfile = 'custom.d/'.$prefix.$treeid;
+	if (!open($vfh, '>', $versionfile)) {
 		print "${VTyellow}Can't open : version set not saved${VTnorm}\n";
 		return;
 	}
@@ -687,7 +738,7 @@
 
 	$index->getallfilesinit($releaseid);
 	while (my ($fid, $pathname, $revision, $relcount) = $index->nextfile()) {
-		next if $files->filerev($pathname, $releaseid) == $revision;
+		next if $files->filerev($pathname, $releaseid) eq $revision;
 		$pathname =~ m!(.*/)(.+)$!;
 		$filename = $2;
 		if ($dirname ne $1) {

[Lxr-commits] CVS: lxr/lib/LXR/Lang generic.conf,1.39,1.40

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Lang
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv10665/lib/LXR/Lang

Modified Files:
	generic.conf 
Log Message:
generic.conf: HTML, JAVA, Make, Pascal, PHP, Python, Ruby include keyword recognition improvement

Also, various Perl syntax optimisations

Index: generic.conf
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Lang/generic.conf,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -d -r1.39 -r1.40
--- generic.conf	19 Apr 2013 12:42:14 -0000	1.39
+++ generic.conf	24 Sep 2013 10:10:10 -0000	1.40
@@ -8,19 +8,19 @@
 
 	# Options to always feed to ectags
 	'ectagsopts' =>
-		[ "--options=" . $config->ectagsconf
-		, "--c-types=+plx"
-		, "--eiffel-types=+l"
-		, "--fortran-types=+L",
+		[ '--options=' . $config->{'ectagsconf'}
+		, '--c-types=+plx'
+		, '--eiffel-types=+l'
+		, '--fortran-types=+L'
 		]
 
 	# How to map a language name to the ectags language-force name
 	# if there is no mapping, then the language name is used
 ,	'eclangnamemapping' =>
-		{ 'C'      => 'c'		# not necessary as ctags
-		, 'C++'    => 'c++'		# seems to take language
-		, 'Python' => 'python'	# names case-insensitive
-		, 'SQL'    => 'SQL2'	# -- ctags processing replaced by regexp
+# 		{ 'C'      => 'c'		# not necessary as ctags
+# 		, 'C++'    => 'c++'		# seems to take language
+# 		, 'Python' => 'python'	# names case-insensitive
+		{ 'SQL'    => 'SQL2'	# -- ctags processing replaced by regexp
 								#    (see ectags.conf)
 			# NOTE: language description is not case-insensitive and
 			#		makes assumptions about layout of declarations.
@@ -110,8 +110,8 @@
 			[ { 'comment'	=> [ '/\*',         '\*/'] }
 			# Does not address "line comment" since syntax is target-specific
 			, { 'string'	=> [ '"',           '"',   '\\\\.' ] }
-			, { 'string'	=> [ "'\\\\?." ] }
-			, { 'include'	=> [ '#\s*include', "\$" ] }
+			, { 'string'	=> [ "'\\\\?.'" ] }
+			, { 'include'	=> [ '#\s*include\b', '$' ] }
 			]
 		, 'typemap' =>
 			{ 'd' => 'define'
@@ -172,11 +172,11 @@
 # 			bindtextdomain	dcgettext	dcngettext
 # 		--- End of built-in list ---
 		, 'spec' =>
-			[ { 'comment'	=> [ '#',         "\$" ] }
+			[ { 'comment'	=> [ '#',         '$' ] }
 			, { 'string'	=> [ '"',         '"',   '\\\\.' ] }
 			, { 'string'	=> [ '/',         '/',   '\\\\.' ] }
 				# for regexps in fact
-			, { 'include'	=> [ '@include', "\$" ] }
+			, { 'include'	=> [ '@include\b', '$' ] }
 			]
 		, 'include' =>
 			{ 'directive' => '(@include)(\s+)(")((?:\\\\.|.)+)(")'
@@ -235,10 +235,10 @@
 						) ]
 		, 'spec' =>
 			[ { 'comment'	=> [ '/\*',         '\*/'] }
-			, { 'comment'	=> [ '//',          "\$" ] }
+			, { 'comment'	=> [ '//',          '$' ] }
 			, { 'string'	=> [ '"',           '"',   '\\\\.' ] }
 			, { 'string'	=> [ "'",           "'",   "\\\\." ] }
-			, { 'include'	=> [ '#\s*include', "\$" ] }
+			, { 'include'	=> [ '#\s*include\b', '$' ] }
 			]
 		,	'typemap' =>
 			{ 'c' => 'class'
@@ -293,10 +293,10 @@
 						) ]
 		, 'spec' =>
 				[ { 'comment'	=> [ '/\*',         '\*/'] }
-				, { 'comment'	=> [ '//',          "\$" ] }
+				, { 'comment'	=> [ '//',          '$' ] }
 				, { 'string'	=> [ '"',           '"',   '\\\\.' ] }
 				, { 'string'	=> [ "'",           "'",   "\\\\." ] }
-				, { 'include'	=> [ '#\s*include', "\$" ] }
+				, { 'include'	=> [ '#\s*include\b', '$' ] }
 				]
 		, 'typemap' =>
 			{ 'c' => 'class'
@@ -471,7 +471,7 @@
 			ZERO ZEROES ZEROS
 						) ]
 		, 'spec' =>
-			[ { 'comment'	=> [ '^[\d ]*\*', '$' ] }
+			[ { 'comment'	=> [ '^[\d ]*\\*', '$' ] }
 			, { 'string'	=> [ '"',         '"' ] }
 			]
 		, 'typemap' =>
@@ -592,7 +592,7 @@
 		}
 	,
 		'HTML' =>		# HTML 4.01 only
-		{ 'identdef' => '[a-zA-Z][\w]*'
+		{ 'identdef' => '[a-zA-Z]\w*'
 		, 'flags' => [ 'case_insensitive' ]
 		, 'reserved' => [ qw(
 			a        abbr    acronym  address applet
@@ -628,19 +628,12 @@
 			[ { 'comment'	=> [ '<!--', '-->'] }
 			, { 'string' 	=> [ '"',    '"' ] }
 			, { 'string' 	=> [ "'",    "'" ] }
-			, { 'include'	=> [ '(?:href|longdesc|src)="', '"' ] }
-			, { 'include'	=> [ "(?:href|longdesc|src)='", "'" ] }
+			, { 'include'	=> [ '\b(?:href|longdesc|src)="', '"' ] }
+			, { 'include'	=> [ "\b(?:href|longdesc|src)='", "'" ] }
 		# The next one for HTML character entity, but UNSAFE
 		# because & can be found in unprotected query strings
-			, { 'string' 	=> [ "&",    ";" ] }
+			, { 'string' 	=> [ '&',    ';' ] }
 			]
-		, 'include' =>
-			{ 'directive' => '(\w+=)()("|\')(.+)("|\')'
-			, 'global' =>	[ '&quot;', '"'
-							, '&#34',      '"', '&#39',      "'"
-							, '(?i)&#x22', '"', '(?i)&#x27', "'"
-							]
-			}
 		, 'typemap'  =>
 			{ 'a' => 'named anchor'
 			, 'f' => 'JavaScript function'
@@ -676,11 +669,11 @@
 						)]
 		, 'spec' =>
 			[ { 'comment'	=> [ '/\*',     '\*/'] }
-			, { 'comment'	=> [ '//',      "\$" ] }
+			, { 'comment'	=> [ '//',      '$' ] }
 			, { 'string' 	=> [ '"',       '"', '\\\\.' ] }
 			, { 'string' 	=> [ "'",       "'", "\\\\." ] }
-			, { 'include'	=> [ 'import',  ";" ] }
-			, { 'include'	=> [ 'package', ";" ] }
+			, { 'include'	=> [ '\bimport\b',  ';' ] }
+			, { 'include'	=> [ '\bpackage\b', ';' ] }
 			]
 		, 'typemap' =>
 			{ 'c' => 'class'
@@ -728,7 +721,7 @@
 						) ]
 		, 'spec' =>
 			[ { 'comment'	=> [ '/\*',     '\*/'] }
-			, { 'comment'	=> [ '//',      "\$" ] }
+			, { 'comment'	=> [ '//',      '$' ] }
 			, { 'string' 	=> [ '"',       '"', '\\\\.' ] }
 			, { 'string' 	=> [ "'",       "'", "\\\\." ] }
 			]
@@ -784,10 +777,10 @@
 			call      eval      value
 						) ]
 		, 'spec'     =>
-			[ { 'comment'	=> [ '#', "\$"] }
+			[ { 'comment'	=> [ '#', '$'] }
 			, { 'string'	=> [ '"', '"' ] }
 			, { 'string'	=> [ "'", "'" ] }
-			, { 'include'	=> [ '[s-]?include\s', '\$'] }
+			, { 'include'	=> [ '(\bs|-)?include\s', '$'] }
 			]
 	# Multiple inclusion is handled in the specific parser.
 		, 'typemap' => { 'm' => 'macro' }
@@ -847,12 +840,8 @@
 			, { 'comment'	=> [ '\\(\\*', '\\*\\)' ] }
 			, { 'comment'	=> [ '//', '$' ] }
 			, { 'string'	=> [ "'", "'" ] }
-			, { 'include'	=> [ 'uses', ';' ] }
+			, { 'include'	=> [ '\buses\b', ';' ] }
 			]
-		, 'include' =>
-			{ 'directive' => '([\w]+)(\s+)()([\w]+)()'
-			, 'post'   => [ '\$', '.pas' ]
-			}
 		, 'typemap' =>
 			{ 'f' => 'function'
 			, 'p' => 'procedure'
@@ -952,31 +941,33 @@
 			[ { 'atom'	=>	 '(?:\$#?\w+'
 							.'|\\\\.'
 							.'|\b(s|tr|y)\b\s*'
-								.'(?:(?:\{(?:\\\\.|.)*?\}){2}'
-								.'|(?:\[(?:\\\\.|.)*?\]}){2}'
-								.'|(?:\((?:\\\\.|.)*?\)){2}'
-								.'|(?:\<(?:\\\\.|.)*?\>){2}'
+								.'(?:(?:\\{(?:\\\\.|.)*?\\}){2}'
+								.'|  (?:\\[(?:\\\\.|.)*?\\]}){2}'
+								.'|  (?:\\((?:\\\\.|.)*?\\)){2}'
+								.'|  (?:\\<(?:\\\\.|.)*?\\>){2}'
 								.'|(.)(?:(?:\\\\.|.)*?\g{-1}){2}'
 								.')'
 							.'|\b(q[qrwx]?|m)\b\s*'
-								.'(?:\{(?:\\\\.|.)*?\}'
-								.'|\[(?:\\\\.|.)*?\]'
-								.'|\((?:\\\\.|.)*?\)'
-								.'|\<(?:\\\\.|.)*?\>'
-								.'|(.)(?:\\\\.|.)*?\g{-1}'
+								.'(?:\\{(?:\\\\.|.)*?\\}'
+								.'|  \\[(?:\\\\.|.)*?\\]'
+								.'|  \\((?:\\\\.|.)*?\\)'
+								.'|  \\<(?:\\\\.|.)*?\\>'
+								.'|(.)(?:\\\\.|.)*?\\g{-1}'
 								.')'
 							.')' }
 	# NOTE:	This complicated 'atom' is an attempt not to lose control
 	#		through quote and regexp operators. It is not 100%
 	#		bullet-proof. It can't handle nested m{ {...} } for instance.
+	# NOTE 2: It does not work if the regular expressions and/or replacements
+	#		extend on several lines (as is frequently the case with /x modifier.
 
 			, { 'include'	=> ['\buse\s+',     ';'] }
 			, { 'include'	=> ['\brequire\s+', ';'] }
 			, { 'string'	=> ['"',            '"',      '\\\\.'] }
 			, { 'string'	=> ["'",            "'",      "\\\\."] }
 			, { 'string'	=> ['\\`',          '\\`',    '\\\\.'] }
-			, { 'comment'	=> ['#',            "\$"] }
-			, { 'comment'	=> ["^=\\w+",       "^=cut"] }
+			, { 'comment'	=> ['#',            '$'] }
+			, { 'comment'	=> ['^=\w+',       '^=cut'] }
 			]
 	# The following include rules are more efficiently implemented
 	# in the Perl.pm module. They are shown as an example of
@@ -1056,17 +1047,17 @@
 			self      parent
 						) ]
 		, 'spec' =>
-			[ { 'comment'	=> [ '/\\*',         '\*/' ] }
-			, { 'comment'	=> [ '//',           "\$" ] }
-			, { 'comment'	=> [ '#',            "\$" ] }
+			[ { 'comment'	=> [ '/\*',         '\*/' ] }
+			, { 'comment'	=> [ '//',           '$' ] }
+			, { 'comment'	=> [ '#',            '$' ] }
 			# TODO: Heredoc and Nowdoc if it makes sense
 			#		to consider them comments
 			, { 'string'	=> [ '"',            '"', '\\\\.' ] }
 			, { 'string'	=> [ "'",            "'", '\\\\.' ] }
-			, { 'include'	=> [ 'require',      "\$" ] }
-			, { 'include'	=> [ 'include',      "\$" ] }
-			, { 'include'	=> [ 'require_once', "\$" ] }
- 			, { 'include'	=> [ 'include_once', "\$" ] }
+			, { 'include'	=> [ '\brequire\b',      '$' ] }
+			, { 'include'	=> [ '\binclude\b',      '$' ] }
+			, { 'include'	=> [ '\brequire_once\b', '$' ] }
+ 			, { 'include'	=> [ '\binclude_once\b', '$' ] }
 			],
 		, 'include' =>
 			{ 'directive' => '([\w]+)(\s*)(\\(\\s*[\'"])([^\'"]+)("\\s*\\))'
@@ -1104,13 +1095,13 @@
 			yield
 						) ]
 		, 'spec' =>
-			[ { 'comment'	=> [ '#',   "\$" ] }
+			[ { 'comment'	=> [ '#',   '$' ] }
 			, { 'string'	=> [ '"""', '"""', '\\\\.' ] }
 			, { 'string'	=> [ "'''", "'''", "\\\\." ] }
 			, { 'string'	=> [ '"',   '"',   '\\\\.' ] }
 			, { 'string'	=> [ "'",   "'",   "\\\\." ] }
-			, { 'include'	=> [ '\bimport\b', "\$" ] }
-			, { 'include'	=> [ '\bfrom\b',   "\$" ] }
+			, { 'include'	=> [ '\bimport\b', '$' ] }
+			, { 'include'	=> [ '\bfrom\b',   '$' ] }
 			]
 	# Include rules implemented in Python.pm to cope with an
 	# endlessly looping case under 'include' patterns.
@@ -1156,8 +1147,8 @@
 			__FILE__ __LINE__
 						) ]
 		, 'spec' =>
-			[ { 'comment'	=> [ '^=begin',  '^=end'] }
-			, { 'comment'	=> [ '#',       "\$"] }
+			[ { 'comment'	=> [ '^=begin\b',  '^=end\b'] }
+			, { 'comment'	=> [ '#',       '$'] }
 			, { 'string' 	=> [ '"',       '"'
 					, '\\\\(?:(?:[CM]-|c)[^\\\\]?|\$|.)' ] }
 			, { 'string' 	=> [ "'",       "'"
@@ -1165,17 +1156,16 @@
 			, { 'string' 	=> [ '\\`',     '\\`'
 					, '\\\\(?:(?:[CM]-|c)[^\\\\]?|\$|.)' ] }
 			# The following def does not handle nested construct
-			, { 'string' 	=>	[ '\%[qQrs]?'
-								. '(?:\\([^(]*?\\)'
-								. '|\\[[^(]*?\\]'
-								. '|\\{[^(]*?\\}'
-								. '|\\<[^(]*?\\>'
- 								. '|([\W]).*?\g{-1}'
-								. ')'
-							   ] }
+			, { 'string' 	=> [ '\%[iIqQrswW]?\\(', '\\)', '\\\\.' ] }
+			, { 'string' 	=> [ '\%[iIqQrswW]?\\[', '\\]', '\\\\.' ] }
+			, { 'string' 	=> [ '\%[iIqQrswW]?\\{', '\\}', '\\\\.' ] }
+			, { 'string' 	=> [ '\%[iIqQrswW]?\\<', '\\>', '\\\\.' ] }
+			, { 'string' 	=> [ '\%[iIqQrswW]?'
+								. '([\W]).*?\g{-1}'
+								] }
 # 			, { 'string' 	=> [ "(?<!:):(?:[!%^&*/|+-]|[@$]?[A-Za-z_]+?)", '[A-Za-z_0-9!?=]*(?![A-Za-z_0-9!?=])' ] }
-			, { 'include'	=> [ 'require', "\$" ] }
-			, { 'include'	=> [ 'load',    "\$" ] }
+			, { 'include'	=> [ '\brequire\b', '$' ] }
+			, { 'include'	=> [ '\bload\b',    '$' ] }
 			]
 		, 'typemap' =>
 			{ 'c' => 'class'
@@ -1376,8 +1366,8 @@
 						) ]
 		, 'spec' =>
 			[ { 'comment'	=> [ '/\*', '\*/' ] }
-			, { 'comment'	=> [ '//',  "\$" ] }
-			, { 'comment'	=> [ '--',  "\$" ] }
+			, { 'comment'	=> [ '//',  '$' ] }
+			, { 'comment'	=> [ '--',  '$' ] }
 			, { 'string'	=> [  '"',   '"',   '\\\\.' ] }
 			, { 'string'	=> [  "'",   "'",   "\\\\." ] }
 			]
@@ -1563,9 +1553,9 @@
 			, 'Xor'
 			]
 		, 'spec' =>
-			[ { 'comment'	=> [ 'rem ', '\$' ] }
+			[ { 'comment'	=> [ '\brem\b', '$' ] }
 			, { 'comment'	=> [ "'",    "\$" ] }
-			, { 'string'	=> [  '"',   '"',  '\\\\.' ] }
+			, { 'string'	=> [ '"',    '"',  '\\\\.' ] }
 			, { 'string'	=> [ "'",    "'",  "\\\\." ] }
 			]
 		, 'typemap' =>

[Lxr-commits] CVS: lxr/templates/Nginx nginx-fastcgi.conf.part, NONE, 1.1 nginx-lxrserver.conf, NONE, 1.1

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/templates/Nginx
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv9845/templates/Nginx

Added Files:
	nginx-fastcgi.conf.part nginx-lxrserver.conf 
Log Message:
templates/Nginx: new configuration templates for nginx web server

--- NEW FILE: nginx-fastcgi.conf.part ---
#-
#-	LXR nginx server configuration
#-		FastCGI block
#-
#-	$Id: nginx-fastcgi.conf.part,v 1.1 2013/09/24 10:00:54 ajlittoz Exp $
#-
#-
#-	This file fragment is meant to be "included" to form the
#-	complete configuration file.
#-
#-	This fragment sets up nginx parameters for launching LXR scripts
#-	in FastCGI mode through a wrapper.
#-
		{
			set $virtroot    $1;
			set $script_name $2;
			gzip off; #gzip makes scripts feel slower since they have to complete before getting gzipped
			alias %LXRroot%/;
		# Create FastCGI environment for LXR scripts
			include fastcgi.conf;
			fastcgi_split_path_info   (diff|ident|search|showconfig|source)(.*)$;
				# nginx bug? fastcgi.conf sets SERVER_NAME to $server_name,
				# but this variable is equal to first name on server_name
				# directive.
				# However, this fix is not bullet-proof: $host is equal to value
				# of HTTP header Host: if it exists, otherwise it reverts
				# to $server_name.
				# Consequently, there are residual cases where the correct
				# hostname is not captured and CSS stylesheets and icons
				# are not retrieved.
			fastcgi_param SERVER_NAME      $host;
			fastcgi_param SCRIPT_FILENAME  $document_root$script_name;
			fastcgi_param SCRIPT_NAME      $virtroot$script_name;
			fastcgi_param PATH_INFO        $fastcgi_path_info;
			fastcgi_pass  unix:/var/run/fcgiwrap.socket;
		}

--- NEW FILE: nginx-lxrserver.conf ---
#
#	LXR nginx server configuration
#
#-	$Id: nginx-lxrserver.conf,v 1.1 2013/09/24 10:00:54 ajlittoz Exp $
#-
#-

		#######################################
		# server - defines general parameters #
		#######################################
#
# IMPORTANT!
#	If LXR is offered as part of an existing server defined in another
#	configuration file, DO NOT use this one.
#	Instead, extract the location paragraphs and transfer them into
#	that other configuration file.
#
#	Servers are considered identical (and thus conflict) if they
#	have the same name and operate on the same port.

server {
#@IF	'H' ne "%_routing%"
	listen       %port%;		# server port
#@	ARRAY	portaliases,P
#@		ON	none
#	Add other listen directives if your LXR server answers on multiple ports
#@		ENDON
#@		ON	prolog
#	Other ports for this server
#	NOTE: remove duplicates since they cause trouble
#@		ENDON
	listen       %P%;
#@	ENDA
#@ENDIF
#@PASS2 here_ports
#@	IF	'H' eq "%_routing%"
#	listen XX;
#	where XX = port number for host %hostname%
#@	ENDIF
#@ENDP2

#@IF	'H' ne "%_routing%" && 'P' ne "%_routing%"
#@	ARRAY	hostaliases,H
#@		ON none
	server_name  %hostname%;	# list of names for this server
# In case of aliases, replace the previous directive with
#	server_name first.host.name first.alias second.alias ... ;
#@		ENDON
#@		ON	prolog
	server_name  %hostname%
#@		ENDON
	             %H%
#@		ON	epilog
	;
#@		ENDON
#@	ENDA
#@ENDIF
#@PASS2	here_hosts
#@	IF	'H' eq "%_routing%"
	server_name  %hostname%
	# List here the aliases for this host name
	;
#@	ELSEIF	'P' eq "%_routing%"
	server_name		%treeid%.%hostname%
#@		ARRAY	hostaliases,H
#@			ON none
	# List here the aliases for this host name
#@			ENDON
			%treeid%.%H%
#@		ENDA
	;
#@	ENDIF
#@ENDP2

	# If SSI (server-side includes) are needed,
	# uncomment the following line.
	# But, BEWARE, #include semantics is different from Apache or lighttpd
#	ssi on;

		# locations tell how to route URLs #
		#==================================#

#	The following images are not needed by LXR, but included just in case
#	you want to display them in header or footer.

    location ~ nginx-logo.png$ {
        alias   /usr/share/nginx/html/nginx-logo.png;
    }
    location ~ poweredby.png$ {
        alias   /usr/share/nginx/html/poweredby.png;
    }

#	The error page definitions are copied from nginx's default.conf.
#	They do use the previous images.
#	Normally, not needed by LXR.

    error_page  404				404.html;
    location = /404.html {
        root   /usr/share/nginx/html;
    }
    error_page  500 502 503 504	/50x.html;
    location = /50x.html {
        root   /usr/share/nginx/html;
    }

# ============================================================
#
#		# LXR scripts activation #
#		#========================#
#
#	This location directive manages both the virtual root and tree
#	(in multiple trees context) identifications. It is configured
#	for the built-in policy where tree designation is put after the
#	virtual root in the URL as (remember that location's omit the
#	"scheme", hostname and port):
#
#	/virtual_root/tree/script/arguments   for "embedded" case
#	/virtual_root/script/arguments        other cases
#
#	Pattern matching is used to isolate the different components:
#	^     virtrootbase /   [^/]+  /  (.*)    $
#	start ----root----   treename   URLtail end
#
#	If you don't use the built-in policy, you must adapt the following
#	regular expression to your needs.

#@IF		'S' ne "%_routing%" && 'E' ne "%_routing%"
	location ~ ^%virtrootbase%/(.*)$
#@ELSEIF	'E' eq "%_routing%"
#@	IF	'c' eq "%_virtrootpolicy%"
#@		REMIND Remember to adapt the tree designation for nginx
#@	ENDIF
	location ~ ^%virtrootbase%/[^/]+/(.*)$
#@ENDIF
#@IF	'S' ne "%_routing%"
	{
#
#	Next, we must handle differently "ordinary" files (like stylesheets
#	or images) and scripts files.
# 	This alias directive serves the ordinary files.
#	Note we don't use root directive because we must replace the head
#	part of the path.
		alias %LXRroot%/$1;

#	Script files will be handled by FastCGI.
#	Scripts are first identified by a more specific regular expression
#	whose head is similar to the previous one. See above for its structure
#	and the warning about the multiple trees policy.

#@	IF	'E' ne "%_routing%"
		location ~ ^(%virtrootbase%/)(diff|ident|search|showconfig|source)
#@	ELSE
		location ~ ^(%virtrootbase%/[^/]+/)(diff|ident|search|showconfig|source)
#@	ENDIF
#@	ADD Nginx/nginx-fastcgi.conf.part
	}
#@ENDIF	!'S'
#@PASS2 here_sections
#@	IF	'S' eq "%_routing%"
	location ~ ^(%virtroot%/)(.*)$
	{
#
#	Next, we must handle differently "ordinary" files (like stylesheets
#	or images) and scripts files.
# 	This alias directive serves the ordinary files.
#	Note we don't use root directive because we must replace the head
#	part of the path.
		alias %LXRroot%/$1;

#	Script files will be handled by FastCGI.
#	Scripts are first identified by a more specific regular expression
#	whose head is similar to the previous one. See above for its structure.

		location ~ ^(%virtroot%/)(diff|ident|search|showconfig|source)
#@		ADD Nginx/nginx-fastcgi.conf.part
	}
#@	ENDIF
#@ENDP2
#
# ============================================================

#	Close server definition
}

[Lxr-commits] CVS: lxr/templates/Nginx - New directory

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/templates/Nginx
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv9708/templates/Nginx

Log Message:
Directory /cvsroot/lxr/lxr/templates/Nginx added to the repository

[Lxr-commits] CVS: lxr/templates/lighttpd lighttpd-lxrserver.conf, 1.10, 1.11

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/templates/lighttpd
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv9571/templates/lighttpd

Modified Files:
	lighttpd-lxrserver.conf 
Log Message:
templates/lighttpd/lighttpd-lxrserver.conf: update configuration template to new tree designation variants and new features in LCL

Index: lighttpd-lxrserver.conf
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/lighttpd/lighttpd-lxrserver.conf,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- lighttpd-lxrserver.conf	22 Jan 2013 09:36:40 -0000	1.10
+++ lighttpd-lxrserver.conf	24 Sep 2013 09:56:15 -0000	1.11
@@ -462,35 +462,112 @@
 # the real site root.
 	server.document-root = "%LXRroot%/"
 
+#@IF	'H' ne "%_routing%" && 'P' ne "%_routing%"
+#@	IF	'localhost' ne "%hostname%"
 	$HTTP["host"] == "%hostname%" {
 		server.document-root = "%LXRroot%/"
 	}
-# Add more for alias names
+#@	ENDIF
+#@	ARRAY	hostaliases,H
+#@		ON none
+# Add similar block for alias names
+#	$HTTP["host"] == "alias.host.name" {
+#		server.document-root = "%LXRroot%/"
+#	}
+#@		ENDON
+	$HTTP["host"] == "%H%" {
+		server.document-root = "%LXRroot%/"
+	}
+#@	ENDA
+#@ELSEIF	'H' eq "%_routing%"
+# Edit the following conditions to remove // and port from hostname.
+# Eventually, create "socket" blocks for non default ports.
+#@ENDIF
+#@PASS2	here_hosts
+#@	IF	'H' eq "%_routing%"
+	$HTTP["host"] == "%hostname%" {
+		server.document-root = "%LXRroot%/"
+#@		IF	%_shared% && !%_commonvirtroot%
+		alias.url +=	("%virtroot%/" => "%LXRroot%/")
+#@		ENDIF
+	}
+#@	ELSEIF	'P' eq "%_routing%"
+	$HTTP["host"] == "%treeid%.%hostname%" {
+		server.document-root = "%LXRroot%/"
+#@		IF	%_shared% && !%_commonvirtroot%
+		alias.url +=	("%virtroot%/" => "%LXRroot%/")
+#@		ENDIF
+	}
+#@		ARRAY	hostaliases,H
+#@			ON none
+#	$HTTP["host"] == "%treeid%.alias_for_%hostname%" {
+#		server.document-root = "%LXRroot%/"
+#@				IF	%_shared% && !%_commonvirtroot%
+		alias.url +=	("%virtroot%/" => "%LXRroot%/")
+#@				ENDIF
+#	}
+#@			ENDON
+	$HTTP["host"] == "%treeid%.%H%" {
+		server.document-root = "%LXRroot%/"
+#@			IF	%_shared% && !%_commonvirtroot%
+		alias.url +=	("%virtroot%/" => "%LXRroot%/")
+#@			ENDIF
+	}
+#@		ENDA
+#@	ENDIF
+#@ENDP2
+#@	IF	'H' eq "%_routing%"
+#	$HTTP["host"] == "alias.host.name" {	# List here aliases for host name
+#		# Block should have same content as primary host
+#	}
+#@ENDIF
 
-## ------- URL black magic for multiple trees and sub-siting ------
+#@IF	'P' ne "%_routing%"
+#@	ARRAY	portaliases,P
+#@		ON	none
+# If incoming requests can arrive simultaneously on several ports,
+# you can add blocks (one per port) of the form:
+#	$HTTP["socket"] =~ ":XX$" {}	# with XX = port number
+# IMPORTANT! Remove duplicates
+#@		ENDON
+#@		ON prolog
+# Alternate ports
+# IMPORTANT! Remove duplicates
+#@		ENDON
+#@		IF	80 != %P%
+	$HTTP["socket"] =~ ":%P%$" {}
+#@		ENDIF
+#@	ENDA
+#@ENDIF
+#@PASS2 here_ports
+#@	IF	'P' eq "%_routing%"
+#	- port for //%treeid%.%hostname% and its aliases (do not uncomment if duplicate!)
+#@		IF	80 != %port%
+#	$HTTP["socket"] =~ ":%port%$" {}
+#@		ENDIF
+#@		ARRAY	portaliases,P
+#@			IF	80 != %P%
+#	$HTTP["socket"] =~ ":%P%$" {}
+#@			ENDIF
+#@		ENDA
+#@	ENDIF
+#@ENDP2
+#@IF	'S' eq "%_routing%" || 'E' eq "%_routing%" || %_shared%
+
+## ------- URL mapping to LXR root directory ------
 ##
 ## Format is "virtroot" => "%LXRroot%"
 ## for all 'virtroot' to be served by the same LXR server
 ## located in the root directory.
-#@IF	%_singlecontext%
-#	$HTTP["url"] =~ "^%virtrootbase%/[^/]+/" {
-#		alias.url +=	("%virtrootbase%/tree/" => "%LXRroot%/")
-#	}
-# 
 #@ENDIF
-#@IF	'' ne "%virtrootbase%"
-	$HTTP["url"] =~ "^%virtrootbase%/" {
+#@IF	%_shared% &&('N' eq "%_routing%" || 'A' eq "%_routing%" ||('H' eq "%_routing%" || 'P' eq "%_routing%") && %_commonvirtroot%)
+	alias.url +=	("%virtrootbase%/" => "%LXRroot%/")
 #@ENDIF
-#- - -
-#- - - Note: block below is interpreted during pass 2.
-#- - -
-#@PASS2 here_virtroot
-		alias.url +=	("%virtroot%/" => "%LXRroot%/")
+#@PASS2 here_alias
+#@	IF	'S' eq "%_routing%" || 'E' eq "%_routing%"
+	alias.url +=	("%virtroot%/" => "%LXRroot%/")
+#@	ENDIF
 #@ENDP2
-#- - - End of second pass additions
-#@IF	'' ne "%virtrootbase%"
-	}
-#@ENDIF
 
 ## ------- Tell which files are CGI scripts ------
 #@IF	'' ne "%virtrootbase%"

[Lxr-commits] CVS: lxr/templates/html html-fatal.html,1.3,1.4

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/templates/html
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv9429/templates/html

Modified Files:
	html-fatal.html 
Log Message:
templates/html/fatal.html: remove <meta> element since encoding is defined in an HTTP header

Index: html-fatal.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-fatal.html,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- html-fatal.html	4 Sep 2013 15:22:41 -0000	1.3
+++ html-fatal.html	24 Sep 2013 09:52:49 -0000	1.4
@@ -24,7 +24,6 @@
 
 <html>
 <head>
-<meta http-equiv="content-type" content="text/html; charset=iso-8859-1">
 <title>Error - no tree</title>
 <base href="$baseurl">
 <link href="$stylesheet" rel="stylesheet" type="text/css">

[Lxr-commits] CVS: lxr/templates thttpd-lxrserver.conf,NONE,1.1

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/templates
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv8565/templates

Added Files:
	thttpd-lxrserver.conf 
Log Message:
templates/thttpd-lxrserver.conf: new configuration template for thttpd web server

--- NEW FILE: thttpd-lxrserver.conf ---
#
#	LXR thttpd server configuration
#
#	$Id: thttpd-lxrserver.conf,v 1.1 2013/09/24 09:39:45 ajlittoz Exp $
#
#

# ---- Copied from default configuration file ---- #
# BEWARE : No empty lines are allowed!
# This section overrides defaults
#LXR commented out dir=/var/www/thttpd
nochroot			# uncommented for LXR
user=thttpd         # default = nobody
logfile=/var/log/thttpd.log
pidfile=/var/run/thttpd.pid
# This section _documents_ defaults in effect
# port=80
# nosymlink         # default = !chroot
# novhost
# nocgipat
# nothrottles
# host=0.0.0.0
# charset=iso-8859-1
# ---- End of copy ---- #

#@IF	"%_shared%"
dir=/var/www/thttpd
#@ELSE
dir=%LXRroot%
#@ENDIF
#@IF	'H' eq "%_routing%" || 'P' eq "%_routing%"
#	Allow multiple host names
vhost
# REMINDER:	manually create the 'host' directories in dir
#			and create 'virtroot' symbolic links in them
#			to point back to dir.
#@ENDIF

#@IF	80 != %port%
#	The port to listen to
port=%port%
#@ENDIF

# Disable symlink check for icons in directory listing
# NOTE:	does not work if icons are stored outside dir (e.g. even
#		as target of symbolic links)
nosymlink

# Tell which files are scripts
#@IF	! %_shared%
cgipat=diff|ident|search|showconfig|source
#@ELSE
# NOTE:	the following pattern tries to cover all configuration cases
#		but may allow for other non-LXR scripts to be run.
#		If this is a security issue, manually adapt the pattern.
cgipat=**/diff|**/ident|**/search|**/showconfig|**/source
#@ENDIF

[Lxr-commits] CVS: lxr/templates classic.css, 1.4, 1.5 lxr.css, 1.15, 1.16

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/templates
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv7156/templates

Modified Files:
	classic.css lxr.css 
Log Message:
templates/classic.css & lxr.css: new mode-dis CSS style for disabled mode (button)

Index: classic.css
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/classic.css,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- classic.css	24 Jan 2013 15:09:53 -0000	1.4
+++ classic.css	24 Sep 2013 09:05:52 -0000	1.5
@@ -24,6 +24,7 @@
 , .dirrow2
 , .modes		/* mode switches */
 , .modes-sel
+, .mode-dis
 , BUTTON
 , .varlink		/* 'variables' switches */
 , .var-sel

Index: lxr.css
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/lxr.css,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -d -r1.15 -r1.16
--- lxr.css	24 Jan 2013 15:09:53 -0000	1.15
+++ lxr.css	24 Sep 2013 09:05:52 -0000	1.16
@@ -24,6 +24,7 @@
 , .dirrow2
 , .modes		/* mode switches */
 , .modes-sel
+, .modes-dis
 , BUTTON
 , .varlink		/* 'variables' switches */
 , .var-sel

[Lxr-commits] CVS: lxr/lib Local.pm,1.2,1.3

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv6780/lib

Modified Files:
	Local.pm 
Log Message:
source, Local.pm: sub descexpand moved from Local.pm to source

This general sub belongs better in source
Name fileexpand in Local.pm changed to filedesc to mirror dirdesc sub name for directories
New sub iconlink in source to cope with security feature in fileref which forbids HTML code in link text.
Also, better comments and various Perl syntax optimisations

Index: Local.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/Local.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- Local.pm	17 Sep 2012 11:56:14 -0000	1.2
+++ Local.pm	24 Sep 2013 08:54:19 -0000	1.3
@@ -35,7 +35,7 @@
 
 require Exporter;
 our @ISA    = qw(Exporter);
-our @EXPORT = qw(&fdescexpand &descexpand &dirdesc &convertwhitespace);
+our @EXPORT = qw(&filedesc &dirdesc);
 
 use LXR::Common;
 use LXR::Markup;
@@ -75,25 +75,27 @@
 #
 # Yea, though I walk through the valley of the shadow of pattern
 # matching, I shall fear no regex.
-sub fdescexpand {
+#
+# ajl 13-07-09: name changed from fdescexpand to filedesc
+# to better mirror dirdesc and emphasize the parallel semantics.
+sub filedesc {
 	my ($filename, $dir, $releaseid) = @_;
 	my $fh;
 	my $linecount = 0;
-	my $copy      = "";
-	my $desc = "";
+	my $copy = '';
+	my $desc = '';
 	my $maxlines = 40;    #only look at the beginning of the file
 
 	#ignore files that aren't source code
-	if (
-		!(	($filename =~ /\.c$/)
-		 |	($filename =~ /\.h$/)
-		 |	($filename =~ /\.cc$/)
-		 |	($filename =~ /\.cp$/)
-		 |	($filename =~ /\.cpp$/)
-		 |	($filename =~ /\.java$/)
-		 )
-	)
-	{ return ("\&nbsp\;"); }
+	if	(	(substr($filename, -2) ne '.c')
+		&&	(substr($filename, -2) ne '.h')
+		&&	(substr($filename, -3) ne '.cc')
+		&&	(substr($filename, -3) ne '.cp')
+		&&	(substr($filename, -4) ne '.cpp')
+		&&	(substr($filename, -5) ne '.java')
+		) {
+	return (' ');
+	}
 
 	if ($fh = $files->getfilehandle($dir . $filename, $releaseid)) {
 		while (<$fh>) {
@@ -106,19 +108,19 @@
 	}
 
 	# sanity check: if there's no description then stop
-	if (!($desc =~ /\w/)) {
-		return ("\&nbsp\;");
+	if (!($desc =~ m/\w/)) {
+		return ('&nbsp;');
 	}
 
 	# if a java file, only consider class-level javadoc comments
-	if ($filename =~ /\.java$/) {
+	if (substr($filename, -5) eq '.java') {
 
 		# last /** ... */ before 'public class' or 'public interface'
 
 		# find declaration
-		$desc =~ m/public\s((abstract|static|final|strictfp)\s)*(class|interface)/g;
+		$desc =~ m/public\s+((abstract|static|final|strictfp)\s+)*(class|interface)/;
 		my $declPos = pos $desc;
-		return "\&nbsp\;" if !$declPos;
+		return '&nbsp;' if !$declPos;
 
 		# last comment start before declaration
 		pos $desc = 0;
@@ -127,15 +129,17 @@
 			last if $declPos < pos $desc;
 			$commentStart = pos $desc;
 		}
-		return "\&nbsp\;" if $commentStart == -1;
+		return '&nbsp;' if $commentStart == -1;
 
 		# find comment end, and extract
 		pos $desc = $commentStart;
 		$desc =~ m#\*/#g;
 		my $commentEnd = pos $desc;
-		$desc       = substr($desc, $commentStart + 3, $commentEnd - $commentStart - 5);
-
-		return "\&nbsp\;" if !$desc;
+		$desc = substr	( $desc
+						, $commentStart + 3
+						, $commentEnd - $commentStart - 5
+						);
+		return '&nbsp;' if !$desc;
 
 		# strip off any leading * s
 		$desc =~ s/^\s*\*\s?//mg;
@@ -150,8 +154,7 @@
 
 		# strip off some CVS keyword lines
 		foreach my $keyword ('Workfile', 'Revision', 'Modtime', 'Author', 'Id', 'Date', 'Source',
-			'RCSfile')
-		{
+			'RCSfile') {
 			$desc =~ s/^\s*\$$keyword[\$:].*$//mg;
 		}
 
@@ -164,13 +167,13 @@
 	# descriptions before we go to the trouble of looking for
 	# one in the first comment. The whitespace between the
 	# delimeter and the description may include a newline.
-	if (   ($desc =~ s/(?:.*?$filename\s*?- ?-*\s*)([^\n]*)(?:.*)/$1/sgi)
+	if	(  ($desc =~ s/(?:.*?$filename\s*?- ?-*\s*)([^\n]*)(?:.*)/$1/sgi)
 		|| ($desc =~ s/(?:.*?$filename\s*?:\s*)([^\n]*)(?:.*)/$1/sgi)
-		|| ($desc =~ s/(?:.*?Description:\s*)([^\n]*)(?:.*)/$1/sgi))
-	{
+		|| ($desc =~ s/(?:.*?Description:\s*)([^\n]*)(?:.*)/$1/sgi)
+		) {
 
 		# if the description is non-empty then clean it up and return it
-		if ($desc =~ /\w/) {
+		if ($desc =~ m/\w/) {
 
 			#strip trailing asterisks and "*/"
 			$desc =~ s#\*/?\s*$##;
@@ -190,7 +193,7 @@
 	}
 
 	# if java and the <filename><seperator> check above didn't work, just dump the whole javadoc
-	if ($filename =~ /\.java$/) {
+	if (substr($filename, -5) eq '.java') {
 		return $desc;
 	}
 
@@ -202,7 +205,7 @@
 	$desc =~ s/\n#.*//s;
 
 	# Strip off code from the end, starting at typedef
-	$desc =~ s/\ntypedef.*//s;
+	$desc =~ s/\n\s*typedef.*//s;
 
 	# Strip off license
 	$desc =~ s#(?:/\*.*license.*?\*/)(.*)#$1#is;
@@ -220,8 +223,8 @@
 	$desc =~ s#\n\s*/\*+[\s\*]+\*/\n#\n#sg;
 
 	# Don't bother to continue if there aren't any comments here
-	if (!($desc =~ m#/\*#)) {
-		return ("&nbsp;");
+	if (-1 == index($desc, '/*')) {
+		return ('&nbsp;');
 	}
 
 	# Remove lines generated by jmc
@@ -264,7 +267,7 @@
 	# If the description is still too long then assume it will look
 	# like gobbeldygook and give up
 	if (length($desc) > 200) {
-		return ("&nbsp;");
+		return ('&nbsp;');
 	}
 
 	# htmlify the comments, making links to symbols and files
@@ -273,29 +276,15 @@
 	if ($desc) {
 		return ("<p>$desc</p>");
 	} else {
-		return ("\&nbsp\;");
+		return ('&nbsp;');
 	}
 }
 
-# dme: create a short description for a subdirectory in a directory listing
-# If no description, return the string "\&nbsp\;" to keep the
-# table looking pretty.
+# dme: Print a descriptive blurb in directory listings between
+# the document heading and the table containing the actual listing.
 #
 # In Mozilla, if the directory has a README file look in it for lines
 # like the ones used in source code: "directoryname --- A short description"
-sub descexpand {
-	my ($templ, $node, $dir, $releaseid) = @_;
-	if ($node =~ m!/$!) {
-		return LXR::Template::expandtemplate($templ,
-			('desctext' => sub { return dirdesc($dir . $node, $releaseid); }));
-	} else {
-		return LXR::Template::expandtemplate($templ,
-			('desctext' => sub { return fdescexpand($node, $dir, $releaseid); }));
-	}
-}
-
-# dme: Print a descriptive blurb in directory listings between
-# the document heading and the table containing the actual listing.
 #
 # For Mozilla, we extract this information from the README file if
 # it exists. If the file is short then just print the whole thing.
@@ -305,22 +294,22 @@
 sub dirdesc {
 	my ($path, $releaseid) = @_;
 	my $readh;
-	if ($readh = $files->getfilehandle($path . "README.txt", $releaseid)) {
-		return descreadme($path, "README.txt", $readh);
+	if ($readh = $files->getfilehandle($path . 'README.txt', $releaseid)) {
+		return descreadme($path, 'README.txt', $readh);
 	}
-	if ($readh = $files->getfilehandle($path . "README", $releaseid)) {
-		return descreadme($path, "README", $readh);
+	if ($readh = $files->getfilehandle($path . 'README', $releaseid)) {
+		return descreadme($path, 'README', $readh);
 	}
-	if ($readh = $files->getfilehandle($path . "README.html", $releaseid)) {
-		return descreadmehtml($path, "README.html", $readh);
+	if ($readh = $files->getfilehandle($path . 'README.html', $releaseid)) {
+		return descreadmehtml($path, 'README.html', $readh);
 	}
-	return "&nbsp;";
+	return '&nbsp;';
 }
 
 sub descreadmehtml {
 	my ($dir, $file, $desc) = @_;
 
-	my $string = "";
+	my $string = '';
 
 	    undef $/;
 	$string = <$desc>;
@@ -329,7 +318,7 @@
 
 	# if the README is 0 length then give up
 	if (!$string) {
-		return;
+		return '&nbsp;';
 	}
 
 	# check if there's a short desc nested inside the long desc. If not, do
@@ -337,11 +326,10 @@
 	# spans within the description.
 	my $long;
 	if ($string =~
-		/<span class=["']?lxrlongdesc['"]?>(.*?<span class=["']?lxrshortdesc['"]?>.*?<\/span>.*?)<\/span>/is
-	  )
-	{
+		m/<span class=["']?lxrlongdesc['"]?>(.*?<span class=["']?lxrshortdesc['"]?>.*?<\/span>.*?)<\/span>/is
+	  ) {
 		$long = $1;
-		if (!($long =~ /<span.*?\<span/is)) {
+		if ($long !~ m/<span.*?\<span/is) {
 			return	( "<div class='desctext'>$long</div>\n<p>\nSEE ALSO: "
 					. fileref($file, '', $dir . $file)
 					. "</p>\n"
@@ -349,19 +337,20 @@
 		}
 	} elsif ($string =~ /<span class=["']?lxrlongdesc['"]?>(.*?)<\/span>/is) {
 		$long = $1;
-		if (!($long =~ /\<span/is)) {
+		if ($long !~ m/\<span/is) {
 			return	( "<div class='desctext lxrlongdesc'>$long</div>\n<p>\nSEE ALSO: "
 					. fileref($file, '', $dir . $file)
 					. "</p>\n"
 					);
 		}
 	}
+	return '&nbsp;';
 }
 
 sub descreadme {
 	my ($dir, $file, $desc) = @_;
 
-	my $string = "";
+	my $string = '';
 
 	#    $string =~ s#(</?([^>^\s]+[^>]*)>.*$)#($2~/B|A|IMG|FONT|BR|EM|I|TT/i)?$1:""#sg;
 	my $n;
@@ -379,7 +368,7 @@
 
 	# if the README is 0 length then give up
 	if (!$string) {
-		return;
+		return '&nbsp;';
 	}
 
 	# strip the emacs tab line
@@ -408,7 +397,9 @@
 	if ($count <= $maxlines) {
 		$string = markupstring($string, $dir);
 		$string = convertwhitespace($string);
-		return "<div class='desctext'><p class=\"lxrdesc\">$string</p></div>\n";
+		return	"<div class='desctext'><p class='lxrdesc'>\n"
+				. $string
+				. "\n</p></div>";
 	} else {
 
 		# grab the first n paragraphs, with n decreasing until the
@@ -445,8 +436,8 @@
 		# since not all of the README is displayed here,
 		# add a link to it.
 		chomp($string);
-		if ($string =~ /SEE ALSO/) {
-			$string = $string . ", ";
+		if (-1 != index($string, 'SEE ALSO')) {
+			$string = $string . ', ';
 		} else {
 			$string = $string . "</p>\n\n<p>SEE ALSO: ";
 		}
@@ -460,7 +451,9 @@
 		$string =~ s/\s*\n$//gs;
 		chomp($string);
 
-		return "<div class='desctext'><p class=\"lxrdesc\">$string</p></div>\n";
+		return	"<div class='desctext'><p class='lxrdesc'>\n"
+				. $string
+				. "\n</p></div>";
 	}
 }
 
@@ -472,11 +465,12 @@
 
 	# handle ascii bulleted lists
 #	$string =~ s/<p>\n\s+o\s/<p>\n\&nbsp\;\&nbsp\;o /sg;
-	$string =~ s/\n\s+o\s/&nbsp\;\n<br>\&nbsp\;\&nbsp\;o /sg;
+	$string =~ s/\n\s+o\s/\n<br>&nbsp;&nbsp;o /sg;
 
-	#find paragraph breaks and replace with <p> ... </p>
+	#find paragraph breaks and replace by <br>
 # 	$string =~ s/\n\s*\n/<br><br>\n/sg;
-	$string =~ s/(([\S\t ]*?\n)+?)[\t ]*(\n|$)/$1<br>\n/sg;
+# 	$string =~ s/(([\S\t ]*?\n)+?)[\t ]*(\n|$)/$1<br>\n/sg;
+	$string =~ s/\n\s*\n/\n<br>\n/sg;
 
 	return ($string);
 }

[Lxr-commits] CVS: lxr ident,1.37,1.38 search,1.50,1.51

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv6383

Modified Files:
	ident search 
Log Message:
ident, search: provide more substitution markers for templates

Also, better comments and various Perl syntax optimisations

Index: ident
===================================================================
RCS file: /cvsroot/lxr/lxr/ident,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- ident	8 Apr 2013 16:05:04 -0000	1.37
+++ ident	24 Sep 2013 08:43:06 -0000	1.38
@@ -1,4 +1,6 @@
 #!/usr/bin/perl -T
+######################################################################
+#
 # $Id$
 #
 # ident --	Look up identifiers
@@ -28,7 +30,7 @@
 use strict;
 use lib do { $0 =~ m{(.*)/} ? "$1/lib" : "lib" }; # if LXR modules are in ./lib
 
-=head1 indent script
+=head1 ident script
 
 This script manages the HTTP requests for identifier search.
 
@@ -53,7 +55,7 @@
 Function C<varinputs> is a "$variable" substitution function.
 It returns a string which is a concatenation of tags
 
-C<<E<lt>input type="hidden" name=">>I<variable_name>C<" value=">I<variable_value>C<<"E<gt> >>
+C<E<lt>input type="hidden" name=">I<variable_name>C<" value=">I<variable_value>C<"E<gt>>
 
 one for each variable defined in configuration parameter C<'variables'>.
 
@@ -65,7 +67,12 @@
 	my $ret = '';
 	foreach ($config->allvariables) {
 		if ($config->variable($_) ne $config->vardefault($_)) {
-			$ret .= "<input type=\"hidden\" name=\"$_\" value=\"" . $config->variable($_) . "\">\n";
+			$ret .=	'<input type="hidden" name="'
+				.	$_
+				.	'" value="'
+				.	$config->variable($_)
+				.	'">'
+				.	"\n";
 		}
 	}
 	return $ret;
@@ -125,7 +132,7 @@
 sub checkvalidref {
 	my ($file) = @_;
 
-	if (	!$index->filetimestamp
+	if (!$index->filetimestamp
 				( $file
 				, $files->filerev($file, $releaseid)
 				)
@@ -137,8 +144,11 @@
 	# need it
 	#	&&	LXR::Lang::parseable($file)
 		) {
-		$bad_refs++; 'identinvalid'
-	} else {''}
+		$bad_refs++;
+		'identinvalid'
+	} else {
+		''
+	}
 }
 
 
@@ -208,7 +218,7 @@
 	my ($desc, $css, $path, $line) = @_;
 
 	if ($line < 0) {
-		return fileref($desc, $css." identapprox", $path, -$line);
+		return fileref($desc, $css.' identapprox', $path, -$line);
 	} else {
 		return fileref($desc, $css, $path, $line);
 	}
@@ -247,6 +257,8 @@
 
 =over
 
+=item
+
 I<The element of the references array is a list.
 This list does not contain the same number of items for
 definitions and usages. In case of modification (notably
@@ -265,7 +277,7 @@
 
 	countfiles ($refs);
 	# Select usage layout on the presence of a specific marker
-	if ($templ =~ m/\$lines\b/) {
+	if (0 <= index($templ, '$lines')) {
 	# We are in "many refs per line" layout
 		my @lines;
 		$last_file = @$refs[0];
@@ -278,24 +290,24 @@
 			}
 LAST_EXPAND:
 			++$i;
-			if	( $last_file ne $file
-				|| $i >= scalar (@$refs)
+			if	( 	$last_file ne $file
+				||	$i >= scalar (@$refs)
 				) {
 				$ret .= expandtemplate
 						( $templ
 						,	( 'file'	=>
-					sub { ref_in_file($last_file, "identfile", $last_file) }
+					sub { ref_in_file($last_file, 'identfile', $last_file) }
 							, 'fileonce'=>
-					sub { ref_in_file($last_file, "identfile", $last_file) }
+					sub { ref_in_file($last_file, 'identfile', $last_file) }
 							, 'lines'	=> sub {
 								join	( ' '
-										, map { ref_in_file( abs($_), "identline", $last_file, $_)
+										, map { ref_in_file( abs($_), 'identline', $last_file, $_)
 											} @lines
 										) }
 							, 'type'	=> sub { $type }
-							, 'rel'		=> sub { if ($rel) { idref($rel, "identrel", $rel) } }
+							, 'rel'		=> sub { if ($rel) { idref($rel, 'identrel', $rel) } }
 							, 'fileref'	=> sub {
-								ref_in_file("$last_file, line ".abs($line), "identline", $last_file, $line);
+								ref_in_file("$last_file, line ".abs($line), 'identline', $last_file, $line);
 											}
 						, 'refinvalid'	=> sub { checkvalidref($last_file) }
 							)
@@ -318,15 +330,15 @@
 			$ret .= expandtemplate
 					( $templ
 					,	( 'file'	=>
-				sub { ref_in_file($file, "identfile", $file) }
+				sub { ref_in_file($file, 'identfile', $file) }
 						, 'fileonce'=>
-				sub { if ($fileonce) { ref_in_file($fileonce, "identfile", $file) } }
+				sub { if ($fileonce) { ref_in_file($fileonce, 'identfile', $file) } }
 						, 'line'	=>
-				sub { ref_in_file( abs($line), "identline", $file, $line) }
+				sub { ref_in_file( abs($line), 'identline', $file, $line) }
 						, 'type'	=> sub { $type }
-						, 'rel'		=> sub { if ($rel) { idref($rel, "identrel", $rel) } }
+						, 'rel'		=> sub { if ($rel) { idref($rel, 'identrel', $rel) } }
 						, 'fileref'	=> sub {
-							ref_in_file("$file, line ".abs($line), "identline", $file, $line);
+							ref_in_file("$file, line ".abs($line), 'identline', $file, $line);
 										}
 						, 'refinvalid'	=> sub { checkvalidref($file) }
 						)
@@ -359,9 +371,13 @@
 
 =over
 
+=item
+
 For usages, the last two element do no exist.
 The comparison stops after the first two steps.
 
+=back
+
 =cut
 
 sub cmprefs {
@@ -450,9 +466,9 @@
 }
 
 
-=head2 C<usessexpand ($templ)>
+=head2 C<usesexpand ($templ)>
 
-Function C<usessexpand> is a "$function" substitution function.
+Function C<usesexpand> is a "$function" substitution function.
 It returns an HTML string which is the concatenation of its
 expanded argument applied to every usage.
 
@@ -467,6 +483,13 @@
 The function queries the database for usages, then hands over
 definition layout to C<refsexpand>.
 
+Since some languages are case-insensitive, the database is also
+queried for the case-insensitive version of the identifier.
+The returned definitions are flagged with their line numbers set
+negative.
+The two lists are merged, removing duplicates and sorted as if a
+single query was made.
+
 =cut
 
 sub usesexpand {
@@ -515,7 +538,10 @@
 
 =head2 C<printident ()>
 
-Sub C<printident> is the main driver for identifier search.
+Procedure C<printident> is the main driver for identifier search.
+
+It retrieves template C<'htmldir'> and expands it using the dedicated
+functions defined in this file.
 
 =cut
 
@@ -537,7 +563,9 @@
 			,	( 'variables'		=> \&varinputs
 				, 'identifier'		=> sub { $_ = $identifier; s/</&lt;/g; s/>/&gt;/g; return $_; }
 				, 'identifier_escaped'=> sub { $_ = $identifier; s/\"/&quot;/g; s/</&lt;/g; s/>/&gt;/g; return $_; }
-				, 'checked'			=> sub { $defonly ? 'checked="checked"' : "" }
+				, 'checked'			=> sub { $defonly ? 'checked="checked"' : '' }
+				, 'varbtnaction'	=> sub { varbtnaction(@_, 'ident') }
+				, 'urlargs'			=> sub { urlexpand('-', 'ident') }
 				, 'defs'			=> \&defsexpand
 				, 'uses'			=> \&usesexpand
 				)
@@ -545,6 +573,14 @@
 	);
 }
 
+
+=head2 Script entry point
+
+Builds the header and footer and launches C<printident>
+for the real job.
+
+=cut
+
 httpinit;
 makeheader('ident');
 $defonly = 1 if	($HTTP->{'param'}{'_identdefonly'}

Index: search
===================================================================
RCS file: /cvsroot/lxr/lxr/search,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -d -r1.50 -r1.51
--- search	24 Jan 2013 15:09:52 -0000	1.50
+++ search	24 Sep 2013 08:43:06 -0000	1.51
@@ -1,6 +1,8 @@
 #!/usr/bin/perl -T
+######################################################################
 # $Id$
-#
+##
+
 # search --	Freetext search
 #
 #	Arne Georg Gleditsch <ar...@if...>
@@ -26,9 +28,9 @@
 $CVSID = '$Id$ ';
 
 use strict;
-use lib do { $0 =~ m{(.*)/} ? "$1/lib" : "lib" }; # if LXR modules are in ./lib
+use lib do { $0 =~ m{(.*)/} ? "$1/lib" : 'lib' }; # if LXR modules are in ./lib
 
-=head1 indent script
+=head1 search script
 
 This script manages the HTTP requests for free-text search.
 
@@ -49,7 +51,7 @@
 Function C<varinputs> is a "$function" substitution function.
 It returns a string which is a concatenation of tags
 
-C<<E<lt>input type="hidden" name=">>I<variable_name>C<" value=">I<variable_value>C<<"E<gt> >>
+C<E<lt>input type="hidden" name=">I<variable_name>C<" value=">I<variable_value>C<"E<gt>>
 
 one for each variable defined in configuration parameter C<'variables'>.
 
@@ -124,10 +126,10 @@
 	my ($filetext, $advanced, $casesensitive, $file) = @_;
 	if ($advanced) {
 		if ($casesensitive) {
-			if ($file =~ /$filetext/) {
+			if ($file =~ m/$filetext/) {
 				return 1;
 			}
-		} elsif ($file =~ /$filetext/i) {
+		} elsif ($file =~ m/$filetext/i) {
 			return 1;
 		}
 	} else {
@@ -184,10 +186,10 @@
 		# Don't scan files ending in ,v or ~
 				." -F '-v (\\,v\|\\~)\$' "
 		# Should we match casesensitive ?
-				. ($casesensitive ? "" : "-i")
+				. ($casesensitive ? '' : '-i')
 		# Location of index datadbase
-				. " -H "
-				.$config->{'glimpsedir'}."/".$releaseid
+				. ' -H '
+				. $config->{'glimpsedir'}.'/'.$releaseid
 		# The pattern to search for
 				." -y -n '$searchtext' 2>&1 |"
 			)
@@ -198,7 +200,7 @@
 	my @glimpsemsgs  = ();
 	while (<GLIMPSE>) {
 		if (s/^$sourceroot//) {
-		my ($file) = $_ =~ /(.*?):\s*/;
+		my ($file) = $_ =~ m/(.*?):\s*/;
 	# Keep only occurrences matching file name if given
 		next if $filetext && !filename_matches($filetext, $advanced, $casesensitive, $file);
 		$numlines++;
@@ -225,11 +227,11 @@
 
 	if ($retval == 0) {
 		my @ret;
-		my $i          = 0;
+		my $i = 0;
 		foreach my $glimpseline (@glimpselines) {
 			last if ($i > $maxhits);
 
-			my ($file, $line, $text) = $glimpseline =~ /(.*?):\s*(\d+)\s*:(.*)/;
+			my ($file, $line, $text) = $glimpseline =~ m/(.*?):\s*(\d+)\s*:(.*)/;
 
 			$text =~ s/&/&amp;/g;
 			$text =~ s/</&lt;/g;
@@ -243,7 +245,7 @@
 		return sort {$$a[0] cmp $$b[0]} @ret;
 	} elsif ($retval == 1) {
 		my $glimpsebin = $config->{'glimpsebin'};
-		my $glimpseresponse = join("<br>", @glimpselines);
+		my $glimpseresponse = join('<br>', @glimpselines);
 		my $glimpseresponse =~ s/$glimpsebin/Reason/;
 		my $glimpseresponse =~ s/glimpse: error in searching index//;
 		print("<p class='error'>Search failed</p>\n<p>$glimpseresponse</p>\n");
@@ -294,16 +296,19 @@
 sub swishsearch {
 	my ($searchtext, $filetext, $advanced, $casesensitive) = @_;
 
-  my $swishIndex = $config->{'swishdir'} . "/" . $releaseid . ".index";
+  my $swishIndex = $config->{'swishdir'} . '/' . $releaseid . '.index';
 	if (!-e $swishIndex) {
-		print "<p class='error'>";
+		print '<p class="error">';
 		print "Version '$releaseid' has not been indexed and is unavailable for searching.";
-		print "</p>";
+		print '</p>';
 		return;
 	}
 	
 	$ENV{'PATH'} = '/bin:/usr/local/bin:/usr/bin:/usr/sbin';
-  my $swishCommand =  join(' ', $config->{'swishbin'}, "-f", $swishIndex, "-w", "'(" . $searchtext . ")'");
+  my $swishCommand =  $config->{'swishbin'}
+					. ' -f ' . $swishIndex
+					. ' -w \'(' . $searchtext . ')\''
+					;
   my $ret = `$swishCommand`;
   my @result = grep { not /^[\#\.]/ } split(/\n/, $ret);
 
@@ -313,9 +318,9 @@
 		my $numlines = 0;
 		foreach my $hit (@result) {
 			print $hit, "<br>\n" if $hit =~ /No such file or directory/;	# feeble attempt to print possible errors (e.g. incomplete LD_LIBRARY_PATH causes linking errors)
-			next if $hit =~ /^err:/;    # skip; only 'no results' errors happen with return value 0
+			next if substr($hit, 0, 4) eq 'err:';	# skip; only 'no results' errors happen with return value 0
 
-			my ($score, $file) = $hit =~ /^(\d+) \/(.+) "(.+)" \d+/;
+			my ($score, $file) = $hit =~ m/^(\d+) \/(.+) "(.+)" \d+/;
 			next if $filetext && !filename_matches($filetext, $advanced, $casesensitive, $file);
 			push @ret, [ $file, $score ];
 			$numlines++;
@@ -325,7 +330,7 @@
 		return @ret;
 	} else {
 		print( "<p class='error'>Search failed: internal error</p><br>\n<p>"
-				. join("<br>", @result)
+				. join('<br>', @result)
 				. "<\p>\n");
 		return;
 	}
@@ -364,7 +369,9 @@
 		&&	LXR::Lang::parseable($file)
 		) {
 		'searchinvalid'
-	} else {''}
+	} else {
+		''
+	}
 }
 
 
@@ -399,6 +406,8 @@
 
 =over
 
+=item
+
 I<Both search engines start by looking into their private "index"
 files before accessing the source-tree files.
 A first consequence is any file added after genxref indexing cannot
@@ -437,19 +446,19 @@
 			$ret .= expandtemplate
 				( $templ
 				,	( 'text'    => sub { return "<pre class='searchtext'>$text</pre>" }
-					, 'file'    => sub { fileref($file, "searchfile", "/$file") }
+					, 'file'    => sub { fileref($file, 'searchfile', "/$file") }
 					, 'fileonce'=> sub { if ($fileonce) {
-											return fileref($fileonce, "searchfile", "/$file")
+											return fileref($fileonce, 'searchfile', "/$file")
 										} else {
-											return "&nbsp;"
+											return '&nbsp;'
 										}
 									}
-					, 'line'    => sub { fileref($line, "searchline", "/$file", $line) }
-					, 'fileref' => sub { fileref("$file, line $line", "searchfile", "/$file", $line) }
+					, 'line'    => sub { fileref($line, 'searchline', "/$file", $line) }
+					, 'fileref' => sub { fileref("$file, line $line", 'searchfile', "/$file", $line) }
 					, 'tdfile'  => sub { if ($fileonce) {
-											return "searchfile"
+											return 'searchfile'
 										} else {
-											return "searchfilevoid"
+											return 'searchfilevoid'
 										}
 									}
 					, 'searchinvalid'	=> sub { checkvalidref($file) }
@@ -463,19 +472,19 @@
 			$ret .= expandtemplate
 				( $templ
 				,	( 'text'    => sub { return $score }
-					, 'file'    => sub { fileref($file, "searchfile", "/$file") }
+					, 'file'    => sub { fileref($file, 'searchfile', "/$file") }
 					, 'fileonce'=> sub { if ($fileonce) {
-											return fileref($fileonce, "searchfile", "/$file")
+											return fileref($fileonce, 'searchfile', "/$file")
 										} else {
-											return "&nbsp;"
+											return '&nbsp;'
 										}
 									}
 					, 'line'    => sub { return '' }
-					, 'fileref' => sub { fileref($file, "searchfile", "/$file") }
+					, 'fileref' => sub { fileref($file, 'searchfile', "/$file") }
 					, 'tdfile'  => sub { if ($fileonce) {
-											return "searchfile"
+											return 'searchfile'
 										} else {
-											return "searchfilevoid"
+											return 'searchfilevoid'
 										}
 									}
 					, 'searchinvalid'	=> sub { checkvalidref($file) }
@@ -499,8 +508,10 @@
 
 =over
 
+=item
+
 Filename search may give inaccurate results if source-tree has
-been modified since last genxref indexation because search is
+been modified since last F<genxref> indexation because search is
 done against an internal list captured at indexing time.
 
 =back
@@ -527,15 +538,15 @@
 	$searchtext =~ s/\+/ /g;	# Reverse <form> space encoding
 
 	my @results;
-	if ($searchtext ne "") {
+	if ($searchtext ne '') {
 		if ($config->{'glimpsebin'}) {
 			@results = glimpsesearch($searchtext, $filetext, $advanced, $casesensitive);
 		} elsif ($config->{'swishbin'} && $config->{'swishdir'}) {
 			@results = swishsearch($searchtext, $filetext, $advanced, $casesensitive);
 		} else {
-			warning("No freetext search engine configured.");
+			warning('No freetext search engine configured.');
 		}
-	} elsif ($filetext ne "") {
+	} elsif ($filetext ne '') {
 		my $FILELISTING;
 		if ($config->{'swishdir'} && $config->{'swishbin'}) {
 			unless ($FILELISTING = IO::File->new($config->{'swishdir'} . "/$releaseid.filenames")) {
@@ -547,7 +558,7 @@
 			}
 		} elsif ($config->{'glimpsedir'} && $config->{'glimpsebin'}) {
 			unless ($FILELISTING =
-				IO::File->new($config->{'glimpsedir'} . "/" . $releaseid . "/.glimpse_filenames"))
+				IO::File->new($config->{'glimpsedir'} . '/' . $releaseid . "/.glimpse_filenames"))
 			{
 				&warning(
 					"Version '$releaseid' has not been indexed and is unavailable for searching<br>Could not open "
@@ -557,7 +568,7 @@
 			}
 		} else {
 			warning(
-				"Freetext search engine required for file search, and no freetext search engine is configured"
+				'Freetext search engine required for file search, and no freetext search engine is configured'
 			);
 			return;
 		}
@@ -572,16 +583,18 @@
 
 	print expandtemplate
 		( $templ
-		,	( 'variables'          => sub { varinputs( @_) }
-			, 'searchtext'         => sub { $_ = $searchtext; s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; return $_; }
-			, 'searchtext_escaped' => sub { $_ = $searchtext; s/\"/&quot;/g; s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; return $_; }
-			, 'filetext_escaped'   => sub { $_ = $filetext; s/\"/&quot;/g; return $_; }
-			, 'advancedchecked'      => sub { return $advanced      ? "checked" : "" }
-			, 'casesensitivechecked' => sub { return $casesensitive ? "checked" : "" }
-			, 'maxhits_message'      => sub {
+		,	( 'variables'			=> \&varinputs
+			, 'searchtext'			=> sub { $_ = $searchtext; s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; return $_; }
+			, 'searchtext_escaped'	=> sub { $_ = $searchtext; s/\"/&quot;/g; s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; return $_; }
+			, 'filetext_escaped'	=> sub { $_ = $filetext; s/\"/&quot;/g; return $_; }
+			, 'advancedchecked'		=> sub { $advanced ? 'checked' : '' }
+			, 'casesensitivechecked'=> sub { $casesensitive ? 'checked' : '' }
+			, 'varbtnaction'		=> sub { varbtnaction(@_, 'search') }
+			, 'urlargs'				=> sub { urlexpand('-', 'search') }
+			, 'maxhits_message'		=> sub {
 				return @results == $maxhits
 				  ? "<b>Too many hits, displaying first $maxhits</b><br>"
-				  : "";
+				  : '';
 				}
 
 			, 'results'     => sub { printresults(@_, $searchtext, @results) }
@@ -590,9 +603,17 @@
 		);
 }
 
+
+=head2 Script entry point
+
+Builds the header and footer and launches C<search>
+for the real job.
+
+=cut
+
 httpinit;
 makeheader('search');
-if ($files->isa("LXR::Files::Plain")) {
+if ($files->isa('LXR::Files::Plain')) {
 	if	(	$config->{'glimpsebin'}
 			&& $config->{'glimpsebin'} =~ m!^(.*/)?true$!
 		||	$config->{'swishbin'}

[Lxr-commits] CVS: lxr showconfig,1.2,1.3

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv6187

Modified Files:
	showconfig 
Log Message:
showconfig: new features

Edit arrays in hash
Correct "Force all" display (tree-specific and global values no longer mixed up)
New _confall=2 for developers (really complete dump)
Variants in tree designation taken into account
Better comments
Various Perl syntax optimisations

Index: showconfig
===================================================================
RCS file: /cvsroot/lxr/lxr/showconfig,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- showconfig	21 Sep 2012 08:18:02 -0000	1.2
+++ showconfig	24 Sep 2013 08:39:05 -0000	1.3
@@ -1,6 +1,7 @@
 #!/usr/bin/perl -T
+######################################################################
 # $Id$
-
+#
 # showconfig --	Present LXR configuration as html
 #
 #	Andre J Littoz <ajl...@us...>
@@ -19,13 +20,13 @@
 # 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.
-
+#
 ######################################################################
 
 =head1 script showconfig
 
 This script shows how LXR understood the configuration parameters
-from lxr.conf file. They are displayed in tabular form:
+from F<lxr.conf> file. They are displayed in tabular form:
 
 First column: parameter name
 
@@ -35,7 +36,7 @@
 
 Fourth column: value from global parameter group
 
-With such a layout, it is easy to see if a global value is overriden
+With such a layout, it is easy to see if a global value is overridden
 by a specific one.
 
 =cut
@@ -43,7 +44,7 @@
 $CVSID = '$Id$ ';
 
 use strict;
-use lib do { $0 =~ m{(.*)/} ? "$1/lib" : "lib" };  # if LXR modules are in ./lib
+use lib do { $0 =~ m{(.*)/} ? "$1/lib" : 'lib' };  # if LXR modules are in ./lib
 
 use LXR::Common;
 use LXR::Template;
@@ -55,9 +56,8 @@
 as a ready-to-print string.
 
 The value of a key may be a simple I<string> (displayed surrounded
-with quotes), an I<array> (simply indicated with an ellipsis to limit
-recursion) or a I<hash> (recursively dumped surrounded wit curly
-braces).
+with quotes), an I<array> (dumped "as is" without checking for further
+references) or a I<hash> (recursively dumped surrounded with curly braces).
 
 =over
 
@@ -81,13 +81,20 @@
 	foreach my $k (sort keys %$h) {
 		$d .= "'$k' => ";
 	# Compute left spaces in case we need to recurse
+		$d =~ m/([^\n]*)$/s;
+		my $indent = length($1);
 		my $v = %$h->{$k};
 		if (ref($v) eq 'ARRAY') {
-			$d .= '[ ... ]';
+			$d .= '[ ' . join("\n".' 'x$indent.', ', @$v);
+			if (1 < scalar(@$v)) {
+				$d .= "\n".' 'x$indent;
+			} else {
+				$d .= ' ';
+			}
+			$d .= ']';
 		} elsif (ref($v) eq 'HASH') {
-			$d =~ m/([^\n]*)$/s;
 			$d .= "\n";
-			$d .= dumphash ($v, length($1));
+			$d .= dumphash ($v, $indent);
 		} else {
 			$d .= "'$v'";
 		}
@@ -114,7 +121,7 @@
 
 =item 1 C<$parm>
 
-a parameter name as a I<hash>
+a parameter name as a I<string>
 
 =item 1 C<$pg>
 
@@ -127,16 +134,17 @@
 sub parmvalue {
 	my $parm = shift;
 	my $pg = shift;
+	my $fallback = shift;
 
-	return '' if !exists($pg->{$parm});
-	my $val = $pg->{$parm};
+	return '' if !exists($pg->{$parm}) && !defined($fallback);
+	my $val = $pg->{$parm} // $fallback->{$parm};
 	if (ref($val) eq 'HASH') {
-		return "<pre>" . dumphash($val, 0) . "</pre>";
+		return '<pre>' . dumphash($val, 0) . '</pre>';
 	} elsif (ref($val) eq 'ARRAY') {
-		return "<pre>" . join('<br>', @$val) . "</pre>";
+		return '<pre>' . join('<br>', @$val) . '</pre>';
 	} else {
 		if ('dbpass' eq $parm) {
-			return "<h4>Hey, that's supposed to be a secret!</h4>";
+			return '<h4>Hey, that\'s supposed to be a secret!</h4>';
 		} else {
 			return "<pre>$val</pre>";
 		}
@@ -147,7 +155,7 @@
 
 =head2 C<parmexpand ($templ, $who, $pgs, $pgnr)>
 
-Function C<parmgrouplink> is a "$function" substitution function.
+Function C<parmexpand> is a "$function" substitution function.
 It returns its block (contained in C<$tmpl>) expanded for each
 accessible configuration parameter.
 
@@ -195,7 +203,7 @@
 	my @keylist = ();
 	my $parmgroup = @$pgs[$pgnr];
 	my $globgroup = @$pgs[0];
-	my $full = $HTTP->{'param'}{'_confall'} || 0;
+	my $full = $HTTP->{'param'}{'_confall'} // 0;
 
 	if ($full != 0) {
 		my %seen;
@@ -204,8 +212,12 @@
 				$seen{$key}++;
 			}
 		}
+		if (1 < $full) {
+			for (keys %$config) {
+				$seen{$_}++
+			}
+		}
 		@keylist = keys(%seen);
-		$full = 1;
 	} else {
 		@keylist = keys %{{%$parmgroup, %$globgroup}};
 	}
@@ -221,13 +233,20 @@
 					,	( 'force' => sub{ $extra ? 'conf_force' : '' }
 						, 'parm' => sub{ $parm }
 						, 'type' => sub{ 
-									my $t = ref($config->{$parm});
-									if ('HASH' eq $t || 'ARRAY' eq $t) {
-										return lc($t);
-									} else {
+										my $t = ref($config->{$parm});
+										if ('' ne $t) {
+											return lc($t);
+										}
 										return 'string';
-									} }
-						, 'val'  => sub{ parmvalue($parm, $parmgroup) }
+									}
+						, 'val'  => sub{ parmvalue	( $parm
+													, $parmgroup
+													, ( 1 < $full
+													  ? $config
+													  : undef
+													  )
+													)
+									}
 						, 'global'=> sub{
 									parmvalue($parm, $globgroup)
 										}
@@ -238,10 +257,10 @@
 }
 
 
-=head2 C<parmgrouplink ($gnr, $pgs)>
+=head2 C<parmgrouplink ($pgnr, $pgs)>
 
 Function C<parmgrouplink> is a "$variable" substitution function.
-It returns an C<< E<lt>aE<gt> >> element invoking the
+It returns an C<E<lt>AE<gt>> element invoking the
 I<showconfig> script to dump the designated parameter group.
 
 =over
@@ -269,9 +288,18 @@
 	} else {
 		return "#$pgnr <a href='"
 				. $config->treeurl($$pgs[$pgnr], $$pgs[0])
-				. "/showconfig?_parmgroup=$pgnr'>"
-				. $$pgs[$pgnr]->{'virtroot'}
-				. "</a>" ;
+				. 'showconfig'
+				. ( exists($$pgs[$pgnr]->{'treename'})
+				  ? '/'.$$pgs[$pgnr]->{'treename'}
+				  : ''
+				  )
+				. "?_parmgroup=$pgnr'> "
+				. ($$pgs[$pgnr]->{'virtroot'} // $$pgs[0]->{'virtroot'})
+				. (exists($$pgs[$pgnr]->{'treename'})
+				  ? '/&hellip;/' . $$pgs[$pgnr]->{'treename'}
+				  : ''
+				  )
+				. '</a>' ;
 	}
 }
 
@@ -281,7 +309,7 @@
 Output is controlled by a template
 
 Eventually, a specific parameter group may be dumped by passing
-its index in argument C<_parmgroup>.
+its index in URL argument C<_parmgroup>.
 This index may receive a default value through configuration parameter
 C<'parmgroupnr'>.
 
@@ -295,7 +323,8 @@
 my $who = 'showconfig';
 my @pgs = $config->readconfig();
 my $which = $HTTP->{'param'}{'_parmgroup'}
-			|| $config->{'parmgroupnr'};
+			// $config->{'parmgroupnr'}
+			// 1;
 makeheader($who);
 $templ = gettemplate	( 'htmlconfig'
 						, $errorsig
@@ -306,12 +335,18 @@
 }
 print expandtemplate
 	( $templ
-	,	( 'conffile' => sub { "<em>" . $config->{'confpath'} . "</em>" }
-		, 'virtroot' => sub { $pgs[$which]->{'virtroot'} }
-		, 'parmgroupnr' => sub { $which }
-		, 'previous' => sub { parmgrouplink($which-1, \@pgs) }
-		, 'next' => sub { parmgrouplink($which+1, \@pgs) }
-		, 'conf_parm' => sub { parmexpand (@_, $who, \@pgs, $which) }
+	,	( 'conffile'	=> sub { '<em>' . $config->{'confpath'} . '</em>' }
+		, 'virtroot'	=> sub { $pgs[$which]->{'virtroot'} }
+		, 'parmgroupnr'	=> sub { $which
+								. (1 <$HTTP->{'param'}{'_confall'}
+								  ? ' (apocalyptical)'
+								  : ''
+								  )
+								}
+		, 'varbtnaction'=> sub { varbtnaction(@_, $who) }
+		, 'previous'	=> sub { parmgrouplink($which-1, \@pgs) }
+		, 'next'		=> sub { parmgrouplink($which+1, \@pgs) }
+		, 'conf_parm'	=> sub { parmexpand (@_, $who, \@pgs, $which) }
 		)
 	);
 makefooter($who);

[Lxr-commits] CVS: lxr diff,1.31,1.32

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv5094

Modified Files:
	diff 
Log Message:
diff: fix for bug #239, better handling of left pane overflow

Bug #239: links in left pane were computed using the cirrent value of 'variables' instead of the set used to select the version to compare to.

Also, better comments and various Perl syntax optimisations

Index: diff
===================================================================
RCS file: /cvsroot/lxr/lxr/diff,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- diff	11 Jan 2013 14:43:47 -0000	1.31
+++ diff	24 Sep 2013 08:14:36 -0000	1.32
@@ -1,6 +1,8 @@
 #!/usr/bin/perl -T
+######################################################################
+#
 # $Id$
-
+#
 # diff --	Display diff output with markup.
 #
 #	Arne Georg Gleditsch <ar...@if...>
@@ -20,7 +22,7 @@
 # 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.
-
+#
 ######################################################################
 
 $CVSID = '$Id$ ';
@@ -28,39 +30,166 @@
 use strict;
 use lib do { $0 =~ m{(.*)/} ? "$1/lib" : "lib" }; # if LXR modules are in ./lib
 
+=head1 diff script
+
+This script manages display of code differences between
+two versions of a source file.
+
+=cut
+
 use LXR::Common;
 use LXR::Markup;
 use LXR::Template;
 use Local;
 use FileHandle;
 
-sub htmlsub {
-	my ($s, $l) = @_;
-	my @s = split(/(<[^>]*>|&[\#\w\d]+;?)/, $s);
+
+=head2 C<fflush ()>
+
+Function C<fflush> sets STDOUT in autoflush mode.
+
+B<Note:>
+
+=over
+
+=item
+
+The reason for using this function is not clear.
+It has been commented out without adverse effect.
+
+Being very short, it could be inlined (only one usage!)
+if it needs to be reenabled.
+
+=back
+
+=cut
+
+# sub fflush {
+# 	$| = 1;
+# 	print('');
+# }
+
+
+=head2 C<htmljust ($s, $l)>
+
+Function C<htmljust> returns an HTML string justified to exactly
+a fixed number of screen positions.
+
+=over
+
+=item 1 C<$s>
+
+a I<string> containing an HTML sequence
+
+=item 1 C<$w>
+
+an I<integer> defining the justification width
+
+=back
+
+The string argument is truncated or expanded to show exactly
+C<$w> "characters" on screen.
+
+Atomic units must not be split, otherwise HTML integrity is broken.
+HTML tags and entity references are copied without truncation.
+
+When checking overflow, HTML tags are considered as zero-width "characters"
+and HTML entity references as one screen position glyphs
+(which is not always the case: combining diacritic marks,
+zero-width spacers, ...).
+
+When the desired width is met, opening tags may not have been matched
+by their closing tags. To return a synctactically correct HTML
+sequence, HTML tags are still copied but without their content.
+This results in a sequence longer than necessary, but it is safe.
+
+=cut
+
+sub htmljust {
+	my ($s, $w) = @_;
+	my @s = split(/(<.*?>|&[\#\w\d]+;)/, $s);
 	$s = '';
 
-	while (@s) {
-		my $f = substr(shift(@s), 0, $l);
-		$l -= length($f);
-		$s .= $f;
-		$f = shift(@s);
-		if ($f =~ /^&/) {
-			if ($l > 0) {
+	while (@s){
+		my $f = shift(@s);
+		next if $f eq '';
+		if ('<' eq substr($f, 0, 1)) {
+		# HTML tag element: no screen position, copy it
+			$s .= $f
+		} elsif ('&' eq substr($f, 0, 1)) {
+		# HTML entity reference: one screen position usually
+		# Copy it space permitting
+			if ($w > 0) {
 				$s .= $f;
-				$l--;
+				$w--;
 			}
 		} else {
+		# Ordinary text, check for truncation
+			$f = substr($f, 0, $w);
+			$w -= length($f);
 			$s .= $f;
 		}
 	}
-	$s .= ' ' x $l;
+	# Add spaces up to the requested width
+	$s .= ' ' x $w;
 	return $s;
 }
 
+
+=head2 C<printdiff (@dargs)>
+
+Procedure C<printdiff> is the main driver for difference display
+(two passes).
+
+=over
+
+=item 1 C<@dargs>
+
+an I<array> containing the C<'variables'> values for the reference version
+
+=back
+
+When entered for the first time, query arguments only offer current
+C<'variables'> values.
+This is detected by the absence of any C<~>I<var_name>C<=>... argument.
+Current values are then transfered into these so-called I<remembered>
+values and user is requested to choose another version.
+
+On second entry, both current values (I<var_name>C<=>...) and
+remembered values (C<~>I<var_name>C<=>...) are present in the
+query arguments.
+The latter values designate the reference version (in the left pane);
+the former values the "new" version (in the right pane).
+With these two file descriptions, processing can be done.
+
+The file name in C<$pathname> has been nominally transformed by the
+C<'maps'> rules.
+But to get the other name, we must first reverse the effects of these
+rules (in the remembered environment) et re-apply them (in the current
+environment).
+Once this is done, both file names correctly point to the desired
+versions.
+
+Next, physical (real) files are obtained so that I<rcs B<diff>> can
+build the patch directives..
+
+Both files are highlighted by C<markupfile>.
+The resulting HTML streams are kept in memory.
+I<This could cause a serious strain on memory and degrade performance
+(because of swapping for instance).>
+
+Then it is relatively simple to merge both streams line by line
+under control of the patch directives.
+
+
+=cut
+
 sub printdiff {
 	my (@dargs) = @_;
 
 	unless (defined @dargs) {
+	# First pass through the script
+	# Request second version
 		my @vars;
 		foreach ($config->allvariables) {
 			if	(!exists($config->{'variables'}{$_}{'when'})
@@ -70,24 +199,26 @@
 			}
 		}
 
-		$vars[ $#vars - 1 ] .= " or " . pop(@vars) if $#vars > 0;
+		$vars[ $#vars - 1 ] .= ' or ' . pop(@vars) if $#vars > 0;
 
-		print(
-			"<p align=\"center\">\n",
-			"Please indicate the version of the file you wish to\n",
-			"compare to by clicking on the appropriate\n",
-			join(", ", @vars),
-			" button.\n", "</p>\n"
-		);
+		print	( "<p align=\"center\">\n"
+				, "Please indicate the version of the file you wish to\n"
+				, "compare to by clicking on the appropriate\n"
+				, join(', ', @vars)
+				, " button.\n"
+				, "</p>\n"
+				);
 		return;
 	}
 
-	if ($pathname =~ m|/$|) {
+	# Second pass - both versions are known
+	if ('/' eq substr($pathname, -1)) {
 		print("<h3 align=\"center\">Diff not yet supported for directories.</h3>\n");
 		return;
 	}
 	my $origname = $pathname;
-
+	# Tentatively reverse the effect of mappath on $pathname to get an "early bird"
+	# skeleton path on which to apply the mapping rules in the current environment.
 	my $diffname = $config->mappath($config->unmappath($pathname, @dargs));
 	my ($diffv) = grep(m/v=/, @dargs);
 	$diffv =~ s/v=//;
@@ -101,14 +232,14 @@
 		return;
 	}
 
-	fflush;
+# 	fflush;
 	# realfilename may create a temporary file
 	# which should be released when no longer needed
 	my $origtemp = $files->realfilename($origname, $releaseid);
 	my $difftemp = $files->realfilename($diffname, $diffv);
 	$ENV{'PATH'} = '/usr/local/bin:/usr/bin:/bin:/usr/sbin';
-	unless (open(DIFF, "-|")) {
-		open(STDERR, ">&STDOUT");
+	unless (open(DIFF, '-|')) {
+		open(STDERR, '>&STDOUT');
 		exec('diff', '-U0', $origtemp, $difftemp);
 		print STDERR "*** Diff subprocess died unexpextedly: $!\n";
 		exit;
@@ -148,46 +279,65 @@
 	}
 	close(DIFF);
 
+	#	Print a descriptive title and tell exactly what versions
+	#	are compared (dump the variable value sets)
 	print	( "<h1>Diff markup</h1>\n"
-			, "<h2>between "
-			, fileref	( "$origname"
-						, "diff-fref", $origname
+			, '<h2>between '
+			, fileref	( $origname
+						, 'diff-fref'
+						, $origname
 						)
-			, " ("
+			, ' <small>('
 			);
 	my @fctx;
-	for ($config->allvariables) {
-		next if	exists($config->{'variables'}{$_}{'when'})
-				&& !eval($config->varexpand($config->{'variables'}{$_}{'when'}));
-		push (@fctx, $config->vardescription($_).": ".$config->variable($_));
+	for my $var ($config->allvariables) {
+		next if	exists($config->{'variables'}{$var}{'when'})
+				&& !eval($config->varexpand($config->{'variables'}{$var}{'when'}));
+		my ($varval) = grep(m/$var=/, @dargs);
+		$varval =~ s/$var=//;
+		push (@fctx, $config->vardescription($var).': '.$varval);
 	}
-	print	( join(", ", @fctx)
-			, ")<br>"
-			, " and "
+	print	( join(', ', @fctx)
+			, ')</small><br>'
+			, ' and '
 			);
-	my @linkargs = grep {m/(.*?)=(.*)/; $config->variable($1) ne "$2";} @dargs;
+	my @linkargs = grep {m/(.*?)=(.*)/; $config->variable($1) ne $2;} @dargs;
 	map (s/(.*?)=/!$1=/, @linkargs);
-	print	( fileref	( "$diffname",
-						, "diff-fref", $diffname, undef
+	print	( fileref	( $diffname
+						, 'diff-fref'
+						, $diffname
+						, undef
 						, @linkargs
 						)
-			, " ("
+			, ' <small>('
 			);
 	@fctx = ();
 	for my $var ($config->allvariables) {
 		next if	exists($config->{'variables'}{$var}{'when'})
 				&& !eval($config->varexpand($config->{'variables'}{$var}{'when'}));
-		my ($varval) = grep(m/$var=/, @dargs);
-		$varval =~ s/$var=//;
-		push (@fctx, $config->vardescription($var).": $varval");
+		push (@fctx, $config->vardescription($var).': '.$config->variable($var));
 	}
-	print	( join(", ", @fctx)
-			, ")</h2><hr>\n"
+	print	( join(', ', @fctx)
+			, ")</small></h2><hr>\n"
 			);
 
+	#	Highlight both files
 	my $origh = FileHandle->new($origtemp);
+	#	Save current environment before switching to @dargs environment
+	my %oldvars;
+	foreach my $arg (@dargs) {
+		if ($arg =~ m/(.*?)=(.*)/) {
+			$oldvars{$1} = $config->variable($1);
+			$config->variable($1, $2);
+		}
+	}
 	my $orig  = '';
 	markupfile($origh, sub { $orig .= shift });
+	#	Restore original environment
+	while ((my $var, my $val) = each %oldvars) {
+		$config->variable($var, $val);
+	}
+	%oldvars = {};
 	my $len = $. + $ofs;
 	$origh->close;
 	$files->releaserealfilename($origtemp);
@@ -202,6 +352,7 @@
 
 	$pathname = $origname;
 
+	#	Output both versions side by side
 	my $i;
 	$i = 1;
 	$orig =~ s/^/"\n" x ($orig{$i++})/mge;
@@ -216,24 +367,24 @@
 					|| 50;
 	print("<pre class=\"filecontent\">\n");
 	foreach $i (0 .. $len) {
-		my $o = htmlsub($orig[$i], $leftwidth);
+		my $o = htmljust($orig[$i], $leftwidth);
 		my $n = $new[$i];
 
-		my $diffmark = "  ";
+		my $diffmark = '  ';
 		if ($chg{ $i + 1 }) {
-			$diffmark = "<span class=\"diff-mark\">" . $chg{ $i + 1 } . "</span>";
-			if ("&lt;&lt;" eq $chg{ $i + 1 }) {
-				$o =~ s|</a> |</a> <span class=\"diff-left\">|;
+			$diffmark = '<span class="diff-mark">' . $chg{ $i + 1 } . "</span>";
+			if ('&lt;&lt;' eq $chg{ $i + 1 }) {
+				$o =~ s|</a> |</a> <span class="diff-left">|;
 			}
-			if ("&gt;&gt;" eq $chg{ $i + 1 }) {
-				$n =~ s|</a> |</a> <span class=\"diff-right\">|;
+			if ('&gt;&gt;' eq $chg{ $i + 1 }) {
+				$n =~ s|</a> |</a> <span class="diff-right">|;
 			}
-			if ("!!" eq $chg{ $i + 1 }) {
-				$o =~ s|</a> |</a> <span class=\"diff-both\">|;
-				$n =~ s|</a> |</a> <span class=\"diff-both\">|;
+			if ('!!' eq $chg{ $i + 1 }) {
+				$o =~ s|</a> |</a> <span class="diff-both">|;
+				$n =~ s|</a> |</a> <span class="diff-both">|;
 			}
-			$o .= "</span>";
-			$n .= "</span>";
+			$o .= '</span>';
+			$n .= '</span>';
 		}
 
 		#print("$o <span class=\"diff-mark\">",
@@ -244,6 +395,14 @@
 
 }
 
+
+=head2 Script entry point
+
+Builds the header and footer and launches C<printdiff>
+for the real job.
+
+=cut
+
 httpinit;
 
 makeheader('diff');
@@ -251,8 +410,8 @@
 foreach my $param (keys %{$HTTP->{'param'}}) {
 	my $var = $param;
 	next unless $var =~ s/^~//;
-	if (exists($config->{'variables'}->{$var})) {
-			push @dargs, "$var=" . $HTTP->{'param'}->{$param};
+	if (exists($config->{'variables'}{$var})) {
+			push @dargs, "$var=" . $HTTP->{'param'}{$param};
 	}
 }
 printdiff(@dargs);

[Lxr-commits] CVS: lxr/lib/LXR/Lang Java.pm, 1.11, 1.12 Python.pm, 1.10, 1.11

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Lang
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv4431/lib/LXR/Lang

Modified Files:
	Java.pm Python.pm 
Log Message:
Lang/java.pm, Lang/Python.pm: update include processing after change in Common.pm & Lang.pm

Index: Java.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Lang/Java.pm,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- Java.pm	12 Apr 2013 15:01:09 -0000	1.11
+++ Java.pm	24 Sep 2013 07:59:19 -0000	1.12
@@ -57,7 +57,7 @@
 		$path    = $file;
 		$path =~ s@\.@/@g;		# Replace Java delimiters
 		$link = $self->_linkincludedirs
-					( &LXR::Common::incdirref
+					( &LXR::Lang::incdirref
 							($file, "include", $path, $dir)
 					, $file
 					, '.'
@@ -83,7 +83,7 @@
 		$class   = $3;
 		$path =~ s@\.@/@g;		# Replace Java delimiters
 		$link = $self->_linkincludedirs
-					( &LXR::Common::incdirref
+					( &LXR::Lang::incdirref
 							($file, "include", $path, $dir)
 					, $file
 					, '.'

Index: Python.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Lang/Python.pm,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- Python.pm	21 Sep 2013 12:54:53 -0000	1.10
+++ Python.pm	24 Sep 2013 07:59:19 -0000	1.11
@@ -110,7 +110,7 @@
 		#		this would suppress the possibility to click-link to
 		#		the directory itself.
 		$path =~ s@\.py$@@;	# Remove file extension
-		$link = &LXR::Common::incdirref($file, "include", $path, $dir);
+		$link = &LXR::Lang::incdirref($file, 'include', $path, $dir);
 		# Erase last path separator from <a> link to enable
 		# following partial path processing.
 		# NOTE: this creates a dependency of link structure from incref!

[Lxr-commits] CVS: lxr/lib/LXR Template.pm,1.25,1.26

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv4220/lib/LXR

Modified Files:
	Template.pm 
Log Message:
Template.pm: new variants in tree designation, better HTTP security

Also, better comments and various Perl source optimisations

Index: Template.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Template.pm,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- Template.pm	5 Jun 2013 17:01:41 -0000	1.25
+++ Template.pm	24 Sep 2013 07:52:05 -0000	1.26
@@ -42,6 +42,8 @@
 our @EXPORT = qw(
 	gettemplate
 	expandtemplate
+	varbtnaction
+	urlexpand
 	makeheader
 	makefooter
 	makeerrorpage
@@ -71,9 +73,10 @@
 =item 1 C<$prefix>
 
[...975 lines suppressed...]
 sub makeerrorpage {
@@ -1644,14 +1742,15 @@
 					);
 
 # Emit a simple HTTP header
-	print("Content-Type: text/html; charset=iso-8859-1\n");
-	print("\n");
+# 	print("Content-Type: text/html; charset=iso-8859-1\n");
+# 	print("\n");
 
 	print(
 		expandtemplate
 		(	$template
-		,	( 'target' =>  sub { targetexpand(@_, $who) }
+		,	( 'target'     =>  sub { targetexpand(@_, $who) }
 			, 'stylesheet' => \&stylesheet
+			, 'baseurl'    => \&baseurl
 			, 'LXRversion' => sub { "%LXRRELEASENUMBER%" }
 			)
 		)

[Lxr-commits] CVS: lxr/lib/LXR Common.pm, 1.103, 1.104 Lang.pm, 1.51, 1.52

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv3740/lib/LXR

Modified Files:
	Common.pm Lang.pm 
Log Message:
Common.pm, Lang.pm: move include file management code from Common.pm to Lang.pm; new variants for tree designation in initialisation code

Better comments, various Perl syntax optimisations

Also in Common.pm: allow for HTML error messages even before HTTP initialisation with careful check of HTTP state, remove unused code

Index: Common.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Common.pm,v
retrieving revision 1.103
retrieving revision 1.104
diff -u -d -r1.103 -r1.104
--- Common.pm	11 Jan 2013 17:35:51 -0000	1.103
+++ Common.pm	24 Sep 2013 07:36:09 -0000	1.104
@@ -26,7 +26,9 @@
 
 =over
 
-I<It initially contained nearly all support routines,
+=item
+
+I<It initially contained nearly all support routines
 but for the "object" collections (files, index, lang), and was
 then correctly the "common" module.
 Its size grew beyond maintanability and readability and forced a
@@ -53,18 +55,11 @@
 	$HTTP
 	$pathname $releaseid $identifier
 	&warning &fatal
-	&fflush
 	&urlargs &nonvarargs &fileref &diffref &idref &incref
 	&httpinit &httpclean
 );
-# our @EXPORT_OK = qw(
-#   &abortall 
-#   );
-
-# our %EXPORT_TAGS = ('html' => [@EXPORT_OK]);
 
 require Local;
-require LXR::SimpleParse;
 require LXR::Config;
 require LXR::Files;
 require LXR::Index;
@@ -79,11 +74,16 @@
 our $identifier;
 our $HTTP;
 
+# Debugging flag - MUST be set to zero before public release
 my $wwwdebug = 0;
 
 # Initial value of temp file counter (see sub tmpcounter below)
 my $tmpcounter = 23;
 
+# Flag telling if HTTP headers have sent, thus allowing to emit
+# HTML code freely
+my $HTTP_inited;
+
 
 #######################################
 #
@@ -91,13 +91,6 @@
 #
 # HTML display is effective only when $wwwdebug is non zero
 
-# TODO:	update these functions so that they can be used
-#		even before sub httpinit has been called to provide
-#		a safe and reliable debugging display.
-# Hint:	create a flag telling if HTTP headers have already been
-#		sent; if not, ouput a minimal set of headers to allow
-#		for HTML environment.
-
 
 =head2 C<warning ($msg)>
 
@@ -113,17 +106,22 @@
 =back
 
 The message is prefixed with Perl context information.
-It is printed both on STDERR and in the HTML stream.
+It is printed on STDERR and returned as an HTML fragment
+for whatever use of the caller (usually printing).
 
 To prevent HTML mayhem, HTML tag delimiters are replaced by their
 entity name equivalent.
 
+I<This function is called after successful initialisation.
+There is no need to check for HTTP state,
+since early errors are fatal and handled by the next function.>
+
 =cut
 
 sub warning {
 	my $msg = shift;
-	my $c = join(", line ", (caller)[ 0, 2 ]);
-	print(STDERR "[", scalar(localtime), "] warning: $c: $msg\n");
+	my $c = join(', line ', (caller)[ 0, 2 ]);
+	print(STDERR '[', scalar(localtime), "] warning: $c: $msg\n");
 	$msg =~ s/</&lt;/g;
 	$msg =~ s/>/&gt;/g;
 	return ("<h4 class=\"warning\"><i>** Warning: $msg</i></h4>\n")
@@ -149,92 +147,49 @@
 
 The message is printed both on STDERR and in the HTML stream.
 
-B<Notes:>
+I<Note>:
 
 =over
 
-The message should be protected against HTML abuse by replacing
-the HTML tag delimiters by their entity name equivalent.
+=item
 
-Since LXR is exited immediately, the HTML stream is not properly
-closed. This may cause problem in some browsers.
+I<The message may be emitted after the final closing
+E<lt>/C<HTML>E<gt> tag if some regular HTML precedes the call
+to this subroutine.
+This is not HTML-compliant.
+Some browsers may complain.>
 
 =back
 
 =cut
 
 sub fatal {
-	my $c = join(", line ", (caller)[ 0, 2 ]);
-	print(STDERR "[", scalar(localtime), "] fatal: $c: $_[0]\n");
-	print(STDERR '[@INC ', join(" ", @INC), ' $0 ', $0, "\n");
-	print(STDERR '$config', join(" ", %$config), "\n") if ref($config) eq "HASH";
-	print("<h4 class=\"fatal\"><i>** Fatal: $_[0]</i></h4>\n")
-		if $wwwdebug;
-	exit(1);
-}
-
-
-=head2 C<abortall ($msg)>
-
-Function C<abortall> issues an error message and quits.
-
-=over
-
-=item 1 C<$msg>
-
-a I<string> containing the message
-
-=back
-
-Perl context information is given (on STDERR).
-
-A minimal error page is sent to the user (if $wwwdebug is non zero).
-
-B<Notes:>
-
-=over
-
-The message should be protected against HTML abuse by replacing
-the HTML tag delimiters by their entity name equivalent.
-
-=back
-
-=cut
-
-sub abortall {
-	my $c = join(", line ", (caller)[ 0, 2 ]);
-	print(STDERR "[", scalar(localtime), "] abortall: $c: $_[0]\n");
-	print	( "Content-Type: text/html; charset=iso-8859-1\n\n"
-			, "<html>\n<head>\n<title>Abort</title>\n</head>\n"
-			, "<body><h1>Abort!</h1>\n"
-			, "<b><i>** Aborting: $_[0]</i></b>\n"
-			, "</body>\n</html>\n"
-			)
-		if $wwwdebug;
+	my $msg = shift;
+	my $c = join(', line ', (caller)[ 0, 2 ]);
+	print(STDERR '[', scalar(localtime), "] fatal: $c: $msg\n");
+	print(STDERR '[@INC ', join(' ', @INC), ' $0 ', $0, "\n");
+	print(STDERR '$config', join(' ', %$config), "\n")
+		if ref($config) eq 'HASH';
+	# If HTTP is not yet initialised, emit a minimal set of headers
+	if ($wwwdebug) {
+		if (!$HTTP_inited) {
+			print 'Content-Type: text/html; charset=utf-8', "\n";
+			#Since this a transient error, don't keep it in cache
+			print 'Expires: Thu, 01 Jan 1970 00:00:00 GMT', "\n";
+			print "\n";
+			print '<html><head><title>LXR Fatal Error!</title></head>', "\n";
+			print '<body>', "\n";
+		};
+		$msg =~ s/</&lt;/g;
+		$msg =~ s/>/&gt;/g;
+		print "<h4 class=\"fatal\"><i>** Fatal: $msg</i></h4>\n";
+		# Properly close the HTML stream
+		print '</body></html>', "\n";
+	}
 	exit(1);
 }
 
 
-=head2 C<fflush ()>
-
-Function C<fflush> sets STDOUT in autoflush mode.
-
-B<Note:>
-
-=over
-
-This sub is no longer needed and is a candidate for removal.
-
-=back
-
-=cut
-
-sub fflush {
-	$| = 1;
-	print('');
-}
-
-
 =head2 C<tmpcounter ()>
 
 Function C<tmpcounter> returns a unique id for numbering temporary files.
@@ -266,11 +221,10 @@
 sub nonvarargs {
 	my @args;
 
-	foreach my $param (keys %{$HTTP->{'param'}}) {
-		next unless $param =~ m!^_!;
-		my $val = $HTTP->{'param'}{$param};
+	while ((my $param, my $val) = each %{$HTTP->{'param'}}) {
+		next unless substr($param, 0, 1) eq '_';
 		if (length($val)) {
-			push(@args, "$param=$HTTP->{'param'}{$param}");
+			push(@args, "$param=$val");
 		}
 	}
 
@@ -308,7 +262,7 @@
 	my $val;
 
 	foreach (@args) {
-		$args{$1} = $2 if /(\S+)=(\S*)/;
+		$args{$1} = $2 if m/(\S+)=(\S*)/;
 	}
 	@args = ();
 
@@ -318,8 +272,10 @@
 		delete($args{$_});
 	}
 
-	foreach (keys(%args)) {
-		push(@args, "$_=$args{$_}");
+	while ((my $param, $val) = each(%args)) {
+		$param = http_encode($param);
+		$val   = http_encode($val);
+		push(@args, "$param=$val");
 	}
 
 	return ($#args < 0 ? '' : '?' . join('&', @args));
@@ -328,7 +284,7 @@
 
 =head2 C<fileref ($desc, $css, $path, $line, @args)>
 
-Function C<fileref> returns an C<< E<lt>AE<gt> >> link to a specific line
+Function C<fileref> returns an C<E<lt>AE<gt>> link to a specific line
 of a source file.
 
 =over
@@ -367,7 +323,7 @@
 =item 1 Since line anchor ids in LXR are at least 4 characters in length,
 the line number is eventually extended with zeros on the left.
 
-= item 1 The @args argument is used to pass state and makes use of sub
+=item 1 The @args argument is used to pass state and makes use of sub
 C<urlargs>.
 
 =back
@@ -377,21 +333,31 @@
 sub fileref {
 	my ($desc, $css, $path, $line, @args) = @_;
 
-	# jwz: URL-quote any special characters.
-	$path =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
+	# Protect against malicious attacks
+	$path = http_encode($path);
+	$desc =~ s/&/&amp;/g;
+	$desc =~ s/</&lt;/g;
+	$desc =~ s/>/&gt;/g;
 
 	if ($line > 0 && length($line) < 4) {
 		$line = ('0' x (4 - length($line))) . $line;
 	}
 
-	return	( "<a class='$css' href=\"$config->{virtroot}/source$path"
+	return	( "<a class='$css' href=\""
+				. $config->{'virtroot'}
+				. 'source'
+				. ( exists($config->{'treename'})
+				  ? '/'.$config->{'treename'}
+				  : ''
+				  )
+				. $path
 			. &urlargs	( ($HTTP->{'param'}{'_showattic'}
-						  ? "_showattic=1"
-						  : ""
+						  ? '_showattic=1'
+						  : ''
 						  )
 						, @args
 						)
-			. ($line > 0 ? "#$line" : "")
+			. ($line > 0 ? "#$line" : '')
 			. "\"\>$desc</a>"
 			);
 }
@@ -399,7 +365,7 @@
 
 =head2 C<diffref ($desc, $css, $path, @args)>
 
-Function C<diffref> returns an C<< E<lt>AE<gt> >> link for the first
+Function C<diffref> returns an C<E<lt>AE<gt>> link for the first
 step of difference display selection.
 
 =over
@@ -435,8 +401,19 @@
 sub diffref {
 	my ($desc, $css, $path, @args) = @_;
 
-	$path =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
-	return	( "<a class='$css' href=\"$config->{virtroot}/diff$path"
+	# Protect against malicious attacks
+	$path = http_encode($path);
+	$desc =~ s/&/&amp;/g;
+	$desc =~ s/</&lt;/g;
+	$desc =~ s/>/&gt;/g;
+	return	( "<a class='$css' href=\""
+				. $config->{'virtroot'}
+				. 'diff'
+				. ( exists($config->{'treename'})
+				  ? '/'.$config->{'treename'}
+				  : ''
+				  )
+				. $path
 			. &urlargs	( &nonvarargs()
 						, @args
 						)
@@ -447,7 +424,7 @@
 
 =head2 C<idref ($desc, $css, $id, @args)>
 
-Function C<idref> returns an C<< E<lt>AE<gt> >> link to the cross
+Function C<idref> returns an C<E<lt>AE<gt>> link to the cross
 reference list of an identifier.
 
 =over
@@ -479,72 +456,31 @@
 
 sub idref {
 	my ($desc, $css, $id, @args) = @_;
-	return ("<a class='$css' href=\"$config->{virtroot}/ident"
-		  . &urlargs	( ($id ? "_i=$id" : "")
+
+	# Protect against malicious attacks
+	$id = http_encode($id);
+	$desc =~ s/&/&amp;/g;
+	$desc =~ s/</&lt;/g;
+	$desc =~ s/>/&gt;/g;
+	return	( "<a class='$css' href=\""
+				. $config->{'virtroot'}
+				. 'ident'
+				. ( exists($config->{'treename'})
+				  ? '/'.$config->{'treename'}
+				  : ''
+				  )
+			. &urlargs	( ($id ? "_i=$id" : '')
 						, &nonvarargs()
 						, @args
 						)
-		  . "\"\>$desc</a>");
-}
-
-
-=head2 C<incfindfile ($filewanted, $file, @paths)>
-
-Function C<incfindfile> returns the "real" path corresponding to argument
-C<$file>.
-
-=over
-
-=item 1 C<$filewanted>
-
-a I<flag> indicating if a directory (0) or file (1) is desired
-
-=item 1 C<$file>
-
-a I<string> containing a file name
-
-=item 1 C<@paths>
-
-an I<array> containing a list of directories to search
-
-=back
-
-The list of directories from configuration parameter C<'incprefix'> is
-appended to C<@paths>. Every directory from this array is then preprended
-to the file name . The resulting string is transformed by the mapping
-rules of configuration parameter C<'maps'> (sub C<mappath>).
-
-If there is a match in the file database (file or directory according
-to the first argument), the "physical" path is returned.
-Otherwise, an C<undef> is return to signal an unknown file.
-
-I<This is an internal sub only.>
-
-=cut
-
-sub incfindfile {
-	my ($filewanted, $file, @paths) = @_;
-	my $path;
-
-	push(@paths, $config->incprefix);
-
-	foreach my $dir (@paths) {
-		$dir =~ s/\/+$//;
-		$path = $config->mappath($dir . "/" . $file);
-		if ($filewanted){
-			return $path if $files->isfile($path, $releaseid);
-		} else {
-			return $path if $files->isdir($path, $releaseid);
-		}
-	}
-
-	return undef;
+			. "\"\>$desc</a>"
+			);
 }
 
 
 =head2 C<incref ($name, $css, $file, @paths)>
 
-Function C<incref> returns an C<< E<lt>AE<gt> >> link to an C<include>d
+Function C<incref> returns an C<E<lt>AE<gt>> link to an C<include>d
 file or C<undef> if the file is unknown.
 
 =over
@@ -578,7 +514,7 @@
 	my ($name, $css, $file, @paths) = @_;
 	my $path;
 
-	$path = incfindfile(1, $file, @paths);
+	$path = &LXR::Lang::_incfindfile(1, $file, @paths);
 	return undef unless $path;
 	return &fileref	( $name
 					, $css
@@ -587,59 +523,6 @@
 }
 
 
-=head2 C<incdirref ($name, $css, $file, @paths)>
-
-Function C<incdirref> returns an C<< E<lt>AE<gt> >> link to a directory
-of an C<include>d file or the directory name if it is unknown.
-
-=over
-
-=item 1 C<$name>
-
-a I<string> for the user-visible part of the link,
-usually the directory name
-
-=item 1 C<$css>
-
-a I<string> containing the CSS class for the link
-
-=item 1 C<$file>
-
-a I<string> containing the HTML path to the directory
-
-=item 1 C<@paths>
-
-an I<array> containing a list of base directories to search
-
-=back
-
-I<<This function is supposed to be called AFTER sub C<incref> on every
-subpath of the include'd file, removing successively the tail directory.
-It thus allows to compose a path where each directory is separately
-clickable.>>
-
-If the include'd directory does not exist (as determined by sub C<incfindfile>),
-the function returns the directory name. This acts as a "no-op" in the
-HTML sequence representing the full path of the include'd file.
-
-If the directory exists, the function returns the E<lt>AE<gt> link
-as computed by sub C<fileref> for the directory.
-
-=cut
-
-sub incdirref {
-	my ($name, $css, $file, @paths) = @_;
-	my $path;
-
-	$path = incfindfile(0, $file, @paths);
-	return $name unless $path;
-	return &fileref	( $name
-					, $css
-					, $path.'/'
-					);
-}
-
-
 #######################################
 #
 #	HTTP management functions
@@ -673,6 +556,27 @@
 }
 
 
+=head2 C<http_encode ($name)>
+
+Function C<http_encode> returns its argument URL-quoted.
+
+=over
+
+=item 1 C<$name>
+
+a I<string> to URL-quote
+
+=back
+
+=cut
+
+sub http_encode {
+	my $t = shift;
+	return undef if !defined $t;
+	$t =~ s|([^-a-zA-Z0-9.@/_~\r\n])|sprintf('%%%02X', ord($1))|ge;
+	return $t
+}
+
 =head2 C<fixpaths ($node)>
 
 Function C<fixpaths> fixes its node argument to prevent unexpected
@@ -688,7 +592,7 @@
 
 This is a security function. If the node argument contains any
 C</../> part, it is removed with the preceding part.
-Also all repeating C</> are replaced by a single slash.
+Also C</./> and all repeating C</> are replaced by a single slash.
 
 The OS will then be presented only "canonical" paths without access
 computation, minimizing the risk of unwanted access.
@@ -697,6 +601,8 @@
 
 =over
 
+=item
+
 Caution! Any use of this sub before full LXR context initialisation
 (i.e. before return from sum C<httpinit>) is doomed to fail
 because the test for directory type needs a proper value in
@@ -711,7 +617,7 @@
 	my $node = '/' . shift;
 
 	while ($node =~ s|/[^/]+/\.\./|/|g) { }
-	$node =~ s|/\.\./|/|g;
+	$node =~ s|/\.\.?/|/|g;
 
 	$node .= '/' if $files->isdir($node, $releaseid);
 	$node =~ s|//+|/|g;
@@ -720,6 +626,21 @@
 }
 
 
+=head2 C<httpminimal ()>
+
+Function C<printhttp> ouputs minimal HTTP headers.
+
+=cut
+
+sub httpminimal {
+	print 'Content-Type: text/html; charset=utf-8', "\n";
+	#Since this a transient error, don't keep it in cache
+	print 'Expires: Thu, 01 Jan 1970 00:00:00 GMT', "\n";
+	print "\n";
+	$HTTP_inited = 1;
+}
+
+
 =head2 C<printhttp ()>
 
 Function C<printhttp> ouputs the HTTP headers.
@@ -740,7 +661,7 @@
 	# Made it stat all currently loaded modules.  -- agg.
 
 	my $time = $files->getfiletime($pathname, $releaseid);
-	my $time2 = (stat($config->confpath))[9];
+	my $time2 = (stat($config->{'confpath'}))[9];
 	$time = $time2 if !defined $time || $time2 > $time;
 
 	# Remove this to see if we get a speed increase by not stating all
@@ -763,9 +684,9 @@
 
 	if ($time > 0) {
 		my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
-		my @days = ("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun");
+		my @days = ('Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat', 'Sun');
 		my @months =
-		  ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
+		  ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
 		$year += 1900;
 		$wday = $days[$wday];
 		$mon  = $months[$mon];
@@ -783,17 +704,20 @@
 			'html' => 'text/html'
 		);
 
-		if ($pathname =~ /\.([^.]+)$/ && $type{$1}) {
-			print("Content-Type: ", $type{$1}, "\n");
+		if	(	$pathname =~ m/\.([^.]+)$/
+			&&	exists($type{$1})
+			) {
+			print('Content-Type: ', $type{$1}, "\n");
 		} else {
 			print("Content-Type: text/plain\n");
 		}
 	} else {
-		print("Content-Type: text/html; charset=", $config->{'encoding'}, "\n");
+		print('Content-Type: text/html; charset=', $config->{'encoding'}, "\n");
 	}
 
 	# Close the HTTP header block.
 	print("\n");
+	$HTTP_inited = 1;
 }
 
 
@@ -816,7 +740,7 @@
 
 =item 1 exclamation mark (C<!>): override C<'variables'> value
 
-=item 1 tilde (C<~>): differrence C<'variables'>
+=item 1 tilde (C<~>): difference C<'variables'>
 
 =item 1 underscore (C<_>): LXR operational parameter
 
@@ -829,45 +753,86 @@
 sub httpinit {
 	$SIG{__WARN__} = \&warning;
 	$SIG{__DIE__}  = \&fatal;
+	$HTTP_inited = undef;
+	my $olddebug = $wwwdebug;
+	$wwwdebug = 1;	# Display something for early errors
+					# instead of leaving user with a blank screen
 
 	$ENV{'PATH'} = '/bin:/usr/local/bin:/usr/bin:/usr/sbin';
 
 	# Parse and split URL
 	$HTTP->{'path_info'} = http_wash($ENV{'PATH_INFO'});
-
 	$HTTP->{'path_info'} = clean_path($HTTP->{'path_info'});
-	$HTTP->{'path_info'} = '/' if $HTTP->{'path_info'} eq "";
-	$HTTP->{'this_url'} = 'http://' . $ENV{'SERVER_NAME'};
-	$HTTP->{'this_url'} .= ':' . $ENV{'SERVER_PORT'}
-	  if $ENV{'SERVER_PORT'} != 80;
-	$HTTP->{'this_url'} .= $ENV{'SCRIPT_NAME'};
-	my $script_path = $HTTP->{'this_url'};
+	$HTTP->{'path_info'} = '/' if $HTTP->{'path_info'} eq '';
+	($HTTP->{'path_root'})
+		= $HTTP->{'path_info'} =~ m!^/([^/]+)!;
+
+	$HTTP->{'host_access'}  = 'http://' . $ENV{'SERVER_NAME'};
+	$HTTP->{'host_access'} .= ':' . $ENV{'SERVER_PORT'}
+		if $ENV{'SERVER_PORT'} != 80;
+
+	my $script_path = $ENV{'SCRIPT_NAME'};
+# die "server $ENV{'SERVER_SOFTWARE'} - script $ENV{'SCRIPT_NAME'} - path $ENV{'PATH_INFO'}\n";
+	# Now, remove script name, to keep only the path (no trailing slash)
 	$script_path =~ s!/[^/]*$!!;
 	$HTTP->{'script_path'} = $script_path;
-	$HTTP->{'this_url'} .= $ENV{'PATH_INFO'};
-	$HTTP->{'this_url'} .= '?' . $ENV{'QUERY_STRING'}
-	  if $ENV{'QUERY_STRING'};
+
+	$HTTP->{'this_url'}	= $HTTP->{'host_access'}
+						. ( 0 <= index($ENV{'SERVER_SOFTWARE'}, 'thttpd')
+						  ?	  $ENV{'SCRIPT_NAME'}
+							. $ENV{'PATH_INFO'}
+							. ($ENV{'QUERY_STRING'}
+							  ? '?'.$ENV{'QUERY_STRING'}
+							  : ''
+							  )
+						  : $ENV{'REQUEST_URI'}
+						  );
 
 	# We don't clean all the parameters here, as some scripts need extended characters
 	# e.g. regexp searching
-	$HTTP->{'param'} = { map { http_wash($_) } $ENV{'QUERY_STRING'} =~ /([^;&=]+)(?:=([^;&]+)|)/g }
-	  if defined $ENV{'QUERY_STRING'};
+	$HTTP->{'param'} =	{ map { s/\+/ /g; http_wash($_) }
+							$ENV{'QUERY_STRING'}
+								=~ m/([^;&=]+)(?:=([^;&]+)|)/g
+						}
+		if defined $ENV{'QUERY_STRING'};
 
-	# But do clean up these
 	$HTTP->{'param'}{'v'}	||= $HTTP->{'param'}{'_version'};
 	$HTTP->{'param'}{'a'}	||= $HTTP->{'param'}{'_arch'};
 	$HTTP->{'param'}{'_i'}	||= $HTTP->{'param'}{'_identifier'};
-
 	$identifier = clean_identifier($HTTP->{'param'}{'_i'});
+
 	# remove the param versions to prevent unclean versions being used
+	delete $HTTP->{'param'}{'_version'};
+	delete $HTTP->{'param'}{'_arch'};
 	delete $HTTP->{'param'}{'_i'};
 	delete $HTTP->{'param'}{'_identifier'};
 
-	$config     = LXR::Config->new($script_path);
+	$config = LXR::Config->new	( $HTTP->{'host_access'}
+								, $script_path
+								, $HTTP->{'path_root'}
+								);
 	unless (defined $config) {
-		$config = LXR::Config->emergency($script_path);
+		$config = LXR::Config->emergency
+						( $HTTP->{'host_access'}
+						, $script_path
+						, $HTTP->{'path_root'}
+						);
+		httpminimal;
 		LXR::Template::makeerrorpage('htmlfatal');
-		die "Can't find config for " . $HTTP->{'this_url'};
+	# There is a race condition under thttpd between STDOUT and STDERR
+	# causing debug information (sent to STDOUT) to be printed before
+	# HTTP-headers. Consequently, HTML is not interpreted by the
+	# browser but displayed as raw data.
+		if (0 <= index($ENV{'SERVER_SIGNATURE'}, 'thttpd')) {
+			$wwwdebug = 0;	# Avoid double information on display
+			die 'Can\'t find config for ' . $HTTP->{'this_url'};
+		}
+		exit(1);
+	}
+
+	# Remove tree name from path_info
+	if (exists($config->{'treename'})) {
+		$HTTP->{'path_info'} =~ s:^/[^/]+::;
 	}
 
 	# Override the 'variables' value if necessary
@@ -881,14 +846,21 @@
 		delete $HTTP->{'param'}{$param};
 	}
 
-	$files = LXR::Files->new($config->sourceroot, $config->sourceparams);
-	die "Can't create Files for " . $config->sourceroot if !defined($files);
-	$index = LXR::Index->new($config->dbname);
-	die "Can't create Index for " . $config->dbname if !defined($index);
+	$files = LXR::Files->new( $config->{'sourceroot'}
+							, $config->{'sourceparams'}
+							);
+	die 'Can\'t create Files for ' . $config->{'sourceroot'}
+		if !defined($files);
+	$index = LXR::Index->new( $config->{'dbname'}
+							, $config->{'dbprefix'}
+							);
+	die 'Can\'t create Index for ' . $config->{'dbname'}
+		if !defined($index);
 
 	# Set variables now
 	foreach ($config->allvariables) {
-		$config->variable($_, $HTTP->{'param'}{$_}) if $HTTP->{'param'}{$_};
+		$config->variable($_, $HTTP->{'param'}{$_})
+			if exists($HTTP->{'param'}{$_});
 		delete $HTTP->{'param'}{$_};
 	}
 
@@ -907,9 +879,10 @@
 	$config->variable('v', $releaseid);  # put back into config obj
 	$pathname   = fixpaths($HTTP->{'path_info'});
 	$pathname   =~ m/(.*)/;
-	$pathname   = $1;		# untaint for future use
+	$pathname   = $1;	# untaint for future use
 
 	printhttp;
+	$wwwdebug = $olddebug;	# Safe now
 }
 
 
@@ -930,6 +903,8 @@
 
 =over
 
+=item
+
 This filtering breaks with CVS if a file is not targeted
 i.e. directory listing or identifier query.
 
@@ -951,10 +926,10 @@
 sub clean_release {
 	my $releaseid = shift;
 
-	if	(	!$files->isa("LXR::Files::CVS")
-		||	$pathname !~ m!/$!
+	if	(	!$files->isa('LXR::Files::CVS')
+		||	substr($pathname, -1) ne '/'
 		) {
-		my @rels= $config->varrange('v');
+		my @rels = $config->varrange('v');
 		my %test;
 		@test{@rels} = undef;
 
@@ -977,17 +952,19 @@
 
 a I<string> representing the identifier
 
+=back
+
 B<Caveat:>
 
 =over
 
+=item
+
 When adding new languages, check that the definition of "unusual" in
 this sub does not conflict with the lexical form of identifiers.
 
 =back
 
-=back
-
 =cut
 
 sub clean_identifier {
@@ -1023,13 +1000,14 @@
 
 =over
 
-This erasure is not correct for C</../>.
-Moreover, this function is called before C<fixpaths> which then
-cannot do its correct job with C</../>.
+=item
 
-=back
+Is this really necessary since it restricts the user choice of
+filenames, even if the set covers the common needs?
+All is needed to protect against malicious attacks is to "quote"
+HTML reserved characters.
 
-B<To do:> see if we realy need two (apparently) similar subs
+=back
 
 =cut
 
@@ -1042,9 +1020,9 @@
 	    # Match good chars from start of string,
 		# then replace entire string with only good chars
 		$path =~ s!(^[\w\s_+\-,\.%\^/\!]+).*!$1!;
-		# Clean out /../
-		while ($path =~ m!/\.\.?/!) {
-			$path =~ s!/\.\.?/!/!g;
+		# Clean out /./
+		while ($path =~ m!/\./!) {
+			$path =~ s!/\./!/!g;
 		}
 	}
 
@@ -1056,7 +1034,7 @@
 
 Function C<httpclean> does the final clean up.
 
-To be called when all processing is done, but is it really necessary?
+To be called when all processing is done.
 
 =cut
 

Index: Lang.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Lang.pm,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -d -r1.51 -r1.52
--- Lang.pm	21 Sep 2013 12:54:52 -0000	1.51
+++ Lang.pm	24 Sep 2013 07:36:09 -0000	1.52
@@ -397,6 +397,117 @@
 }
 
 
+=head2 C<_incfindfile ($filewanted, $file, @paths)>
+
+Function C<_incfindfile> returns the "full" path corresponding to argument
+C<$file>.
+
+=over
+
+=item 1 C<$filewanted>
+
+a I<flag> indicating if a directory (0) or file (1) is desired
+
+=item 1 C<$file>
+
+a I<string> containing a file name to resolve
+
+=item 1 C<@paths>
+
+an I<array> containing a list of directories to search
+
+=back
+
+The list of directories from configuration parameter C<'incprefix'> is
+appended to C<@paths>. Every directory from this array is then preprended
+to the file name . The resulting string is transformed by the mapping
+rules of configuration parameter C<'maps'> (See I<Config.pm> sub C<mappath>).
+
+If there is a match in the file database (file or directory according
+to the first argument), the "physical" path is returned.
+Otherwise, an C<undef> is returned to signal an unknown file.
+
+I<This is a "private" or "internal" C<sub> for include path resolution only.>
+
+=cut
+
+sub _incfindfile {
+	my ($filewanted, $file, @paths) = @_;
+	my $path;
+
+	# The following line could be faster interpreted as
+	# 	push(@paths, @{$config->{'incprefix'}});
+	# but this would forbid variable expansion.
+	# Is this feature really needed for include path?
+	push(@paths, $config->incprefix);
+
+	foreach my $dir (@paths) {
+		$dir =~ s!/+$!!;	# Remove trailing slashes
+		$path = $config->mappath($dir . '/' . $file);
+		if ($filewanted){
+			return $path if $files->isfile($path, $releaseid);
+		} else {
+			return $path if $files->isdir($path, $releaseid);
+		}
+	}
+
+	return undef;
+}
+
+
+=head2 C<incdirref ($name, $css, $file, @paths)>
+
+Function C<incdirref> returns an C<E<lt>AE<gt>> link to a directory
+of an C<include>d file or the directory name if it is unknown.
+
+=over
+
+=item 1 C<$name>
+
+a I<string> for the user-visible part of the link,
+usually the directory name
+
+=item 1 C<$css>
+
+a I<string> containing the CSS class for the link
+
+=item 1 C<$file>
+
+a I<string> containing the HTML path to the directory
+
+=item 1 C<@paths>
+
+an I<array> containing a list of base directories to search
+
+=back
+
+I<This function is supposed to be called AFTER sub C<incref> on every
+subpath of the include'd file, removing successively the tail directory.
+It thus allows to compose a path where each directory is separately
+clickable.>
+
+If the include'd directory does not exist (as determined by sub C<incfindfile>),
+the function returns the directory name. This acts as a "no-op" in the
+HTML sequence representing the full path of the include'd file.
+
+If the directory exists, the function returns the C<E<lt>AE<gt>> link
+as computed by sub C<fileref> for the directory.
+
+=cut
+
+sub incdirref {
+	my ($name, $css, $file, @paths) = @_;
+	my $path;
+
+	$path = _incfindfile(0, $file, @paths);
+	return $name unless $path;
+	return &fileref	( $name
+					, $css
+					, $path.'/'
+					);
+}
+
+
 =head2 C<processcode ($code)>
 
 Method C<processcode> processes the fragment as code.

[Lxr-commits] CVS: lxr/lib/LXR/Files GIT.pm,1.13,1.14

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Files
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv25646/lib/LXR/Files

Modified Files:
	GIT.pm 
Log Message:
Git.pm: separate filename from options

Add -- (end of options) on all Git commands before the filename, so that an initial hyphen does not cause interpretation as an option.

Index: GIT.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Files/GIT.pm,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- GIT.pm	21 Sep 2013 12:54:52 -0000	1.13
+++ GIT.pm	23 Sep 2013 15:20:27 -0000	1.14
@@ -89,7 +89,7 @@
 	if ($pathname eq '') {
 		$git = $self->_git_cmd ('ls-tree', $releaseid);
 	} else {
-		$git = $self->_git_cmd ('ls-tree', $releaseid, $pathname);
+		$git = $self->_git_cmd ('ls-tree', $releaseid, '--', $pathname);
 	}
 	while (<$git>) {
 		if (m/(\d+) (\w+) ([[:xdigit:]]+)\t(.*)/) {
@@ -156,7 +156,7 @@
 	# to be relative to 'rootpath'. Changes LXR convention.
 	$filename =~ s,^/+,,;
 
-	my $sha1hashline = $self->_git_oneline ('ls-tree', $releaseid, $filename);
+	my $sha1hashline = $self->_git_oneline ('ls-tree', $releaseid, '--', $filename);
 	if ($sha1hashline =~ m/\d+ blob ([[:xdigit:]]+)\t.*/) {
 		return substr	($self->_git_oneline
 							('rev-list'
@@ -198,7 +198,7 @@
 		$self->{'authors'}     = [];
 		return $self;
 	} else {
-		my $sha1hashline = $self->_git_oneline ('ls-tree', $releaseid,  $filename);
+		my $sha1hashline = $self->_git_oneline ('ls-tree', $releaseid, '--', $filename);
 		if ($sha1hashline =~ m/^\d+ blob ([[:xdigit:]]+)\t.*/) {
 			my $fh = $self->_git_cmd ('cat-file', 'blob', $1);
 			die('Error executing "git cat-file"') unless $fh;
@@ -308,7 +308,7 @@
 	if ($pathname eq '') {
 		return 1 == 1;
 	} else {
-		my $line = $self->_git_oneline ('ls-tree', $releaseid, $pathname);
+		my $line = $self->_git_oneline ('ls-tree', $releaseid, '--', $pathname);
 		return $line =~ m/^\d+ tree .*$/;
 	}
 }
@@ -322,7 +322,7 @@
 	if ($pathname eq '') {
 		return 1 == 0;
 	} else {
-		my $line = $self->_git_oneline ('ls-tree', $releaseid, $pathname);
+		my $line = $self->_git_oneline ('ls-tree', $releaseid, '--', $pathname);
 		return $line =~ m/^\d+ blob .*$/;
 	}
 }

[Lxr-commits] CVS: lxr/lib/LXR/Index Mysql.pm, 1.35, 1.36 Oracle.pm, 1.25, 1.26 Postgres.pm, 1.37, 1.38 SQLite.pm, 1.3, 1.4

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Index
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv4903/lib/LXR/Index

Modified Files:
	Mysql.pm Oracle.pm Postgres.pm SQLite.pm 
Log Message:
Files.pm, Index.pm, Lang.pm, Markup.pm, SimpleParse.pm, Files/*, Index/*, Lang/*: better comments, source code improvement & optilmisation

Index: Mysql.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Index/Mysql.pm,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- Mysql.pm	10 Sep 2012 17:22:21 -0000	1.35
+++ Mysql.pm	21 Sep 2013 12:54:52 -0000	1.36
@@ -27,7 +27,7 @@
 use DBI;
 use LXR::Common;
 
-our @ISA = ("LXR::Index");
+our @ISA = ('LXR::Index');
 
 sub new {
 	my ($self, $dbname, $prefix) = @_;
@@ -42,27 +42,27 @@
 #	a tiny improvement may show up with explicit commit (the
 #	difference on the medium-sized test cases is difficult to
 #	appreciate since it is within the measurement error).
-		or fatal "Can't open connection to database: $DBI::errstr\n";
+		or die "Can't open connection to database: $DBI::errstr\n";
 
 	$self->{'files_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}files"
-			. " (filename, revision, fileid)"
-			. " values (?, ?, NULL)"
+			. ' (filename, revision, fileid)'
+			. ' values (?, ?, NULL)'
 			);
 
 	$self->{'symbols_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}symbols"
-			. " (symname, symid, symcount)"
-			. " values ( ?, NULL, 0)"
+			. ' (symname, symid, symcount)'
+			. ' values ( ?, NULL, 0)'
 			);
 
 	$self->{'langtypes_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}langtypes"
-			. " (typeid, langid, declaration)"
-			. " values (NULL, ?, ?)"
+			. ' (typeid, langid, declaration)'
+			. ' values (NULL, ?, ?)'
 			);
 
 	$self->{'purge_all'} = $self->{dbh}->prepare

Index: Oracle.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Index/Oracle.pm,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- Oracle.pm	10 Sep 2012 17:22:21 -0000	1.25
+++ Oracle.pm	21 Sep 2013 12:54:52 -0000	1.26
@@ -39,7 +39,7 @@
 use DBI;
 use LXR::Common;
 
-our @ISA = ("LXR::Index");
+our @ISA = ('LXR::Index');
 
 sub new {
 	my ($self, $dbname, $prefix) = @_;
@@ -47,28 +47,28 @@
 	$self = bless({}, $self);
 
 	$self->{dbh} =
-		DBI->connect($dbname, $config->{dbuser}, $config->{dbpass},
+		DBI->connect($dbname, $config->{'dbuser'}, $config->{'dbpass'},
 			{ RaiseError => 1, AutoCommit => 1 })
-		or fatal "Can't open connection to database: $DBI::errstr\n";
+		or die "Can't open connection to database: $DBI::errstr\n";
 
 	$self->{'files_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}files"
-			. " (filename, revision, fileid)"
+			. ' (filename, revision, fileid)'
 			. " values (?, ?, ${prefix}filenum.nextval)"
 			);
 
 	$self->{'symbols_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}symbols"
-			. " (symname, symid) values"
+			. ' (symname, symid) values'
 			. " ( ?, ${prefix}symnum.nextval)"
 			);
 
 	$self->{'langtypes_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}langtypes"
-			. " (typeid, langid, declaration)"
+			. ' (typeid, langid, declaration)'
 			. " values (${prefix}typenum.nextval, ?, ?)"
 			);
 
@@ -78,8 +78,4 @@
 	return $self;
 }
 
-#
-# LXR::Index API Implementation
-#
-
 1;

Index: Postgres.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Index/Postgres.pm,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- Postgres.pm	14 Nov 2012 11:27:31 -0000	1.37
+++ Postgres.pm	21 Sep 2013 12:54:52 -0000	1.38
@@ -27,7 +27,7 @@
 use DBI;
 use LXR::Common;
 
-our @ISA = ("LXR::Index");
+our @ISA = ('LXR::Index');
 
 sub new {
 	my ($self, $dbname, $prefix) = @_;
@@ -46,7 +46,7 @@
 #	eventually comment out begin_work() call.
 								, {'AutoCommit' => 0}
 								)
-	or fatal "Can't open connection to database: $DBI::errstr\n";
+	or die "Can't open connection to database: $DBI::errstr\n";
 
 #	Without the following instruction (theoretically meaningless
 #	in auto commit mode), indexing time is multiplied by 10
@@ -58,8 +58,8 @@
 	$self->{'files_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}files"
-			. " (filename, revision, fileid)"
-			. " values (?, ?, ?)"
+			. ' (filename, revision, fileid)'
+			. ' values (?, ?, ?)'
 			);
 
 	$self->{'symnum_nextval'} = 
@@ -67,8 +67,8 @@
 	$self->{'symbols_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}symbols"
-			. " (symname, symid, symcount)"
-			. " values (?, ?, 0)"
+			. ' (symname, symid, symcount)'
+			. ' values (?, ?, 0)'
 			);
 
 	$self->{'typeid_nextval'} = 
@@ -77,27 +77,27 @@
 	$self->{'langtypes_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}langtypes"
-			. " (typeid, langid, declaration)"
-			. " values (?, ?, ?)"
+			. ' (typeid, langid, declaration)'
+			. ' values (?, ?, ?)'
 			);
 
 	$self->{'delete_definitions'} =
 		$self->{dbh}->prepare
 			( "delete from ${prefix}definitions as d"
 			. " using ${prefix}status t, ${prefix}releases r"
-			. " where r.releaseid = ?"
-			. "  and  t.fileid = r.fileid"
-			. "  and  t.relcount = 1"
-			. "  and  d.fileid = r.fileid"
+			. ' where r.releaseid = ?'
+			. '  and  t.fileid = r.fileid'
+			. '  and  t.relcount = 1'
+			. '  and  d.fileid = r.fileid'
 			);
 	$self->{'delete_usages'} =
 		$self->{dbh}->prepare
 			( "delete from ${prefix}usages as u"
 			. " using ${prefix}status t, ${prefix}releases r"
-			. " where r.releaseid = ?"
-			. " and t.fileid = r.fileid"
-			. " and t.relcount = 1"
-			. " and u.fileid = r.fileid"
+			. ' where r.releaseid = ?'
+			. ' and t.fileid = r.fileid'
+			. ' and t.relcount = 1'
+			. ' and u.fileid = r.fileid'
 			);
 
 	$self->{'reset_filenum'} = $self->{dbh}->prepare

Index: SQLite.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Index/SQLite.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- SQLite.pm	14 Nov 2012 11:27:31 -0000	1.3
+++ SQLite.pm	21 Sep 2013 12:54:52 -0000	1.4
@@ -27,7 +27,7 @@
 use DBI;
 use LXR::Common;
 
-our @ISA = ("LXR::Index");
+our @ISA = ('LXR::Index');
 
 our ($filenum, $symnum, $typenum);
 our ($fileini, $symini, $typeini);
@@ -52,7 +52,7 @@
 
 	$self = bless({}, $self);
 	$self->{dbh} = DBI->connect($dbname)
-	or fatal "Can't open connection to database: $DBI::errstr\n";
+	or die "Can't open connection to database: $DBI::errstr\n";
 #	SQLite is forced into explicit commit mode as the medium-sized
 #	test cases have shown a 40-times (!) performance improvement
 #	over auto commit.
@@ -64,15 +64,15 @@
 	$self->{'symbols_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}symbols"
-			. " (symname, symid, symcount) values"
-			. " (?, ?, 0)"
+			. ' (symname, symid, symcount) values'
+			. ' (?, ?, 0)'
 			);
 
 	$self->{'langtypes_insert'} =
 		$self->{dbh}->prepare
 			( "insert into ${prefix}langtypes"
-			. " (typeid, langid, declaration)"
-			. " values (?, ?, ?)"
+			. ' (typeid, langid, declaration)'
+			. ' values (?, ?, ?)'
 			);
 
 	$self->{'purge_all'} = undef;	# Prevent parsing the common one
@@ -121,21 +121,21 @@
 	$self->{'filenum_newval'} =
 		$self->{dbh}->prepare
 			( "update ${prefix}filenum"
-			. " set fid = ?"
-			. " where rcd = 0"
+			. ' set fid = ?'
+			. ' where rcd = 0'
 			);
 
 	$self->{'symnum_newval'} =
 		$self->{dbh}->prepare
 			( "update ${prefix}symnum"
-			. " set sid = ?"
-			. " where rcd = 0"
+			. ' set sid = ?'
+			. ' where rcd = 0'
 		);
 	$self->{'typenum_newval'} =
 		$self->{dbh}->prepare
 			( "update ${prefix}typenum"
-			. " set tid = ?"
-			. " where rcd = 0"
+			. ' set tid = ?'
+			. ' where rcd = 0'
 			);
 
 	return $self;

[Lxr-commits] CVS: lxr/lib/LXR Files.pm, 1.22, 1.23 Index.pm, 1.23, 1.24 Lang.pm, 1.50, 1.51 Markup.pm, 1.8, 1.9 SimpleParse.pm, 1.21, 1.22

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv4903/lib/LXR

Modified Files:
	Files.pm Index.pm Lang.pm Markup.pm SimpleParse.pm 
Log Message:
Files.pm, Index.pm, Lang.pm, Markup.pm, SimpleParse.pm, Files/*, Index/*, Lang/*: better comments, source code improvement & optilmisation

Index: Files.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Files.pm,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- Files.pm	18 Jan 2013 17:48:50 -0000	1.22
+++ Files.pm	21 Sep 2013 12:54:52 -0000	1.23
@@ -48,7 +48,7 @@
 
 =item 1 C<$params>
 
-an optional I<hash> from lxr.conf used to pass extra information
+an optional I<hash> reference from lxr.conf used to pass extra information
 to the real constructor
 
 =back
@@ -124,7 +124,7 @@
 	return @dircontents;
 }
 
-=head2 C<getfile ($pathname, $releaseid, $withannot)>
+=head2 C<getfile ($pathname, $releaseid)>
 
 C<getfile> returns a file content in a string.
 
@@ -139,10 +139,6 @@
 the release (or version) in which C<$pathname> is expected to
 be found
 
-=item 1 C<$withannot>
-
-optional, if defined request an annotated file
-
 =back
 
 Function result is C<undef> if file does not exist in this version.
@@ -192,6 +188,8 @@
 
 =over
 
+=item
+
 Starting with release 1.1, this method should only be used for
 internal needs of the derived classes because annotation editing
 has been drastically changed in script I<source>.
@@ -277,7 +275,7 @@
 	return ++$len;
 }
 
-=head2 C<getauthor ($pathname, $annotation)>
+=head2 C<getauthor ($pathname, $releaseid, $annotation)>
 
 C<getauthor> returns the author of the designated revision.
 
@@ -461,7 +459,7 @@
 eventually adding C</> suffix.
 Afterwards, all is needed is test for the trailing slash.
 
-This sub is used when the existence must be confirmed, such as
+This method is used when the existence must be confirmed, such as
 when processing an include link since it is independent from
 the currently displayed file.
 
@@ -492,7 +490,7 @@
 
 =back
 
-This sub is used when the existence must be confirmed, such as
+This method is used when the existence must be confirmed, such as
 when processing an include link since it is independent from
 the currently displayed file.
 
@@ -502,7 +500,7 @@
 
 =item
 
-I<< When the file is subsequently accessed, it is much simpler and
+I<When the file is subsequently accessed, it is much simpler and
 efficient to use C<getfilehandle>, since a handle will be
 required anyway.>
 
@@ -535,7 +533,7 @@
 
 =back
 
-Extract content of the path from repository and stuf it into a
+Extract content of the path from repository and stuff it into a
 temporary file whose name is returned.
 
 B<Note:>
@@ -558,7 +556,7 @@
 	$fileh = $self->getfilehandle ($filename, $releaseid);
 	return undef unless defined($fileh);
 
-	$tmp = $config->tmpdir
+	$tmp = $config->{'tmpdir'}
 			. '/lxrtmp.'
 			. time
 			. '.' . $$
@@ -614,9 +612,7 @@
 
 C<_ignoredirs> is an internal (as indicated by _ prefix) filter utility
 to exclude directories containing any partial path defined in configuration
-parameter C<'ignoredirs'>.
-
-The filter is to be called from C<getdir()>.
+parameters C<'ignoredirs'> and C<'filterdirs'>.
 
 =over
 
@@ -630,22 +626,28 @@
 
 =back
 
-Only the last part is tested since the parent is supposed to have been
-scanned by a previous step of the recursive directory tree traversal.
+Only the last part is tested for C<'ignoredirs'> since the parent
+is supposed to have been scanned by a previous step of the recursive
+directory tree traversal.
 If a higher element matched one of the C<'ignoredirs'> strings,
 that path part was filtered out and no further part is presented to this
 function.
 
+C<'filterdirs'> operates on the full path,
+I<i.e.> C<$path> concatenated with C<$node>.
+
 B<Note:>
 
 =over
 
+=item
+
 The filter is to be called from C<getdir()>.
 
-I<<This usage choice leaves the possibility to override the filter through
+I<This usage choice leaves the possibility to override the filter through
 manually entering the path in the URL. Since it does not go through
 C<getdir()>, the "forbidden" path subdirectory is transmitted unaltered
-to the source display script.>>
+to the source display script.>
 
 =back
 
@@ -654,7 +656,7 @@
 sub _ignoredirs {
 	my ($self, $path, $node) = @_;
 
-	return 1 if $node =~ m/^\./;	# ignore "dot" dirs
+	return 1 if substr($node, 0, 1) eq '.';	# ignore "dot" dirs
 	foreach my $ignoredir (@{$config->{'ignoredirs'}}) {
 		return 1 if $node eq $ignoredir;
 	}
@@ -668,9 +670,7 @@
 
 C<_ignorefiles> is an internal (as indicated by _ prefix) filter utility
 to exclude files containing patterns defined in configuration
-parameter C<'ignorefiles'>.
-
-The filter is to be called from C<getdir()>.
+parameters C<'ignorefiles'> and C<'filterfiles'>.
 
 =over
 
@@ -684,24 +684,26 @@
 
 =back
 
-Presently, only filename filtering is done, i.e. the same filter is
-applied in every directory.
+Only filename filtering is done for C<'ignorefiles'>,
+i.e. the same filter is applied in every directory.
 Usually, it screens off "dot" files, editor backups, binaries, ...
-A more specific filtering could be implemented taking into account
-both the parent directory and the filename.
-But this extended feature will be added only on user request due to
-its time-cost on huge trees such as Linux kernel.
+
+C<'filterfiles'> operates on the full path,
+I<i.e.> concatenation of the parent directory C<$path>
+and the filename C<$node>.
 
 B<Note:>
 
 =over
 
+=item
+
 The filter is to be called from C<getdir()>.
 
-I<<This usage choice leaves the possibility to override the filter through
+I<This usage choice leaves the possibility to override the filter through
 manually entering the path in the URL. Since it does not go through
 C<getdir()>, the "forbidden" filename is transmitted unaltered
-to the source display script.>>
+to the source display script.>
 
 =back
 

Index: Index.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Index.pm,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- Index.pm	1 Dec 2012 15:03:19 -0000	1.23
+++ Index.pm	21 Sep 2013 12:54:52 -0000	1.24
@@ -30,7 +30,6 @@
 
 $CVSID = '$Id$ ';
 
-use LXR::Common;
 use strict;
 
 #
@@ -59,10 +58,10 @@
 
 =item
 
-I<<There used to be a second C<@args> argument which passed file
+I<There used to be a second C<@args> argument which passed file
 open-attributes (such as C<O_RDWR> or C<O_CREAT>) when the DB
-made of a set of files.
-This is no longer used.>
+was made of a set of files.
+This is no longer used with DB engines.>
 
 =back
 
@@ -91,18 +90,15 @@
 #	only once and do not contribute to the running time behaviour.
 
 sub new {
-	my ($self, $dbname) = @_;
+	my ($self, $dbname, $prefix) = @_;
 	my $index;
     
 	%files    = ();
 	%symcache = ();    
 	%cntcache = ();
 
-	my $prefix;
-	if (defined($config->{'dbprefix'})) {
-		$prefix = $config->{'dbprefix'};
-	} else {
-		$prefix = "lxr_";
+	if (!defined($prefix)) {
+		$prefix = 'lxr_';
 	}
 
 	if ($dbname =~ m/^DBI:/i) {
@@ -135,19 +131,19 @@
 		$index->{'files_select'} =
 			$index->{dbh}->prepare
 				( "select fileid from ${prefix}files"
-				. " where filename = ? and revision = ?"
+				. ' where filename = ? and revision = ?'
 				);
 	}
 	if (!exists($index->{'allfiles_select'})) {
 		$index->{'allfiles_select'} =
 			$index->{dbh}->prepare
-				( "select f.fileid, f.filename, f.revision, t.relcount"
+				( 'select f.fileid, f.filename, f.revision, t.relcount'
 				. " from ${prefix}files f, ${prefix}status t"
 				.		", ${prefix}releases r"
-				. " where r.releaseid = ?"
-				. "  and  f.fileid = r.fileid"
-				. "  and  t.fileid = r.fileid"
-				. " order by f.filename, f.revision"
+				. ' where r.releaseid = ?'
+				. '  and  f.fileid = r.fileid'
+				. '  and  t.fileid = r.fileid'
+				. ' order by f.filename, f.revision'
 				);
 	}
 
@@ -156,38 +152,38 @@
 		$index->{'symbols_byname'} =
 			$index->{dbh}->prepare
 				( "select symid, symcount from ${prefix}symbols"
-				. " where symname = ?"
+				. ' where symname = ?'
 				);
 	}
 	if (!exists($index->{'symbols_byid'})) {
 		$index->{'symbols_byid'} =
 			$index->{dbh}->prepare
 				( "select symname from ${prefix}symbols"
-				. " where symid = ?"
+				. ' where symid = ?'
 				);
 	}
 	if (!exists($index->{'symbols_setref'})) {
 		$index->{'symbols_setref'} =
 			$index->{dbh}->prepare
 				( "update ${prefix}symbols"
-				. " set symcount = ?"
-				. " where symid = ?"
+				. ' set symcount = ?'
+				. ' where symid = ?'
 				);
 	}
 	if (!exists($index->{'related_symbols_select'})) {
 		$index->{'related_symbols_select'} =
 			$index->{dbh}->prepare
-				( "select s.symid, s.symcount, s.symname"
+				( 'select s.symid, s.symcount, s.symname'
 				. " from ${prefix}symbols s, ${prefix}definitions d"
-				. " where d.fileid = ?"
-				. "  and  s.symid = d.relid"
+				. ' where d.fileid = ?'
+				. '  and  s.symid = d.relid'
 				);
 	}
 	if (!exists($index->{'delete_symbols'})) {
 		$index->{'delete_symbols'} =
 			$index->{dbh}->prepare
 				( "delete from ${prefix}symbols"
-				. " where symcount = 0"
+				. ' where symcount = 0'
 				);
 	}
 
@@ -195,32 +191,32 @@
 		$index->{'definitions_insert'} =
 			$index->{dbh}->prepare
 				( "insert into ${prefix}definitions"
-				. " (symid, fileid, line, langid, typeid, relid)"
-				. " values (?, ?, ?, ?, ?, ?)"
+				. ' (symid, fileid, line, langid, typeid, relid)'
+				. ' values (?, ?, ?, ?, ?, ?)'
 				);
 	}
 	if (!exists($index->{'definitions_select'})) {
 		$index->{'definitions_select'} =
 			$index->{dbh}->prepare
-				( "select f.filename, d.line, l.declaration, d.relid"
+				( 'select f.filename, d.line, l.declaration, d.relid'
 				. " from ${prefix}symbols s, ${prefix}definitions d"
 				.		", ${prefix}files f, ${prefix}releases r"
 				.		", ${prefix}langtypes l"
-				. " where s.symname = ?"
-				. "  and  r.releaseid = ?"
-				. "  and  d.fileid = r.fileid"
-				. "  and  d.symid  = s.symid"
-				. "  and  d.langid = l.langid"
-				. "  and  d.typeid = l.typeid"
-				. "  and  f.fileid = r.fileid"
-				. " order by f.filename, d.line, l.declaration"
+				. ' where s.symname = ?'
+				. '  and  r.releaseid = ?'
+				. '  and  d.fileid = r.fileid'
+				. '  and  d.symid  = s.symid'
+				. '  and  d.langid = l.langid'
+				. '  and  d.typeid = l.typeid'
+				. '  and  f.fileid = r.fileid'
+				. ' order by f.filename, d.line, l.declaration'
 				);
 	}
 	if (!exists($index->{'delete_file_definitions'})) {
 		$index->{'delete_file_definitions'} =
 			$index->{dbh}->prepare
 				( "delete from ${prefix}definitions"
-				. " where fileid  = ?"
+				. ' where fileid  = ?'
 				);
 	}
 	# 'delete_definitions' mandatory but syntax varies
@@ -228,13 +224,13 @@
 		$index->{'delete_definitions'} =
 			$index->{dbh}->prepare
 				( "delete from ${prefix}definitions"
-				. " where fileid in"
-				.	" (select r.fileid"
+				. ' where fileid in'
+				.	' (select r.fileid'
 				.	"  from ${prefix}releases r, ${prefix}status t"
-				.	"  where r.releaseid = ?"
-				.	"   and  t.fileid = r.fileid"
-				.	"   and  t.relcount = 1"
-				.	" )"
+				.	'  where r.releaseid = ?'
+				.	'   and  t.fileid = r.fileid'
+				.	'   and  t.relcount = 1'
+				.	' )'
 				);
 	}
 
@@ -242,31 +238,31 @@
 		$index->{'releases_insert'} =
 			$index->{dbh}->prepare
 				( "insert into ${prefix}releases"
-				. " (fileid, releaseid)"
-				. " values (?, ?)"
+				. ' (fileid, releaseid)'
+				. ' values (?, ?)'
 				);
 	}
 	if (!exists($index->{'releases_select'})) {
 		$index->{'releases_select'} =
 			$index->{dbh}->prepare
 				( "select fileid from ${prefix}releases"
-				. " where fileid = ?"
-				. " and  releaseid = ?"
+				. ' where fileid = ?'
+				. ' and  releaseid = ?'
 				);
 	}
 	if (!exists($index->{'delete_one_release'})) {
 		$index->{'delete_one_release'} =
 			$index->{dbh}->prepare
 				( "delete from ${prefix}releases"
-				. " where fileid = ?"
-				. "  and  releaseid = ?"
+				. ' where fileid = ?'
+				. '  and  releaseid = ?'
 				);
 	}
 	if (!exists($index->{'delete_releases'})) {
 		$index->{'delete_releases'} =
 			$index->{dbh}->prepare
 				( "delete from ${prefix}releases"
-				. " where releaseid = ?"
+				. ' where releaseid = ?'
 				);
 	}
 
@@ -274,45 +270,45 @@
 		$index->{'status_insert'} =
 			$index->{dbh}->prepare
 				( "insert into ${prefix}status"
-				. " (fileid, relcount, indextime, status)"
-				. " values (?, 0, 0, ?)"
+				. ' (fileid, relcount, indextime, status)'
+				. ' values (?, 0, 0, ?)'
 				);
 	}
 	if (!exists($index->{'status_select'})) {
 		$index->{'status_select'} =
 			$index->{dbh}->prepare
 				( "select status from ${prefix}status"
-				. " where fileid = ?"
+				. ' where fileid = ?'
 				);
 	}
 	if (!exists($index->{'status_update'})) {
 		$index->{'status_update'} =
 			$index->{dbh}->prepare
 				( "update ${prefix}status"
-				. " set status = ?"
-				. " where fileid = ?"
+				. ' set status = ?'
+				. ' where fileid = ?'
 				);
 	}
 	if (!exists($index->{'status_timestamp'})) {
 		$index->{'status_timestamp'} =
 			$index->{dbh}->prepare
 				( "select indextime from ${prefix}status"
-				. " where fileid = ?"
+				. ' where fileid = ?'
 				);
 	}
 	if (!exists($index->{'status_update_timestamp'})) {
 		$index->{'status_update_timestamp'} =
 			$index->{dbh}->prepare
 				( "update ${prefix}status"
-				. " set indextime = ?"
-				. " where fileid = ?"
+				. ' set indextime = ?'
+				. ' where fileid = ?'
 				);
 	}
 	if (!exists($index->{'delete_unused_status'})) {
 		$index->{'delete_unused_status'} =
 			$index->{dbh}->prepare
 				( "delete from ${prefix}status"
-				. " where relcount = 0"
+				. ' where relcount = 0'
 				);
 	}
 
@@ -320,29 +316,29 @@
 		$index->{'usages_insert'} =
 			$index->{dbh}->prepare
 				( "insert into ${prefix}usages"
-				. " (fileid, line, symid)"
-				. " values (?, ?, ?)"
+				. ' (fileid, line, symid)'
+				. ' values (?, ?, ?)'
 				);
 	}
 	if (!exists($index->{'usages_select'})) {
 		$index->{'usages_select'} =
 			$index->{dbh}->prepare
-				( "select f.filename, u.line"
+				( 'select f.filename, u.line'
 				. " from ${prefix}symbols s, ${prefix}files f"
 				.	", ${prefix}releases r, ${prefix}usages u"
-				. " where s.symname = ?"
-				. "  and  r.releaseid = ?"
-				. "  and  u.symid  = s.symid"
-				. "  and  f.fileid = r.fileid"
-				. "  and  u.fileid = r.fileid"
-				. " order by f.filename, u.line"
+				. ' where s.symname = ?'
+				. '  and  r.releaseid = ?'
+				. '  and  u.symid  = s.symid'
+				. '  and  f.fileid = r.fileid'
+				. '  and  u.fileid = r.fileid'
+				. ' order by f.filename, u.line'
 				);
 	}
 	if (!exists($index->{'delete_file_usages'})) {
 		$index->{'delete_file_usages'} =
 			$index->{dbh}->prepare
 				( "delete from ${prefix}usages"
-				. " where fileid  = ?"
+				. ' where fileid  = ?'
 				);
 	}
 	# 'delete_definitions' mandatory but syntax varies
@@ -350,13 +346,13 @@
 		$index->{'delete_usages'} =
 			$index->{dbh}->prepare
 				( "delete from ${prefix}usages"
-				. " where fileid in"
-				.	" (select r.fileid"
+				. ' where fileid in'
+				.	' (select r.fileid'
 				.	"  from ${prefix}releases r, ${prefix}status t"
-				.	"  where r.releaseid = ?"
-				.	"   and  t.fileid = r.fileid"
-				.	"   and  t.relcount = 1"
-				.	" )"
+				.	'  where r.releaseid = ?'
+				.	'   and  t.fileid = r.fileid'
+				.	'   and  t.relcount = 1'
+				.	' )'
 				);
 	}
 
@@ -365,8 +361,8 @@
 		$index->{'langtypes_select'} =
 			$index->{dbh}->prepare
 				( "select typeid from ${prefix}langtypes"
-				. " where langid = ?"
-				. " and declaration = ?"
+				. ' where langid = ?'
+				. ' and declaration = ?'
 				);
 	}
 	if (!exists($index->{'langtypes_count'})) {
@@ -383,7 +379,7 @@
 				. ", ${prefix}usages, ${prefix}langtypes"
 				. ", ${prefix}symbols, ${prefix}releases"
 				. ", ${prefix}status, ${prefix}files"
-				. " cascade"
+				. ' cascade'
 				);
 	}
 	return $index;
@@ -394,11 +390,12 @@
 # Generic implementation of this interface
 #
 
-=head2 C<fileidifexists ($filename, $revision)>
-
 =head2 C<fileid ($filename, $revision)>
 
-C<fileid> returns a unique id for a file with a given revision.
+=head2 C<fileidifexists ($filename, $revision)>
+
+C<fileid> returns a unique id for a file with a given revision,
+creating it if it does not exist.
 
 C<fileidifexists> is similar, but returns C<undef> if the given
 revision is unknown, which can happen if the revision was created
@@ -414,8 +411,8 @@
 
 the revision for the file
 
-CAUTION: this is not a release id!
-It is computed by method filerev in the Files classes.
+B<CAUTION:> this is not a release id!
+It is computed by method C<filerev> in the I<Files> classes.
 
 =back
 
@@ -426,9 +423,12 @@
 
 =over
 
-=item C<files_select>
+=item * C<files_select>
 
-=item C<files_insert>
+=item * C<files_insert>
+
+=item * C<status_insert>
+B<I<(>C<fileid> I<only)>>
 
 =back
 
@@ -438,12 +438,12 @@
 	my ($self, $filename, $revision) = @_;
 	my $fileid;
 
-	unless (defined($fileid = $files{"$filename\t$revision"})) {
+# 	unless (defined($fileid = $files{"$filename\t$revision"})) {
 		$self->{'files_select'}->execute($filename, $revision);
 		($fileid) = $self->{'files_select'}->fetchrow_array();
 # opt		$self->{'files_select'}->finish();
-		$files{"$filename\t$revision"} = $fileid;
-	}
+# 		$files{"$filename\t$revision"} = $fileid;
+# 	}
 	return $fileid
 }
 
@@ -458,7 +458,7 @@
 		($fileid) = $self->{'files_select'}->fetchrow_array();
 		$self->{'status_insert'}->execute($fileid, 0);
 # opt	$self->{'files_select'}->finish();
-		$files{"$filename\t$revision"} = $fileid;
+# 		$files{"$filename\t$revision"} = $fileid;
 	}
 	return $fileid;
 }
@@ -471,7 +471,7 @@
 
 =item 1 C<$releaseid>
 
-the release (or version) for which all recorded file should be returned
+the release (or version) for which all recorded files should be returned
 
 =back
 
@@ -482,7 +482,7 @@
 
 =over
 
-=item C<allfiles_select>
+=item * C<allfiles_select>
 
 =back
 
@@ -506,7 +506,7 @@
 
 =over
 
-=item Previous initialisation by C<getallfilesinit>
+=item * Previous initialisation by C<getallfilesinit>
 
 =back
 
@@ -540,9 +540,9 @@
 
 =over
 
-=item C<releases_select>
+=item * C<releases_select>
 
-=item C<releases_insert>
+=item * C<releases_insert>
 
 =back
 
@@ -592,7 +592,9 @@
 
 =over
 
-=item C<delete_one_release>
+=item * C<delete_one_release>
+
+=back
 
 =cut
 
@@ -657,11 +659,11 @@
 
 =over
 
-=item C<status_select>
+=item * C<status_select>
 
-=item C<status_insert>
+=item * C<status_insert>
 
-=item C<status_update>
+=item * C<status_update>
 
 =back
 
@@ -696,23 +698,11 @@
 
 =back
 
-B<Note:>
-
-=over
-
-=item
-
-I<A file must> always I<<be indexed before being parsed for
-reference. Calling C<setfilereferenced> implicitly sets
-C<fileindexed> as well.>
-
-=back
-
 B<Requires:>
 
 =over
 
-=item C<status_select>
+=item * C<status_select>
 
 =back
 
@@ -744,17 +734,28 @@
 
 =back
 
+B<Note:>
+
+=over
+
+=item
+
+I<A file must> always I<be indexed before being parsed for
+references.>
+
+=back
+
 B<Requires:>
 
 =over
 
-=item C<status_select>
+=item * C<status_select>
 
-=item C<status_insert>
+=item * C<status_insert>
 
-=item C<status_update>
+=item * C<status_update>
 
-=item C<status_update_timestamp>
+=item * C<status_update_timestamp>
 
 =back
 
@@ -793,13 +794,7 @@
 
 =over
 
-=item C<status_select>
-
-=item C<status_insert>
-
-=item C<status_update>
-
-=item C<status_update_timestamp>
+=item * C<status_timestamp>
 
 =back
 
@@ -839,7 +834,7 @@
 
 =over
 
-=item C<definitions_select>
+=item * C<definitions_select>
 
 =back
 
@@ -895,7 +890,7 @@
 
 =over
 
-=item C<definitions_insert>
+=item * C<definitions_insert>
 
 =back
 
@@ -947,7 +942,7 @@
 
 =over
 
-=item C<usages_select>
+=item * C<usages_select>
 
 =back
 
@@ -991,9 +986,9 @@
 
 =over
 
-=item C<symbols_byname>
+=item * C<symbols_byname>
 
-=item C<usages_insert>
+=item * C<usages_insert>
 
 =back
 
@@ -1038,8 +1033,9 @@
 
 =head2 C<issymbol ($symname, $releaseid)>
 
-C<issymbol> returns a unique id for a symbol in a given release
-if it exists in the DB, C<undef> otherwise.
+C<issymbol> returns I<true> (1) for an existing symbol in a given release
+according to the DB,
+0 otherwise.
 
 =over
 
@@ -1057,7 +1053,7 @@
 
 =over
 
-=item C<symbols_byname>
+=item * C<symbols_byname>
 
 =back
 
@@ -1105,7 +1101,7 @@
 C<symid> returns a unique id for a symbol.
 
 If symbol is unknown, insert it into the DB with a zero reference count.
-The reference count is adjusted by the method which add definition
+The reference count is adjusted by the methods which add definition
 or usage.
 Decrementing the reference count is only done when purging the database.
 
@@ -1121,9 +1117,9 @@
 
 =over
 
-=item C<symbols_byname>
+=item * C<symbols_byname>
 
-=item C<symbols_insert>
+=item * C<symbols_insert>
 
 =back
 
@@ -1169,7 +1165,7 @@
 
 =over
 
-=item C<symbols_byid>
+=item * C<symbols_byid>
 
 =back
 
@@ -1207,9 +1203,9 @@
 
 =over
 
-=item C<langtypes_select>
+=item * C<langtypes_select>
 
-=item C<langtypes_insert>
+=item * C<langtypes_insert>
 
 =back
 
@@ -1222,6 +1218,8 @@
 
 =over
 
+=item
+
 I<This implementation is valid for DB engines with auto-incrementing
 fields. It must be overridden when the auto-incrementation feature
 is missing (e.g. PostgreSQL and SQLite).>
@@ -1248,7 +1246,7 @@
 
 =head2 C<deccount ()>
 
-C<deccount> retrieves the number of declaration types in the database.
+C<deccount> retrieves the number of type declarations in the database.
 
 It is used as a check to see if the database has been initialised.
 The previous mechanism based on a package variable in F<Generic.pm>
@@ -1258,7 +1256,7 @@
 
 =over
 
-=item C<langtypes_count>
+=item * C<langtypes_count>
 
 =back
 
@@ -1316,6 +1314,8 @@
 
 =over
 
+=item
+
 I<With the implementation of> C<flushcache>I<, this function is
 no longer necessary since the cache is also emptied in that
 subroutine.>
@@ -1340,7 +1340,7 @@
 optional argument to force 0-count write back
 
 (When creating the database, reference counts are incremented.
-Consequently, if the final count is still zero, the symbols has not
+Consequently, if the final count is still zero, the symbol has not
 been referenced and there is no need to overwrite the record.
 On the contrary, when purging the database, reference counts may
 decrement to zero and it is then mandatory to update the record
@@ -1359,6 +1359,14 @@
 
 The cache is then emptied
 
+B<Requires:>
+
+=over
+
+=item * C<symbols_setref>
+
+=back
+
 =cut
 
 sub flushcache {
@@ -1400,11 +1408,11 @@
 
 =over
 
-=item C<related_symbols_select>
+=item * C<related_symbols_select>
 
-=item C<delete_file_definitions>
+=item * C<delete_file_definitions>
 
-=item C<delete_file_usages>
+=item * C<delete_file_usages>
 
 =back
 
@@ -1495,15 +1503,15 @@
 
 =over
 
-=item C<delete_definitions>
+=item * C<delete_definitions>
 
-=item C<delete_usages>
+=item * C<delete_usages>
 
-=item C<delete_symbolss>
+=item * C<delete_symbolss>
 
-=item C<delete_releases>
+=item * C<delete_releases>
 
-=item C<delete_unused_status>
+=item * C<delete_unused_status>
 
 which should also delete I<files> table
 
@@ -1513,6 +1521,8 @@
 
 =over
 
+=item
+
 DBD C<commit()> is explicitly called to bypass possible
 disabling caused by private overriding method C<commit>.
 
@@ -1522,6 +1532,8 @@
 
 =over
 
+=item
+
 Manage the I<relid> relationship in I<definitions>
 
 =back
@@ -1553,39 +1565,19 @@
 	$self->{dbh}{'AutoCommit'} = $oldcommitmode;
 }
 
-=head2 C<purgeall>
+=head2 C<purgeall ()>
 
 C<purgeall> deletes all data in the DB.
 
-This is a more extensive version of C<purge> aimed at
-C<--reindexall --allversions> with VCSes
-which do not manage versions very well (e.g. CVS).
-
-=over
-
-=item 1 C<$releaseid>
-
-the target release (or version)
-
-=back
+This is a brutal way of erasing everything, I<e.g.> for
+C<--reindexall --allversions>.
+It is much more efficient than a sequence of C<purge> on every version.
 
 B<Requires:>
 
 =over
 
-=item C<purge_langtypes>
-
-=item C<purge_files>
-
-=item C<purge_definitions>
-
-=item C<purge_releases>
-
-=item C<purge_status>
-
-=item C<purge_symbols>
-
-=item C<purge_usages>
+=item * C<purge_all>
 
 =back
 
@@ -1597,9 +1589,9 @@
 	$self->{'purge_all'}->execute();
 }
 
-=head2 C<final_cleanup>
+=head2 C<final_cleanup ()>
 
-C<final_cleanup> allows to execute last actions on the database
+C<final_cleanup> allows to execute last-minute actions on the database
 and disconnects.
 
 Must be called before C<Index> object disappears.

Index: Lang.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Lang.pm,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -d -r1.50 -r1.51
--- Lang.pm	19 Apr 2013 12:42:14 -0000	1.50
+++ Lang.pm	21 Sep 2013 12:54:52 -0000	1.51
@@ -25,6 +25,12 @@
 It is responsible for creating the parser and handling the specific
 categories editing.
 
+A language parser is an I<object> with associated methods.
+I<Lang.pm> creates the base object, to be augmented/overriden by
+specific parsers in directory I<Lang>.
+The methods described below are generally only dummy declarations
+to capture missing specific implementations.
+
 =cut
 
 package LXR::Lang;
@@ -49,14 +55,39 @@
 
 a I<string> containing the release (version) of the file to parse
 
+B<Note:>
+
+=over
+
+=item
+
+I<Considering all call locations,
+this argument is not really necessary and we could as well
+use the global variable.>
+
+=back
+
 =item 1 C<@itag>
 
-an I<array> of 3 elements used to generate an C<<E<lt>AE<gt> >> link
+an I<array> of 3 elements used to generate an C<E<lt>AE<gt>> link
 for the identifiers found in the file (just insert the identifier name
 between the array elements)
 
 =back
 
+Creation of a specific parser is attempted first based on the file name
+and information from configuration parameter C<'filetype'>.
+If the file type is unknown,
+the first line of the file is read to tentatively extract a I<shebang>
+processed through configuration parameter C<'interpreters'>.
+In case there is no I<shebang>,
+an emacs-style C<mode:> is looked for.
+
+If all fail, C<undef> is returned.
+
+The LXR language name and argument C<@itag> are recorded in
+the created parser which is then returned.
+
 =cut
 
 sub new {
@@ -185,10 +216,10 @@
 
 =back
 
-The fragment is surrounded with C<<E<lt>spanE<gt> >> and C<<E<lt>/spanE<gt> >>
+The fragment is surrounded with C<E<lt>spanE<gt>> and C<E<lt>/spanE<gt>>
 tags. Special care is taken to repeat these tags at ends of line, so
 that the fragment can be correctly displayed on several lines without
-disturbing other highlighting (suv as line numbers or difference marks).
+disturbing other highlighting (such as line numbers or difference marks).
 
 =cut
 
@@ -196,7 +227,7 @@
 	my ($frag, $css) = @_;
 	$$frag = "<span class=\"$css\">$$frag</span>";
 	$$frag =~ s!\n!</span>\n<span class="$css">!g;
-	$$frag =~ s!<span class="comment"></span>$!! ; #remove excess marking
+	$$frag =~ s!<span class=".+?"></span>$!!; #remove excess marking
 }
 
 
@@ -319,7 +350,7 @@
 	my $tail;
 
 	if (!defined($link)) {
-		if ($path !~ m!/!) {
+		if (index($path, '/') < 0) {
 			$tail = $file;
 		} elsif (substr($path, -1) eq '/') {
 		# Path ends with /: it may be a directory or an HTTP request.
@@ -327,13 +358,13 @@
 			chop($path);
 			$tail = $sep;
 			$file = substr($file, 0, rindex($file, $sep));
-			$link = &LXR::Common::incdirref($file, "include", $path, $dir);
+			$link = incdirref($file, 'include', $path, $dir);
 		}
 	}
-	# If incref or incdiref did not return a link to the file,
+	# If incref or incdirref did not return a link to the file,
 	# explore however the path to see if directories are
 	# known along the way.
-	while	(	$path =~ m!/!
+	while	(	index($path, '/') >= 0
 			&&	substr($link, 0, 1) ne '<'
 			) {
 		# NOTE: the following rindex never returns -1, because
@@ -343,12 +374,12 @@
 		$tail = substr($file, $sp) . $tail;
 		$file = substr($file, 0, $sp);
 		$path =~ s!/[^/]+$!!;
-		$link = &LXR::Common::incdirref($file, "include", $path, $dir);
+		$link = incdirref($file, 'include', $path, $dir);
 	}
 	# A known directory (at least) has been found.
 	# Build links to higher path elements
 	if (substr($link, 0, 1) eq '<') {
-		while ($path =~ m!/!) {
+		while (index($path, '/') >= 0) {
 			# NOTE: see note above about rindex
 			$l = index  ($link, '>');
 			$r = rindex ($link, '<');
@@ -359,7 +390,7 @@
 			$sp = rindex ($file, $sep);
 			$file = substr($file, 0, $sp);
 			$path =~ s!/[^/]+$!!;
-			$link = &LXR::Common::incdirref($file, "include", $path, $dir);
+			$link = incdirref($file, 'include', $path, $dir);
 		}
 	}
 	return $link . $tail;
@@ -403,8 +434,12 @@
 
 =over
 
-I<This method is nowhere invoked. It corresponds to no category. It is
-thus candidate for removal.
+=item
+
+I<This method is nowhere invoked because keywords are processed in
+C<processcode> simultaneouly with identifiers.
+It corresponds to no category. It is
+thus candidate for removal.>
 
 =back
 
@@ -442,7 +477,7 @@
 
 a I<reference> to the index (DB) object
 
-=itm 1 C<$config>
+=item 1 C<$config>
 
 a I<reference> to the configuration objet
 
@@ -482,7 +517,7 @@
 
 a I<reference> to the index (DB) object
 
-=itm 1 C<$config>
+=item 1 C<$config>
 
 a I<reference> to the configuration objet
 
@@ -500,7 +535,7 @@
 =head2 C<language ()>
 
 Method C<language> is usually a shorthand notation for
-C<<$lang-E<gt>{'language'}>>.
+C<$lang-E<gt>{'language'}>.
 
 =cut
 

Index: Markup.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Markup.pm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- Markup.pm	21 Nov 2012 13:39:28 -0000	1.8
+++ Markup.pm	21 Sep 2013 12:54:52 -0000	1.9
@@ -21,7 +21,7 @@
 
 # =encoding utf8	Not recognised??
 
-=head1 Template module
+=head1 Markup module
 
 This module is the markup engine in charge of highlighting the
 syntactic components or otherwise interesting elements of a block.
@@ -85,8 +85,8 @@
 
 	# Look for identifiers and create links with identifier search query.
 	# TODO: Is there a performance problem with this?
-	$string =~ s#(^|\s)([a-zA-Z_~][a-zA-Z0-9_]*)\b#
-		$1.(is_linkworthy($2) ? &idref($2, "", $2) : $2)#ge;
+	$string =~ s/(^|\s)([a-zA-Z_~][a-zA-Z0-9_]*)\b/
+		$1.(is_linkworthy($2) ? &idref($2, '', $2) : $2)/ge;
 
 	# HTMLify the special characters we marked earlier,
 	# but not the ones in the recently added xref html links.
@@ -95,8 +95,8 @@
 	$string =~ s/\0>/&gt;/g;
 
 	# HTMLify email addresses and urls.
-	$string =~
-	  s#((ftp|http|nntp|snews|news)://(\w|\w\.\w|\~|\-|\/|\#)+(?!\.\b))#<a href=\"$1\">$1</a>#g;
+	$string =~ s{((ftp|http|nntp|snews|news)://(\w|\w\.\w|\~|\-|\/|\#)+(?!\.\b))}
+				{<a href=\"$1\">$1</a>}g;
 
 	# htmlify certain addresses which aren't surrounded by <>
 	$string =~ s/([\w\-\_]*\@netscape.com)(?!&gt;)/<a class='offshore' href=\"mailto:$1\">$1<\/a>/g;
@@ -108,8 +108,8 @@
 	$string =~ s/(&lt;)(.*@.*)(&gt;)/$1<a class='offshore' href=\"mailto:$2\">$2<\/a>$3/g;
 
 	# HTMLify file names, assuming file is in the directory defined by $virtp.
-	$string =~
-	  s#\b(([\w\-_\/]+\.(c|h|cc|cp|hpp|cpp|java))|README)\b#{fileref($1, '', $virtp . $1);}#ge;
+	$string =~ s{\b(([\w\-_\/]+\.(c|h|cc|cp|hpp|cpp|java))|README)\b}
+				{fileref($1, '', $virtp . $1);}ge;
 
 	return ($string);
 }
@@ -142,25 +142,27 @@
 
 =over
 
-Presently, the DB check is not implemented.
-It could be through C<index->symreferences($string, $releaseid)>
-or C<$index->symdeclarations($string, $releaseid)>
+=item
+
+DB check is not implemented.
+It could be through C<index-E<gt>symreferences($string, $releaseid)>
+or C<$index-E<gt>symdeclarations($string, $releaseid)>
 if we want to consider only declared identifiers.
 
+=back
+
 =cut
 
 sub is_linkworthy {
 	my ($string) = @_;
 
-	if ($string =~ m/....../
-		&& ($string =~ m/_/ || $string =~ m/.[A-Z]/)
-		&& $string !~ m/README/
-#		&& defined($xref{$string}) FIXME
-	   ) {
-		return (1);
-	} else {
-		return (0);
-	}
+	return	(	5 < length($string)
+			&&	(	0 <= index($string, '_')
+				||	$string =~ m/.[A-Z]/
+				)
+			&&	0 > index($string, 'README')
+	#		&&	defined($xref{$string}) FIXME
+			);
 }
 
 
@@ -177,7 +179,7 @@
 
 =back
 
-This sub is called before editing (highlighting) its content
+This sub is called before editing (highlighting) the string argument
 so that we can later distinguish between original litteral HTML special
 characters and those added as part of HTML tags.
 
@@ -219,9 +221,9 @@
 }
 
 
-=head2 C<htmlquote ($string)>
+=head2 C<freetextmarkup ($string)>
 
-Function C<htmlquote> creates links in its argument for URLs and e-mail addresses.
+Function C<freetextmarkup> creates links in its argument for URLs and e-mail addresses.
 
 =over
 
@@ -249,18 +251,18 @@
 
 =over
 
-=item 1 C<$sfileh>
+=item 1 C<$fileh>
 
 a I<filehandle> for the source file
 
-=item 1 C<$sfileh>
+=item 1 C<$outfun>
 
 a reference to a I<sub> which outputs the HTML stream
 
 =back
 
 This sub calls the parser to split the source file into homogeneous
-fragments which are highlited by various specialized support routines.
+fragments which are highlighted by various specialized support routines.
 
 Sub C<&outfun> is called to output the HTML stream.
 Use of a subroutine allows to do the highlighting with C<markupfile> in
@@ -284,20 +286,20 @@
 	#	2: '</a>'
 	#	Later, it only needs to insert line numbers betwwen 0-1 and 1-2 to
 	#	have the correct anchor.
-	&fileref(1, "fline", $pathname, 1) =~ m/^(<a.*?)href.*\#(\d+)(\">)\d+(<\/a>)$/;
+	&fileref(1, 'fline', $pathname, 1) =~ m/^(<a.*?)href.*\#(\d+)(\">)\d+(<\/a>)$/;
 	my @ltag;
 	$ltag[0] = $1 . 'name="';
 	my $line = $2;
 	$ltag[1] = $3;
-	$ltag[2] = $4 . " ";
+	$ltag[2] = $4 . ' ';
 
 	# As an optimisation, the skeleton of the <A> link marking for an
 	# identifier will be cached in the $lang object.
 	# To guard against any modification of the <A> link structure by
 	# sub idref, a very specific (and improbable) identifier is used.
 	# This allows to make no assumption on idref result.
-	my $itagtarget = "!!!";
-	my @itag = &idref("$itagtarget", "fid", $itagtarget) =~ m/^(.*)$itagtarget(.*)$itagtarget(.*)$/;
+	my $itagtarget = '---';
+	my @itag = &idref($itagtarget, 'fid', $itagtarget) =~ m/^(.*)$itagtarget(.*)$itagtarget(.*)$/;
 	my $lang = LXR::Lang->new($pathname, $releaseid, @itag);
 
 	if ($lang) {
@@ -343,13 +345,13 @@
 
 	} elsif ($pathname =~ m/\.($graphic)$/) {
 	# Graphic files are detected by their extension
-		&$outfun("<b>Image: </b>");
-		&$outfun("<img src=\""
-			  . $config->{'sourceaccess'}
-			  . "/" . $config->variable('v')
-			  . $pathname
-			  . "\" border=\"0\""
-			  . " alt=\"No access to $pathname or browser cannot display this format\">");
+		&$outfun('<b>Image: </b>');
+		&$outfun('<img src="'
+				. $config->{'sourceaccess'}
+				. '/' . $config->variable('v')
+				. $pathname
+				. '" border="0"'
+				. " alt=\"No access to $pathname or browser cannot display this format\">");
 	} elsif ($pathname =~ m|/CREDITS$|) {
 	# Special case
 		while (defined($_ = $fileh->getline)) {
@@ -366,19 +368,27 @@
 
 		# If it's not a script or something with an Emacs spec header and
 		# the first line is very long or containts control characters...
-		if	(	m/^#!/
-			&&	m/-\*-.*-\*-/i
-			&&	(length($_) > 132 || m/[\x00-\x08\x0B\x0C\x0E-\x1F\x80-\x9F]/)
+		if	(	substr($_, 0, 2) ne '#!'
+			&&	! m/-\*-.*-\*-/
+			&&	(	length($_) > 132
+				||	m/[\x00-\x08\x0B\x0C\x0E-\x1F\x80-\x9F]/
+				)
 			) {
 			# We postulate that it's a binary file.
-			&$outfun("<ul><b>Binary File: ");
+			&$outfun('<ul><b>Binary File: ');
 			# jwz: URL-quote any special characters.
 			my $uname = $pathname;
 			$uname =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
 
-			&$outfun("<a href=\"$config->{virtroot}/source" . $uname . &urlargs("_raw=1") . "\">");
+			&$outfun	( '<a href="'
+						. $config->{'virtroot'}
+						. 'source'
+						. $uname
+						. &urlargs('_raw=1')
+						. '">'
+						);
 			&$outfun("$pathname</a></b>");
-			&$outfun("</ul>");
+			&$outfun('</ul>');
 
 		} else {
 		# Unqualified text file, do minimal work

Index: SimpleParse.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/SimpleParse.pm,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- SimpleParse.pm	18 Aug 2012 15:47:21 -0000	1.21
+++ SimpleParse.pm	21 Sep 2013 12:54:52 -0000	1.22
@@ -88,26 +88,25 @@
 sub init {
 	my @blksep;
 
-	$fileh    = "";
 	@frags    = ();
 	@bodyid   = ();
 	@open     = ();
 	@term     = ();
 	@stay     = ();
-	$split    = "";
-	$open     = "";
-	$continue = "";
+	$split    = '';
+	$open     = '';
+	$continue = '';
 	$tabwidth = 8;
 	my $tabhint;
 
 	($fileh, $tabhint, @blksep) = @_;
-	$tabwidth = $tabhint || $tabwidth;
+	$tabwidth = $tabhint // $tabwidth;
 
 # Consider every specification in the order given
 	foreach my $s (@blksep) {
 		#	$k is category name (e.g; comment, string, ...)
 		my $k = (keys(%$s))[0];
-		if ($k eq "atom") {		# special case for uncategorised fragments
+		if ($k eq 'atom') {		# special case for uncategorised fragments
 			$continue = $$s{$k};
 		}
 		else {
@@ -129,7 +128,7 @@
 	}
 
 	# Replace the anchors with a Start_of_Line marker
-	# The markers are removed by sub C<markupfile before
+	# The markers are removed by sub markupfile before
 	# emiting HTML code
 	foreach (@open) {
 		$_ =~ s/^\^/\xFF/;
@@ -172,7 +171,7 @@
 
 Note that this sub is presently only used by sub C<markupfile>
 when no specific parser definition could be found.
-No attempt is made to interpret an Emacs-style tab specification.
+No attempt is made to interpret an emacs-style tab specification.
 Consequently, tab width can be erroneous.
 
 =cut
@@ -216,12 +215,16 @@
 
 =over
 
+=item
+
 I<Speed is acceptable when displaying a file (since time here is
 dominated by HTML editing).>
 
-I<<Raw speed can be seen during C<genxref> where the full tree is
+=item
+
+I<Raw speed can be seen during C<genxref> where the full tree is
 parsed. It could be worth to replace the parser by a compiled
-deterministic FSA version.>>
+deterministic FSA version.>
 
 =back
 
@@ -233,7 +236,7 @@
 	my $term  = undef;	# closing delim pattern
 	my $stay  = $continue;	# lock pattern
 	my $line  = '';		# line buffer
-	# These initial values sets the state for the "anonymous"
+	# These initial values set the state for the "anonymous"
 	# default category (i.e. code). It is switched to another
 	# state if $next (the following characters to process)
 	# begins with a starting delimiter.
@@ -302,7 +305,7 @@
 				}
 				my $opos = undef;
 			# Look for "term" or any "open delim" if not defined
-				my $change = $term || $split;
+				my $change = $term // $split;
 				if ($next =~ m/$change/) {
 			# Compute the position of the "end" delimiter
 					$next =~ m/^(.*?)($change)/s;
@@ -324,7 +327,7 @@
 #	Is it a named category?
 #	Add to output buffer till we find a closing delimiter.
 #	Remember that "stay" constructs have been processed above.
-			if (defined($btype)) {
+			if (defined($btype) && defined($term)) {
 				if ($next =~ m/$term/) {		# A close delim in this fragment?
 			# Next instruction group is 5.8 compatible but does
 			# not allow capture parenthesis in regexps
@@ -452,9 +455,11 @@
 
 =over
 
+=item
+
 When using this sub, pay special attention to the order of
 requests so that you do not create permutations of source
-sequences: it is a LIFO!
+sequences: it is a stack (LIFO)!
 
 =back
 

[Lxr-commits] CVS: lxr/lib/LXR Config.pm,1.57,1.58

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv3188/lib/LXR

Modified Files:
	Config.pm 
Log Message:
Config.pm: new tree selection variant

Implement 'routing' management with the new variant where tree name is first segment in URL after script name
Various syntax optimisations
Better comments

Index: Config.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Config.pm,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -d -r1.57 -r1.58
--- Config.pm	22 Jan 2013 09:39:28 -0000	1.57
+++ Config.pm	21 Sep 2013 12:18:53 -0000	1.58
@@ -52,7 +52,7 @@
 
 =item 1 C<@parms>
 
-the paramaters I<array> (just passed to C<_initialize>
+the paramaters I<array> (just passed "as is" to C<_initialize>)
 
 =back
 
@@ -98,6 +98,8 @@
 
 =over
 
+=item
+
 This method should only be used in cases when it is relevant to
 make distinction between the different blocks (such as I<showconfig>
 or the need to create links to other trees).
@@ -118,7 +120,7 @@
 
 	local ($/) = undef;
 	my $config_contents = <CONFIG>;
-	$config_contents =~ /(.*)/s;
+	$config_contents =~ m/(.*)/s;
 	$config_contents = $1;    #untaint it
 	my @config = eval("\n#line 1 \"configuration file\"\n" . $config_contents);
 	die($@) if $@;
@@ -145,6 +147,8 @@
 
 =over
 
+=item
+
 This is not a "method", it is a standard function.
 Its main goal is to provide an easy way to initialize the
 configuration C<'variables'> by reading the set of values from
@@ -163,53 +167,92 @@
 	$file = <INPUT>;
 	close(INPUT);
 
-	@data = $file =~ /([^\s]+)/gs;
+	@data = $file =~ m/([^\s]+)/gs;
 
 	return wantarray ? @data : $data[0];
 }
 
 
-=head2 C<_initialize ($url, $confpath)>
+=head2 C<_initialize ($host, $script_path, $firstseg, $confpath)>
 
 Internal method C<_initialize> does the real object initialization.
 
 =over
 
-=item 1 C<$url>
+=item 1 C<$host>
 
-a I<string> containing the initial part of the URL
+a I<string> containing the host name
+
+=item 1 C<$script_path>
+
+a I<string> containing the hierarchical web path to the script
 (truncated at the invoking script)
 
+=item 1 C<$firstseg>
+
+a I<string> containing the first segment of the path into the
+source-trees, possibly the tree name
+(may be empty if single-tree context)
+
+I<CAUTION! It may also be a first-level directory!>
+
 =item 1 C<$confpath>
 
-a I<string> containing the path of the configuration file
+a I<string> containing the path of an alternate configuration file
 (either relative to the LXR root directory or absolute)
 
 =back
 
 If C<$confpath> is not defined, use the internal C<$confname>.
 
-If C<$url> is not defined, try to extract something meaningful
-from the invoking URL.
+If C<$host>, C<$script_path> is not defined,
+try to extract something meaningful from the invoking URL.
+
+B<CAVEAT!>
+
+=over
+
+=item
+
+This C<sub> is also used by C<genxref>.
+C<genxref> is an ordinary script, operating in OS environment.
+Remember then that HTTP environment does not exists
+and there is no URL.
+Consequently, the last two arguments must be explicitly given.
+
+=back
 
 =cut
 
 sub _initialize {
-	my ($self, $url, $confpath) = @_;
+	my ($self, $host, $script_path, $firstseg, $confpath) = @_;
 	my ($dir,  $arg);
+	my	$routing;
 
-	unless ($url) {
-		$url = 'http://' . $ENV{'SERVER_NAME'} . ':' . $ENV{'SERVER_PORT'};
-		$url =~ s/:80$//;
+	unless ($host) {
+		$host = 'http://' . $ENV{'SERVER_NAME'} . ':' . $ENV{'SERVER_PORT'};
+		$host =~ s/:80$//;
 	}
 
-	$url =~ s!^//!http://!;		# allow a shortened form in genxref
-	$url =~ s!^http://([^/]*):443/!https://$1/!;
-	$url =~ s!/*$!/!;			# append / if necessary
+	$host =~ s!^//!http://!;		# allow a shortened form in genxref
+	$host =~ s!(//[^:/]+(:\d+)?).*!$1!;	# only host name and port
+	$host =~ s!^http://([^/]*):443!https://$1!;
+
+	unless ($script_path) {
+		$script_path = $ENV{'SCRIPT_NAME'};
+		$script_path =~ s!/[^/]*$!!;	# path to script
+	}
+	$script_path =~ s!^/*!/!;		# ensure a single starting /
 
 	unless ($confpath) {
-		($confpath) = ($0 =~ /(.*?)[^\/]*$/);
-		$confpath .= $confname;
+		# If $confname defines an absolute path, use it
+		if ('/' eq substr($confname, 0, 1)) {
+			$confpath = $confname;
+		} else {
+		# Otherwise, path is relative to the current executing script directory
+			($confpath) = ($0 =~ m!(.*?)[^/]*$!);
+			$confpath .= $confname;
+		}
 	}
 
 	unless (open(CONFIG, $confpath)) {
@@ -220,7 +263,7 @@
 
 	local ($/) = undef;
 	my $config_contents = <CONFIG>;
-	$config_contents =~ /(.*)/s;
+	$config_contents =~ m/(.*)/s;
 	$config_contents = $1;    #untaint it
 	my @config = eval("\n#line 1 \"configuration file\"\n" . $config_contents);
 	die($@) if $@;
@@ -230,26 +273,111 @@
 		%$self = (%$self, %{ $config[0] });
 	}
 
+#	Check for the presence of 'routing' parameters.
+#	It really matters when it is equal to 'argument' to force
+#	comparison with the first argument.
+#	Otherwise, for 'single' it cross-checks that configuration
+#	file has not been damaged or extended.
+#	If it does not exist, consider that tree selection is based
+#	on whatever is passed in the URL before the script name.
+	if (exists($config[0]->{'routing'})) {
+		$routing = $config[0]->{'routing'};
+		(my $caller) = $0 =~ m/([^\/]*)$/;
+		if ('single' eq $routing && 1 < $#config) {
+			die "single tree operation requested and $#config trees found in configuration file";
+		}
+		# tree selection through first argument, but none present;
+		# ask user to manually select.
+		if	(	'argument' eq $routing
+			&&	!defined($firstseg)
+			) {
+			if (1 == $#config) {	# Single tree, accept it
+				$firstseg = $config[1]->{'treename'};
+			} elsif ('genxref' eq $caller) {
+				goto FINAL;
+			} else {
+				print <<END_PROLOG;
+Content-Type: text/html; charset=utf-8
+Expires: Thu, 01 Jan 1970 00:00:00 GMT
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN">
+<html>
+	<head>
+		<title>Tree selector</title>
+	</head>
+	<body>
+		<h1>Please select one of the following trees:</h1>
+		<ul>
+END_PROLOG
+			# We don't check hostname and virtroot because we suppose
+			# user set them right (but for the missing tree name).
+			# Anyway, they'll be checked when we return with the
+			# completed URL
+				my $no_tree = 1;
+				my $uri = $ENV{'SCRIPT_NAME'};
+				$uri =~ s|([^-a-zA-Z0-9.@/_~\r\n])|sprintf('%%%02X', ord($1))|ge;
+				foreach my $config (@config[1..$#config]) {
+					my $c =  $config->{'caption'};
+					$c =~ s/</&lt;/g;	# Protect against HTML mayhem
+					$c =~ s/>/&gt;/g;
+					print '<li>';
+					if (exists($config->{'treename'})) {
+						print '<em>'
+							, $config->{'treename'}
+							, '</em>: ';
+						print '<a href="'
+							, $host
+							, $uri
+							, '/'
+							, $config->{'treename'}
+							, '">'
+							, $c
+							, '</a>';
+						$no_tree = 0;
+					} else {
+						print '<del>'
+							, $c
+							, '</del>'
+							, ' <em>(No tree identification)</em>';
+					}
+					print "</li>\n";
+				}
+				print "</ul>\n";
+				if ($no_tree) {
+					print <<END_NOTREE;
+		<h2>Error! No enabled tree!</h2>
+			<p>
+Configuration file claims tree selection through first segment of
+argument to script and no tree has an associated
+<code>'treename'</code> parameter.
+			</p>
+			<p>
+You must first fix your configuration file!
+			</p>
+END_NOTREE
+				}
+				print <<END_EPILOG;
+	</body>
+</html>
+END_EPILOG
+				exit 0;
+			}
+		}
+	}
+
 #	Find the applicable parameter group
 #	"Modern" identification is based on 'host_names' and 'virtroot'
 #	parameters (which needs to spplit $url); "compatibility"
 #	identification uses 'baseurl' and 'baseurl_aliases'.
 #	The target id ends up in 'baseurl' in both cases.
-	$url =~ m!(^.*?://[^/]+)!;	# host name and port used to access server
-	my $host = $1;
 		# To allow simultaneous Apache and lighttpd operation
 		# on 2 different ports, remove port for identification
 	$host =~ s/(:\d+|)$//;
-	my $port = $1;
-	my $script_path;
-	if ($url) {
-		($script_path = $url) =~ s!^.*?://[^/]*!!; # remove host and port
-	} else {
-		$script_path = $ENV{'SCRIPT_NAME'};
-	}
-	$script_path =~ s!/[^/]*$!!;	# path to script
-	$script_path =~ s!^/*!/!;		# ensure a single starting /
+	$host = lc($host);	# hosts should match case-insensitively
+	my $port = $1;#die "host $host - port $port - script $script_path - SCRIPT_NAME $ENV{'SCRIPT_NAME'} - tree $firstseg - PATH_INFO $ENV{'PATH_INFO'}\n";
+
 	my $parmgroup = 0;
+	my $virtroot;
 		# Test every parameter group in turn
 CANDIDATE: foreach my $config (@config[1..$#config]) {
 		$parmgroup++;				# next parameter group
@@ -262,15 +390,10 @@
 		} elsif (exists($self->{'host_names'})) {
 			@hostnames = @{$self->{'host_names'}};
 		};
-		my $virtroot = $config->{'virtroot'};
-		my $hits = $virtroot =~ s!/+$!!;	# ensure no ending /
-		$hits += $virtroot =~ s!^/*!/!;		# and a single starting /
-		if ($hits > 0) {
-			$config->{'virtroot'} = $virtroot
-		}
-		if ('/' eq $virtroot) {				# special case: LXR at root
-			$config->{'virtroot'} = '';		# make sure no trouble on relative links
-		}
+		$virtroot = $config->{'virtroot'}
+					// $$self{'virtroot'};
+		$virtroot =~ s!/+$!!;		# ensure no ending /
+		$virtroot =~ s!^/*!/!;		# and a single starting /
 		if (scalar(@hostnames)>0) {
 			foreach my $rt (@hostnames) {
 				$rt =~ s!/*$!!;		# remove trailing /
@@ -278,8 +401,13 @@
 		# To allow simultaneous Apache and lighttpd operation
 		# on 2 different ports, remove port for identification
 				$rt =~ s/:\d+$//;
-				if	(	$host eq $rt
+				if	(	$host eq lc($rt)
 					&&	$script_path eq $virtroot
+					&&	(	'argument' ne $routing
+						||	(	defined($firstseg)
+							&&	$firstseg eq $config->{'treename'}
+							)
+						)
 					) {
 					$config->{'baseurl'} = $rt . $port . $script_path;
 					%$self = (%$self, %$config);
@@ -290,19 +418,25 @@
 		} else { # elsif ($config->{'baseurl'}) {
 		# To allow simultaneous Apache and lighttpd operation
 		# on 2 different ports, remove port for identification
-			$url =~ s/:\d+$//;
 			my @aliases;
 			if ($config->{'baseurl_aliases'}) {
 				@aliases = @{ $config->{'baseurl_aliases'} };
 			}
-			my $root = $config->{'baseurl'};
-			push @aliases, $root;
+			unshift @aliases, $config->{'baseurl'};
+			my $l = length($host);
 			foreach my $rt (@aliases) {
-				$rt .= '/' unless $rt =~ m#/$#;    # append / if necessary
-				$rt =~ s/:\d+$//;	# remove port (approximate match)
-				my $r = quotemeta($rt);
-				if ($url =~ /^$r/) {
-					$rt =~ s/^$r/$rt$port/;
+				$rt =~ s!/*$!/!;    # append / if necessary
+				if	(	$host eq lc(substr($rt, 0, $l))
+					&&	(  substr($rt, $l, 1) eq '/'
+						|| substr($rt, $l, 1) eq ':'
+						)
+					&&	$script_path eq $virtroot
+					&&	(	'argument' ne $routing
+						||	(	defined($firstseg)
+							&&	$firstseg eq $config->{'treename'}
+							)
+						)
+					) {
 					$config->{'baseurl'} = $rt;
 					%$self = (%$self, %$config);
 					$$self{'parmgroupnr'} = $parmgroup;
@@ -312,31 +446,51 @@
 		}
 	}
 
+FINAL:
 #	Have we found our target?
 	if(!exists $self->{'baseurl'}) {
 		$0 =~ m/([^\/]*)$/;
-		if("genxref" ne $1) {
+		if('genxref' ne $1) {
+			#	Create a surrogate baseurl to allow an expansion of
+			#	$baseurl for <base> in the HTML templates
+			$self->{'baseurl'} = $host . $port . $script_path;
 			return 0;
-		} elsif($url =~ m!(https?:)?//.+!) {
-			die "Can't find config for $url: make sure there is a 'host_names' + 'virtroot' combination or a 'baseurl' line that matches in lxr.conf\n";
+		} elsif($host =~ m!^(https?:)?//.!) {
+			die 'Can\'t find config for '
+				. $host.$script_path
+				. ( $firstseg
+				  ? " ($firstseg)"
+				  : ''
+				  )
+				. ': make sure there is a "host_names" + "virtroot" combination'
+				. ' or a "baseurl" line that matches in lxr.conf'
+				. "\n";
 		} else {
 			# wasn't a url, so probably genxref with a bad --url parameter
-			die "Can't find config for $url: " . 
-			 	"the --url parameter should be a URL (e.g. http://example.com/lxr) and must match a baseurl line in lxr.conf\n";
+			die 'Can\'t find config for '
+				. $host.$script_path
+				. ": the --url parameter should be a URL (e.g. http://example.com/lxr) and must match a baseurl line in lxr.conf\n";
 		}
 	}
 
-	$$self{'encoding'} = "iso-8859-1" unless (exists $self->{'encoding'});
+# Make sure there is a trailing /, so that the script name may be concatenated
+# without any separator. This avoids the site-root special case where we
+# could inadvertantly generate an URL starting with //, erroneously
+# exhibiting an non existent host!
+	$virtroot =~ s!/*$!/!;
+	$$self{'virtroot'} = $virtroot;	# From now on, use the modified virtual root
+
+	$$self{'encoding'} = 'iso-8859-1' unless (exists $self->{'encoding'});
 
 #	Final checks on the parsing dispatcher
 	if (!exists $self->{'filetype'}) {
 		if (exists $self->{'filetypeconf'}) {
 			unless (open(FILETYPE, $self->{'filetypeconf'})) {
-				die("Couldn't open configuration file ".$self->{'filetypeconf'});
+				die('Couldn\'t open configuration file '.$self->{'filetypeconf'});
 			}
 			local ($/) = undef;
 			my $contents = <FILETYPE>;
-			$contents =~ /(.*)/s;
+			$contents =~ m/(.*)/s;
 			$contents = $1;    #untaint it
 			my $mapping = eval("\n#line 1 \"file mappings\"\n" . $contents);
 			die($@) if $@;
@@ -364,16 +518,28 @@
 		
 	} elsif (exists $self->{'glimpsebin'}) {    
 		if (!exists($self->{'glimpsedir'})) {
-			die "Please specify glimpsedirbase or glimpsedir in $confpath\n"
+			die "Please specify 'glimpsedirbase' or 'glimpsedir' in $confpath\n"
 				unless exists($self->{'glimpsedirbase'});
-			$self->{'glimpsedir'} = $self->{'glimpsedirbase'} . $self->{'virtroot'};
+			$self->{'glimpsedir'}	= $self->{'glimpsedirbase'}
+									. $self->{'virtroot'}
+									. ('argument' eq $routing
+									  ? $self->{'treename'}
+									  : ''
+									  )
+									;
 		}
 		_ensuredirexists($self->{'glimpsedir'});
 	} elsif (exists $self->{'swishbin'}) {    
 		if (!exists($self->{'swishdir'})) {
-			die "Please specify swishdirbase or swishdir in $confpath\n"
+			die "Please specify 'swishdirbase' or 'swishdir' in $confpath\n"
 				unless exists($self->{'swishdirbase'});
-			$self->{'swishdir'} = $self->{'swishdirbase'} . $self->{'virtroot'};
+			$self->{'swishdir'}	= $self->{'swishdirbase'}
+								. $self->{'virtroot'}
+								. ('argument' eq $routing
+								  ? $self->{'treename'}
+								  : ''
+								  )
+								;
 		}
 		_ensuredirexists($self->{'swishdir'});
 	} else {
@@ -430,7 +596,7 @@
 
 =over
 
-=item 1 Presently, only parameter C<'hostnames'> is used
+=item 1 Presently, only parameter C<'host_names'> is used
 because the automatic configurator does not use C<'baseurl'>
 nor C<'baseurl_aliases'>, which are deprecated.
 
@@ -465,23 +631,33 @@
 	my ($self, $group, $global) = @_;
 
 	my ($accesshost, $accessport) =
-		$HTTP->{'script_path'} =~ m!(^.+?://[^/:]+)(:\d+)?!;
-	(my $scriptpath = $HTTP->{'script_path'}) =~ s!(^.+?://[^/:]+)(:\d+)?!$1!;
-	my @hosts = @{$group->{'host_names'} || $global->{'host_names'}};
-	my $virtroot =  $group->{'virtroot'};
+		$HTTP->{'host_access'} =~ m!(^.+?://[^/:]+)(:\d+)?!;
+	$accesshost = lc($accesshost);
+	my $scriptpath = $HTTP->{'script_path'};
+	$scriptpath =~ s!^/*!/!;	# ensure a single starting /
+	my @hosts = @{$group->{'host_names'} // $global->{'host_names'}};
+	my $virtroot =  $group->{'virtroot'} // $global->{'virtroot'};
+	$virtroot =~ s!/+$!!;		# ensure no ending /
+	$virtroot =~ s!^/*!/!;		# and a single starting /
 	my $url;
 	my $port;
 	for my $hostname (@hosts) {
 		$hostname =~ s!/*$!!;		# remove trailing /
 		$hostname =~ s/(:\d+)$//;	# remove port
-		my $port = $1;
+		$port = $1;
+		$hostname = lc($hostname);
 	# Add http: if it was dropped in the hostname
 		if ($hostname !~ m!^.+?://!) {
-			$hostname = "http:" . $hostname;
+			$hostname = 'http:' . $hostname;
 		}
 		$url = $hostname . $virtroot;
 	# Is this the presently used hostname?
-		last if $url eq $scriptpath;
+		if	(	$hostname eq $accesshost
+			&&	$virtroot eq $scriptpath
+			&&	$config->{'treename'} eq $group->{'treename'}
+			) {
+			last;
+		}
 		$url = undef;
 	}
 	# The current tree has been found, tell the caller
@@ -494,9 +670,10 @@
 		$hostname =~ s!/*$!!;		# remove trailing /
 		$hostname =~ s/(:\d+)$//;	# remove port
 		$port = $1;
+		$hostname = lc($hostname);
 	# Add http: if it was dropped in the hostname
 		if ($hostname !~ m!^.+?://!) {
-			$hostname = "http:" . $hostname;
+			$hostname = 'http:' . $hostname;
 		}
 		if ($hostname eq $accesshost) {
 			$url = $hostname;
@@ -507,15 +684,15 @@
 	# Take the first name but NOTE it is not reliable
 	if (!defined($url)) {
 		$url = $group->{'host_names'}[0]
-			|| $global->{'host_names'}[0];
+			// $global->{'host_names'}[0];
 		$url =~ s/(:\d+)$//;
 		$port = $1;
 	}
 	# If a port is given on 'host_names', use it.
 	# Otherwise, use the incoming request port
-	$url .= $port || $accessport;
-	$url = "http:" . $url unless ($url =~ m!^.+?://!);
-	return $url . $virtroot;
+	$url .= $port // $accessport;
+	$url = 'http:' . $url unless ($url =~ m!^.+?://!);
+	return $url . $virtroot . '/';
 }
 
 
@@ -557,13 +734,13 @@
 
 	$self->{'variables'}{$var}{'value'} = $val if defined($val);
 	return $self->{'variables'}{$var}{'value'}
-	  || $self->vardefault($var);
+	  // $self->vardefault($var);
 }
 
 
 =head2 C<vardefault ($var)>
 
-Method C<variable> returns the default value of the designated variable.
+Method C<vardefault> returns the default value of the designated variable.
 
 =over
 
@@ -584,17 +761,18 @@
 	if (exists($self->{'variables'}{$var}{'default'})) {
 		return $self->{'variables'}{$var}{'default'}
 	}
-	if (ref($self->{'variables'}{$var}{'range'}) eq "CODE") {
+	if (ref($self->{'variables'}{$var}{'range'}) eq 'CODE') {
 		my @vr = varrange($var);
-		return $vr[0] if scalar(@vr)>0; return "head"
+		return $vr[0] if scalar(@vr)>0;
+		return 'head'
 	}
 	return	$self->{'variables'}{$var}{'range'}[0];
 }
 
 
-=head2 C<vardefault ($var, $val)>
+=head2 C<vardescription ($var, $val)>
 
-Method C<variable> returns the description of the designated variable.
+Method C<vardescription> returns the description of the designated variable.
 
 =over
 
@@ -612,8 +790,10 @@
 
 =over
 
+=item
+
 Don't be confused! The word "description" is human semantic meaning
-for this data. It is stored in the C<'data'> element of the hash
+for this data. It is stored in the C<'name'> element of the hash
 representing the variable and its state.
 
 =back
@@ -631,7 +811,7 @@
 
 =head2 C<varrange ($var)>
 
-Method C<variable> returns the set of values of the designated variable.
+Method C<varrange> returns the set of values of the designated variable.
 
 =over
 
@@ -645,18 +825,18 @@
 
 sub varrange {
 	my ($self, $var) = @_;
-no strict "refs";
-	if (ref($self->{'variables'}{$var}{'range'}) eq "CODE") {
+no strict 'refs';	# NOTE: Without it, next line fails in $var!
+	if (ref($self->{'variables'}{$var}{'range'}) eq 'CODE') {
 		return &{ $self->{'variables'}{$var}{'range'} };
 	}
 
-	return @{ $self->{'variables'}{$var}{'range'} || [] };
+	return @{ $self->{'variables'}{$var}{'range'} // [] };
 }
 
 
 =head2 C<varexpand ($exp)>
 
-Method C<variable> returns its argument with all occurrences of
+Method C<varexpand> returns its argument with all occurrences of
 C<$xxx> replaced by the current value of variable C<'xxx'>.
 
 =over
@@ -679,7 +859,7 @@
 
 =head2 C<value ($var)>
 
-Method C<variable> returns the value of a configuration parameter
+Method C<value> returns the value of a configuration parameter
 with occurrences of C<$xxx> replaced by the current value of
 variable C<'xxx'>.
 
@@ -724,7 +904,7 @@
 
 =back
 
-When a bareword is encountered in a construct like C<$config->bareword>,
+When a bareword is encountered in a construct like C<$config-E<gt>bareword>,
 this method is called. It tries to get the expanded value of
 configuration parameter C<'bareword'> with method C<value>.
 If the value itself is a function, that function is called with
@@ -751,7 +931,7 @@
 =head2 C<mappath ($path, @args)>
 
 Method C<mappath> returns its argument path transformed by
-the C'maps'> rules.
+the C<'maps'> rules.
 
 =over
 
@@ -770,6 +950,8 @@
 
 =over
 
+=item
+
 The rules are applied once only in the path.
 Should they be globally applied (with flag C<g> on the regexp)?
 Does this make sense?
@@ -786,7 +968,7 @@
 
 	# Protect the current context
 	foreach $m (@args) {
-		if ($m =~ /(.*?)=(.*)/) {
+		if ($m =~ m/(.*?)=(.*)/) {
 			$oldvars{$1} = $self->variable($1);
 			$self->variable($1, $2);
 		}
@@ -861,7 +1043,7 @@
 =over
 
 =item 1 C<$num> elements become C<.+?>, i.e. "match something, but not
-too much" to avoid to "swallow" what is described after this
+too much" to avoid "swallowing" what is described after this
 sub-pattern.
 
 B<Note:>
@@ -974,7 +1156,7 @@
 
 sub unmappath {
 	my ($self, $path, @args) = @_;
-	return $path if	(!exists($self->{'maps'})
+	return $path if	(  !exists($self->{'maps'})
 					|| scalar($self->allvariables)<2
 					);
 	my ($m, $n);
@@ -982,7 +1164,7 @@
 
 #	Save current environment before switching to @args environment
 	foreach $m (@args) {
-		if ($m =~ /(.*?)=(.*)/) {
+		if ($m =~ m/(.*?)=(.*)/) {
 			$oldvars{$1} = $self->variable($1);
 			$self->variable($1, $2);
 		}
@@ -992,9 +1174,7 @@
 	while ($i >= 0) {
 		$n = ${$self->{'maps'}}[$i--];
 		$m = ${$self->{'maps'}}[$i--];
-# 		if ($n =~ m/\$\{?[0-9]/) {
-# 			warning("Unable to reverse 'maps' rule $m => $n");
-# 		}
+
 	# Transform the original "replacement" into a pattern
 	#	Replace variable markers by their values
 		$n = $self->varexpand($n);
@@ -1003,42 +1183,65 @@
 
 	# Next transform the original "pattern" into a replacement
 	#	Remove x* or x? fragments since they are optional
+	#	Guard prefix insures left parenthesis is not an escaped one:
+	#	any character-----+
+	#	or escaped  <->   v     <-------> quantifiers
 		$m =~ s/((?:\\.|[^*?])+)[*?][+?]?/{
 			my $pre = $1;
-	#	( ... ) sub-pattern
-			if ($pre =~ m!(\\.|[^\\])\)$!) {
-	#	a- remove innermost ( ... ) blocks
+		#	( ... ) sub-pattern
+			if (')' eq substr($pre, -1)) {
+		#	a- remove innermost ( ... ) blocks
+				#          guards:     <------->      <->                <--------->
 				while ($pre =~ s!((?:^|\\.|[^\\])\((?:\\.|[^\(\)])*)\((?:\\.|[^\(\)])*\)!$1!) {};
-	# 			                 1                ^                1 ^                 ^
-	#	b- remove outer ( ... ) block
+				#     prefix     1                ^                1 ^     removed     ^
+				#        outer left parenthesis---+                  + innermost block +
+		#	b- remove outer ( ... ) block
+				#  guards:   <------->      <------->
 				$pre =~ s!(^|\\.|[^\\])\((?:\\.|[^\)])*\)$!$1!;
-	#	[ ... ] sub-pattern
-			} elsif ($pre =~ m!(\\.|[^\\])\]$!) {
+				# prefix  1           1 ^               ^
+				# removed block---------+---------------+
+		#	[ ... ] sub-pattern
+			} elsif (']' eq substr($pre, -1)) {
+				#  guards:   <------->      <------->
 				$pre =~ s!(^|\\.|[^\\])\[(?:\\.|[^\]])+\]$!$1!;
-	#	single character or class
+				# prefix  1           1 ^               ^
+				# removed block---------+---------------+
+		#	single character or class
 			} else {
 				$pre =~ s!\\?.$!!;
 			}
 			$pre;
 		}/ge;
+	#	Remove empty () blocks
 		$m =~ s!(^|[^\\])\(\)!$1!;
 	#	Remove + quantifiers since a single occurrence is enough
 		$m =~ s/(\\.|[^+])\+[+?]?/$1/g;
 	#	Process block constructs
 	#	( ... ) sub-pattern: replace by first alternative
 		while ($m =~ m!(^|\\.|[^\\])\(!) {
-	#	a- process innermost, i.e. non-nested, ( ... ) blocks
+		# guard prefix    <------->  ^
+		# real opening parenthesis---+
+		#	a- process innermost, i.e. non-nesting, ( ... ) blocks
+			#    guards:         <------->      <--------->         <----------->         <--------->
 			while ($m =~ s!((?:^|\\.|[^\\])\((?:\\.|[^\(\)])*)\(((?:\\.|[^\(\)\|])+)\|?(?:\\.|[^\(\)])*\)!$1$2!) {};
-		#	               1                ^                1 ^2                  2                    ^
-	#	b- process the remaining outer ( ... ) block
+			#   prefix     1                ^                1 ^2                  2                    ^
+			# outer left parenthesis--------+                  |+first-alternative-+                    |
+			#                 innermost left parenthesis-------+          innermost right parenthesis---+
+		#	b- process the remaining outer ( ... ) block
+			#  guards: <------->       <--------->           <--------->
 			$m =~ s!(^|\\.|[^\\])\(((?:\\.|[^\)\|])+)(?:\|(?:\\.|[^\(\)])*)?\)!$1$2!;
-#			        1           1 ^2                2                        ^
+			#       1--prefix---1 ^2                2    ^                ^  ^
+			# outer left par------+|                |    |                |  +-outer right par
+			# first alternative----+----------------+    +-----------other+alternatives
 		}
 	#	[ ... ] sub-pattern: replace by one character
+		#  guards: <------->   <------->     <------->
 		$m =~ s!(^|\\.|[^\\])\[(\\.|[^\]])(?:\\.|[^\\])*\]!
-			# Heuristic attempt to handle [^range]
-			if ($2 eq "^") {
-				$2 = "%";
+			#   1--prefix---1 ^2         2               ^
+			# left bracket----+|         |               +--right bracket
+			# firstcharacter --+---------+
+			if ($2 eq '^') {	# Heuristic attempt to handle [^range]
+				$2 = '%';		# Use this character (non used elsewhere)
 			}
 			$1 . $2;
 				!ge;
@@ -1056,8 +1259,8 @@
 
 	# Finally, transfer position information from original pattern
 	# to new pattern (i.e. start and end tags)
-		$n = "^" . $n if $m =~ s/^\^//;
-		$n .= "\$" if $m =~ s/\$$//;
+		$n = '^' . $n if $m =~ s/^\^//;
+		$n .= '$' if $m =~ s/\$$//;
 
 	# Apply the generated rule
 		$path =~ s/$n/$m/;

[Lxr-commits] CVS: lxr/templates/html html-config.html, 1.2, 1.3 html-fatal.html, 1.2, 1.3 html-head-btn-smaller.html, 1.6, 1.7 html-head-btn.html, 1.8, 1.9 html-head-smaller.html, 1.4, 1.5 html-head.html, 1.6, 1.7 html-ident.html, 1.4, 1.5 html-search-glimpse.html, 1.4, 1.5 html-search-swish.html, 1.3, 1.4

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/templates/html
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv17426/templates/html

Modified Files:
	html-config.html html-fatal.html html-head-btn-smaller.html 
	html-head-btn.html html-head-smaller.html html-head.html 
	html-ident.html html-search-glimpse.html 
	html-search-swish.html 
Log Message:
templates/html/*: various minor fixes

Index: html-config.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-config.html,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- html-config.html	21 Sep 2012 08:18:02 -0000	1.2
+++ html-config.html	4 Sep 2013 15:22:41 -0000	1.3
@@ -26,7 +26,7 @@
 		</td>
 		<td class="rightmost">
 			<p>
-			<form method="get" action="showconfig">
+			<form method="get" action="$varbtnaction">
 				<input type="hidden" name="_confall" value="1">
 				<button type="submit">Force all</button>
 			</form>

Index: html-fatal.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-fatal.html,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- html-fatal.html	4 Feb 2012 12:36:10 -0000	1.2
+++ html-fatal.html	4 Sep 2013 15:22:41 -0000	1.3
@@ -26,6 +26,7 @@
 <head>
 <meta http-equiv="content-type" content="text/html; charset=iso-8859-1">
 <title>Error - no tree</title>
+<base href="$baseurl">
 <link href="$stylesheet" rel="stylesheet" type="text/css">
 </head>
 
@@ -79,14 +80,14 @@
 		</td>
 		<td class="rightmost">
 			<a href="http://jigsaw.w3.org/css-validator/check/referer">
-  <img	src="http://jigsaw.w3.org/css-validator/images/vcss"
+  <img	src="LXRimages/vcss.gif"
 		alt="Valid CSS 2.1!"
 		height="31"
 		width="88"
   >
 			</a>
 			<a href="http://validator.w3.org/check?uri=referer">
-  <img	src="templates/valid-html401.png"
+  <img	src="LXRimages/valid-html401.png"
 		alt="Valid HTML 4.01!"
 		height="31"
 		width="88">

Index: html-head-btn-smaller.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-head-btn-smaller.html,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- html-head-btn-smaller.html	30 Sep 2012 10:33:46 -0000	1.6
+++ html-head-btn-smaller.html	4 Sep 2013 15:22:41 -0000	1.7
@@ -25,13 +25,10 @@
 <html>
 <head>
 	<title>$title</title>
-	<meta http-equiv="content-type" content="text/html; charset=$encoding">
 	<base href="$baseurl">
 	<link rel="stylesheet" type="text/css" href="$stylesheet">
 $alternatestyle{	<link rel="alternate stylesheet" type="text/css" href="$stylesheet" title="$stylename">
 }	<link  rel="icon" type="image/x-icon" href="LXRimages/LXRlogo32.ico">
-<!-- Candidat à destruction -->
-<!-- placer le script seulement où il y a besoin -->
 <script type="text/javascript">
 function ensureFocus()
 {

Index: html-head-btn.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-head-btn.html,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- html-head-btn.html	14 Nov 2012 11:28:13 -0000	1.8
+++ html-head-btn.html	4 Sep 2013 15:22:41 -0000	1.9
@@ -27,13 +27,10 @@
 <html>
 <head>
 	<title>$title</title>
-	<meta http-equiv="content-type" content="text/html; charset=$encoding">
 	<base href="$baseurl">
 	<link rel="stylesheet" type="text/css" href="$stylesheet">
 $alternatestyle{	<link rel="alternate stylesheet" type="text/css" href="$stylesheet" title="$stylename">
 }	<link  rel="icon" type="image/x-icon" href="LXRimages/LXRlogo32.ico">
-<!-- Candidat à destruction -->
-<!-- placer le script seulement où il y a besoin -->
 <script type="text/javascript">
 function ensureFocus()
 {

Index: html-head-smaller.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-head-smaller.html,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- html-head-smaller.html	30 Sep 2012 10:33:46 -0000	1.4
+++ html-head-smaller.html	4 Sep 2013 15:22:42 -0000	1.5
@@ -25,13 +25,10 @@
 <html>
 <head>
 	<title>$title</title>
-	<meta http-equiv="content-type" content="text/html; charset=$encoding">
 	<base href="$baseurl">
 	<link rel="stylesheet" type="text/css" href="$stylesheet">
 $alternatestyle{	<link rel="alternate stylesheet" type="text/css" href="$stylesheet" title="$stylename">
 }	<link  rel="icon" type="image/x-icon" href="LXRimages/LXRlogo32.ico" sizes="32x32">
-<!-- Candidat à destruction -->
-<!-- placer le script seulement où il y a besoin -->
 <script type="text/javascript">
 function ensureFocus()
 {

Index: html-head.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-head.html,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- html-head.html	14 Nov 2012 11:28:13 -0000	1.6
+++ html-head.html	4 Sep 2013 15:22:42 -0000	1.7
@@ -27,13 +27,10 @@
 <html>
 <head>
 	<title>$title</title>
-	<meta http-equiv="content-type" content="text/html; charset=$encoding">
 	<base href="$baseurl">
 	<link rel="stylesheet" type="text/css" href="$stylesheet">
 $alternatestyle{	<link rel="alternate stylesheet" type="text/css" href="$stylesheet" title="$stylename">
 }	<link  rel="icon" type="image/x-icon" href="LXRimages/LXRlogo32.ico">
-<!-- Candidat à destruction -->
-<!-- placer le script seulement où il y a besoin -->
 <script type="text/javascript">
 function ensureFocus()
 {

Index: html-ident.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-ident.html,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- html-ident.html	21 Nov 2012 17:01:16 -0000	1.4
+++ html-ident.html	4 Sep 2013 15:22:42 -0000	1.5
@@ -36,7 +36,7 @@
 (either belonging to a case-insensitive language or differing in case).
 </p>
 
-<form method="get" action="ident">
+<form method="get" action="$varbtnaction">
 	<p>
   $variables
 	<label>

Index: html-search-glimpse.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-search-glimpse.html,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- html-search-glimpse.html	14 Nov 2012 11:28:13 -0000	1.4
+++ html-search-glimpse.html	4 Sep 2013 15:22:42 -0000	1.5
@@ -33,8 +33,9 @@
 <br>Files ending in ",v" (CVS internal) or "~" (editor backup) are excluded from the search.
 </p>
 
-<form method="get" action="search">
+<form method="get" action="$varbtnaction">
 $variables{<input type="hidden" name="$variable" value="$value">
+}$urlargs{               <input type="hidden" name="$urlvar" value="$urlval">
 }	<table>
 		<tr>
 			<td>

Index: html-search-swish.html
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/html/html-search-swish.html,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- html-search-swish.html	14 Nov 2012 11:28:13 -0000	1.3
+++ html-search-swish.html	4 Sep 2013 15:22:42 -0000	1.4
@@ -31,8 +31,9 @@
 <br>Matches are case-insensitive unless you check the box below.
 <br>To use full-fledged Perl regex in the filename filter, check the other box below.
 
-<form method="get" action="search">
+<form method="get" action="$varbtnaction">
 $variables{<input type="hidden" name="$variable" value="$value">
+}$urlargs{               <input type="hidden" name="$urlvar" value="$urlval">
 }	<table>
 		<tr>
 			<td>

[Lxr-commits] CVS: lxr/templates/Apache apache-lxrserver.conf, 1.6, 1.7 htaccess-generic, 1.6, 1.7

[Andre-Littoz <ajl...@us...>]

Update of /cvsroot/lxr/lxr/templates/Apache
In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv30861/templates/Apache

Modified Files:
	apache-lxrserver.conf htaccess-generic 
Log Message:
templates/Apache/apache-lxrserver.conf, htaccess-generic: Apache support maintenance

Upgrade to new LCL version, adaptation to variants of tree designation in URL

Index: apache-lxrserver.conf
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/Apache/apache-lxrserver.conf,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- apache-lxrserver.conf	21 Jan 2013 10:49:36 -0000	1.6
+++ apache-lxrserver.conf	3 Sep 2013 08:56:16 -0000	1.7
@@ -1,5 +1,5 @@
 #
-#	Web server configuration for LXR server
+#	LXR Apache server configuration
 #
 #	$Id$
 #
@@ -8,62 +8,140 @@
 # directive syntax and semantics changed between releases.
 # When updating 2.2 -> 2.4, uncomment 2.4 specific lines
 #@IF	!%Apache24%
-#@	ASK Is your Apache version 2.4 or higher?; 1; yes, no; y, n
-#@	DEFINE	Apache24="%A%"
+#@	ASK,Apache24 Is your Apache version 2.4 or higher?; 1; yes, no; y, n
 #@ENDIF
 
-#@IF	80 != %port% && 8080 != %port% && 443 != %port%
+# =================================================
+# -------             Port list             -------
+#
+#	(only if different from 80, 8080 or 443)
+#	NOTE: remove duplicate ports since they cause trouble
+#	      and uncomment the remaining ones.
+
+#@IF	'H' ne "%_routing%" && 'P' ne "%_routing%"
+#@	IF	80 != %port% && 8080 != %port% && 443 != %port%
 Listen %port%
+#@	ENDIF
+#@	ARRAY	portaliases,P
+#@		IF	80 != %P% && 8080 != %P% && 443 != %P%
+#Listen %P%
+#@		ENDIF
+#@	ENDA
+#@ENDIF
+#@PASS2 here_ports
+#@	IF	'H' eq "%_routing%"
+#Listen XX
+#	where XX = port number for host %hostname%
+#@	ELSEIF	'P' eq "%_routing%"
+#	- host //%treeid%.%hostname% and its aliases
+#@		IF	80 != %port% && 8080 != %port% && 443 != %port%
+#Listen %port%
+#@		ENDIF
+#@		ARRAY	portaliases,P
+#@			IF	80 != %P% && 8080 != %P% && 443 != %P%
+#Listen %P%
+#@			ENDIF
+#@		ENDA
+#@	ENDIF
+#@ENDP2
+#@IF 'n' eq "%Apache24%"
+
+
+# The following directive is deprecated in 2.4 and becomes a no-op
+NameVirtualHost *
 #@ENDIF
+#@IF	'H' ne "%_routing%" && 'P' ne "%_routing%"
 
 
-#@IF	%_virthost%
+#@	IF	'localhost' ne "%hostname%" || %hostaliases%
 # =================================================
 #
-# -------    LXR as an independent site      ------
+# -------     LXR host name and aliases      ------
+#
+
+<VirtualHost *>
+	DocumentRoot	%LXRroot%
+	ServerName		%hostname%
+#@		ARRAY	hostaliases,H
+#@			ON none
+#	ServerAlias		# List here the aliases for host name
+#@			ENDON
+	ServerAlias		%H%
+#@		ENDA
+</VirtualHost>
+#@	ENDIF
+#@ELSE
+# =================================================
+#
+# -------    LXR host names and aliases      ------
 #
-#@IF 'n' eq "%Apache24%"
-# The following directive is deprecated in 2.4 and becomes a no-op
-NameVirtualHost *
 #@ENDIF
+#@PASS2	here_hosts
+#@	IF	'H' eq "%_routing%"
 
 <VirtualHost *>
 	DocumentRoot	%LXRroot%
 	ServerName		%hostname%
 #	ServerAlias		# List here the aliases for host name
+#@	IF	%_shared% && !%_commonvirtroot%
+	Alias %virtroot% "%LXRroot%"
+#@	ENDIF
+</VirtualHost>
+#@	ELSEIF	'P' eq "%_routing%"
+
+<VirtualHost *>
+	DocumentRoot	%LXRroot%
+	ServerName		%treeid%.%hostname%
+#@		ARRAY	hostaliases,H
+#@			ON none
+#	ServerAlias		# List here the aliases for host name
+#@			ENDON
+	ServerAlias		%treeid%.%H%
+#@		ENDA
+#@	IF	%_shared% && !%_commonvirtroot%
+	Alias %virtroot% "%LXRroot%"
+#@	ENDIF
 </VirtualHost>
+#@	ENDIF
+#@ENDP2
+#@IF	'E' eq "%_routing%"
 
 
-#@ENDIF	%_virthost%
 # =================================================
 #
 # ------- URL black magic for multiple trees ------
 #
 #	NOTE: this is the built-in default management method.
-#	      Adapt it to fit your custom management.
-#@IF %_singlecontext%
-#	Uncomment for multiple trees operation
+
+#@	IF	'c' eq %_virtrootpolicy%
 #AliasMatch ^%virtrootbase%/[^/]+/(.*) "%LXRroot%/$1"
-#@ELSE
-#	Comment out for single tree operation
+
+###		REMINDER	###
+### Adapt the previous regular expression to fit your selection method
+###		REMINDER	###
+#@	ELSEIF	'b' eq %_virtrootpolicy%
 AliasMatch ^%virtrootbase%/[^/]+/(.*) "%LXRroot%/$1"
-#@ENDIF
+#@	ELSE
+### ERROR ### ERROR ### ERROR ### Unknown selection method!
+#@	ENDIF
+#@ELSE
+#@	IF	'S' eq "%_routing%" || %_shared%
+
 
 # =================================================
 #
-# -------    Simple URL for a single tree    ------
+# -------    URL mapping to LXR directory    ------
 #
-#@IF '' eq %virtrootbase%
-#	Nothing to be done since LXR is located at root of server
-#@ELSE
-#@	IF %_singlecontext%
-#	Comment out for multiple trees operation
+#@	ENDIF
+#@	IF	%_shared% &&('N' eq "%_routing%" || 'A' eq "%_routing%" ||('H' eq "%_routing%" || 'P' eq "%_routing%") && %_commonvirtroot%)
 Alias %virtrootbase% "%LXRroot%"
-#@	ELSE
-#	Uncomment for single tree operation
-#	Alias %virtrootbase% "%LXRroot%"
 #@	ENDIF
 #@ENDIF
+#@PASS2 here_alias
+#@	IF	'S' eq "%_routing%"
+Alias %virtroot% "%LXRroot%"
+#@	ENDIF
+#@ENDP2
 
 
 # =================================================

Index: htaccess-generic
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/Apache/htaccess-generic,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- htaccess-generic	21 Jan 2013 10:49:36 -0000	1.6
+++ htaccess-generic	3 Sep 2013 08:56:16 -0000	1.7
@@ -13,8 +13,7 @@
 # directive syntax and semantics changed between releases.
 # When updating 2.2 -> 2.4, uncomment 2.4 specific lines
 #@IF	!%Apache24%
-#@	ASK Is your Apache version 2.4 or higher?; 1; yes, no; y, n
-#@	DEFINE	Apache24="%A%"
+#@	ASK,Apache24 Is your Apache version 2.4 or higher?; 1; yes, no; y, n
 #@ENDIF