lxr-commits — Don't use, CVS commits

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

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24584/lib/LXR

Modified Files:
	Common.pm 
Log Message:
Correct pathname cleaning


Index: Common.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Common.pm,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -d -r1.51 -r1.52
--- Common.pm	4 May 2005 23:19:33 -0000	1.51
+++ Common.pm	15 May 2005 22:59:31 -0000	1.52
@@ -169,7 +169,6 @@
 		return (undef);
 	}
 
-	$t =~ s/\+/ /g;
 	$t =~ s/\%([\da-f][\da-f])/pack("C", hex($1))/gie;
 
 	return ($t);
@@ -539,10 +538,10 @@
 	
 	if(defined $path) {
 		# First suppress anything after a dodgy character
-		$path =~ s!(^[\w_+-,.%^/]+).*!$1!;
+		$path =~ s!(^[\w_+-,.%^/\!]+).*!$1!;
 		# Clean out /../
-		while ($path =~ m!/../!) {
-			$path = s!/\.\./!/!g;
+		while ($path =~ m!/\.\.?/!) {
+			$path =~ s!/\.\.?/!/!g;
 		}
 	}
 	

[Lxr-commits] CVS: lxr genjavaclasses,1.1.1.1,NONE

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7538

Removed Files:
      Tag: release-0-9-4
	genjavaclasses 
Log Message:
Remove old java support file


--- genjavaclasses DELETED ---

[Lxr-commits] CVS: lxr/tests CVSTest.pm,1.1,1.2 SecurityTest.pm,1.1,1.2

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30194/lxr/tests

Modified Files:
	CVSTest.pm SecurityTest.pm 
Log Message:
Updates to testcode

Index: CVSTest.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/CVSTest.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- CVSTest.pm	4 May 2005 23:21:09 -0000	1.1
+++ CVSTest.pm	5 May 2005 22:01:34 -0000	1.2
@@ -1,4 +1,4 @@
-# Test cases for the LXR::Files::Plain module
+# Test cases for the LXR::Files::CVS module
 # Uses the associated lxr.conf file
 
 package CVSTest;

Index: SecurityTest.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/SecurityTest.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- SecurityTest.pm	4 May 2005 23:19:51 -0000	1.1
+++ SecurityTest.pm	5 May 2005 22:01:34 -0000	1.2
@@ -102,6 +102,51 @@
 
 }
 
+sub test_filename_wash {
+	# Check that filenames are washed
+	my $self = shift;
+
+	$ENV{'SERVER_NAME'} = 'test';
+	$ENV{'SERVER_PORT'} = 80;
+	$ENV{'SCRIPT_NAME'} = '/lxr/source';
+	$ENV{'PATH_INFO'} = '/a/test/path/../../../';
+	$ENV{'QUERY_STRING'} = 'v=../../;virtroot=testpath;dbname=notapath';
+
+	# Need to preserve signal handlers round call to httpinit as
+	# it sets up the LXR signal handlers.
+	
+	my $die = $SIG{'__DIE__'};
+	my $warn = $SIG{'__WARN__'};
+	
+	httpinit;
+	
+	$SIG{'__DIE__'} = $die;
+	$SIG{'__WARN__'} = $warn;
+
+	$self->assert($pathname eq '/', "pathname not washed, got $pathname");
+	$self->assert($HTTP->{'param'}->{'file'} eq $pathname, '$http->{param}->{file} not washed, got '.$HTTP->{'param'}->{'file'});	
+	
+	$ENV{'PATH_INFO'} = '';
+	$ENV{'QUERY_STRING'} = 'file=/a/test/path++many';
+	my $die = $SIG{'__DIE__'};
+	my $warn = $SIG{'__WARN__'};
+	httpinit;
+	$SIG{'__DIE__'} = $die;
+	$SIG{'__WARN__'} = $warn;
+	$self->assert($pathname eq '/a/test/path++many', "pathname not washed, got $pathname");
+
+	$ENV{'PATH_INFO'} = '/../.././.././a/test/path+!/some/%chars,v';
+	$ENV{'QUERY_STRING'} = '';
+	my $die = $SIG{'__DIE__'};
+	my $warn = $SIG{'__WARN__'};
+	httpinit;
+	$SIG{'__DIE__'} = $die;
+	$SIG{'__WARN__'} = $warn;
+	$self->assert($pathname eq '/a/test/path+!/some/%chars,v', "pathname not washed, got $pathname");
+	
+}
+
+
 sub test_config {
 	# Check that parameters in URL cannot alter config variables
 	

[Lxr-commits] CVS: lxr .htaccess,1.7,1.8

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29588/lxr

Modified Files:
	.htaccess 
Log Message:
PerlTaintCheck doesn't work for some reason - so switch it off.

Index: .htaccess
===================================================================
RCS file: /cvsroot/lxr/lxr/.htaccess,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- .htaccess	4 May 2005 23:21:09 -0000	1.7
+++ .htaccess	5 May 2005 21:59:50 -0000	1.8
@@ -14,7 +14,6 @@
 SetHandler perl-script
 PerlHandler Apache::Registry
 PerlSetEnv PERL5LIB lib
-PerlTaintCheck On
 ForceType text/html
 PerlSendHeader On
 </Files>

[Lxr-commits] CVS: lxr/lib/LXR/Files CVS.pm,1.32,1.33

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Files
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20746/lxr/lib/LXR/Files

Modified Files:
	CVS.pm 
Log Message:
Add test cases for Security and for some CVS bugs.

Enable taint mode for mod_perl - should reduce security vulnerabilities

Index: CVS.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Files/CVS.pm,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -d -r1.32 -r1.33
--- CVS.pm	2 Sep 2004 18:50:03 -0000	1.32
+++ CVS.pm	4 May 2005 23:21:09 -0000	1.33
@@ -27,17 +27,20 @@
 
 use vars qw(%cvs $cache_filename $gnu_diff);
 
+$cache_filename = '';
+
 sub new {
 	my ($self, $rootpath) = @_;
 
 	$self = bless({}, $self);
 	$self->{'rootpath'} = $rootpath;
 	$self->{'rootpath'} =~ s@/*$@/@;
-
+	$self->{'path'} = $config->cvspath;
+	
 	unless (defined $gnu_diff) {
 
 		# the rcsdiff command (used in getdiff) uses parameters only supported by GNU diff
-		$ENV{'PATH'} = '/bin:/usr/local/bin:/usr/bin:/usr/sbin';
+		$ENV{'PATH'} = $self->{'path'};
 		if (`diff --version 2>/dev/null` =~ /GNU/) {
 			$gnu_diff = 1;
 		} else {
@@ -169,7 +172,7 @@
 	$clean_filename =~ /(.*)/;
 	$clean_filename = $1;    # technically untaint here (cleanstring did the real untainting)
 
-	$ENV{'PATH'} = '/bin:/usr/local/bin:/usr/bin:/usr/sbin';
+	$ENV{'PATH'} = $self->{'path'};
 	open($fileh, "-|", "co -q -p$rev $clean_filename");
 
 	die("Error executing \"co\"; rcs not installed?") unless $fileh;
@@ -198,7 +201,7 @@
 	$clean_filename =~ /(.*)/;
 	$clean_filename = $1;    # technically untaint here (cleanstring did the real untainting)
 
-	$ENV{'PATH'} = '/bin:/usr/local/bin:/usr/bin:/usr/sbin';
+	$ENV{'PATH'} = $self->{'path'};
 	open($fileh, "-|", "rcsdiff -q -a -n -r$rev1 -r$rev2 $clean_filename");
 
 	die("Error executing \"rcsdiff\"; rcs not installed?") unless $fileh;

[Lxr-commits] CVS: lxr/tests CVSTest.pm,NONE,1.1 lxr.conf,1.1,1.2 AllTests.pm,1.1,1.2

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20746/lxr/tests

Modified Files:
	lxr.conf AllTests.pm 
Added Files:
	CVSTest.pm 
Log Message:
Add test cases for Security and for some CVS bugs.

Enable taint mode for mod_perl - should reduce security vulnerabilities

--- NEW FILE: CVSTest.pm ---
# Test cases for the LXR::Files::Plain module
# Uses the associated lxr.conf file

package CVSTest;
use strict;

use Test::Unit;
use lib "..";
use lib "../lib";

use LXR::Files;
use LXR::Config;
use LXR::Common;
use Cwd;
use File::Spec;

use base qw(Test::Unit::TestCase);

use vars qw($root);

$config = new LXR::Config("http://test/lxr", "./lxr.conf");

sub new {
	my $self = shift()->SUPER::new(@_);
#	$self->{config} = {};
	return $self;
}

# define tests

# test that a files object can be created
sub test_creation {
	my $self = shift;
	$self->assert(defined($self->{'cvs'}), "Failed to create Files::CVS");
	$self->assert($self->{'cvs'}->isa("LXR::Files::CVS"), "Not a CVS object");
}

# Access some of the values to check what is found
sub test_root {
	my $self = shift;
	$self->assert($self->{'cvs'}->{rootpath} eq $self->{'config'}->{'dir'},
		   "rootpath failed $self->{cvs}->{rootpath} $self->{'config'}->{'dir'}");
}

# Test for failure when co is not found on path
# Bug [ 1111786 ] Failure to open file not detected

sub test_no_co_bug_1111786 {
	my $self =shift;
	
	$self->{'cvs'}->{'path'} = '';
	my $t;
	my $ret = eval($t = $self->{'cvs'}->getfilehandle('tests/CVSTest.pm','release'));
	$self->assert(!defined($ret) or !defined($t), 'Getfilehandle should die');
	
}

# set_up and tear_down are used to
# prepare and release resources need for testing

# Prepare a CVS object
 sub set_up {
	my $self = shift;
	my $dir = getcwd;
	$dir = File::Spec->updir($dir);
	
	$self->{'cvs'} = new LXR::Files("cvs:$dir");
 	$self->{'config'}->{'dir'} = "$dir/";
 	}

 sub tear_down {
	my $self = shift;
#	$self->{config} = undef;
 }




1;

Index: lxr.conf
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/lxr.conf,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- lxr.conf	4 Mar 2002 15:11:27 -0000	1.1
+++ lxr.conf	4 May 2005 23:21:09 -0000	1.2
@@ -22,7 +22,10 @@
   'tmpdir'		=> '/tmp',
 
   # Location of the Generic.pm config file
-  'genericconf' => '../lib/LXR/Lang/generic.conf'
+  'genericconf' => '../lib/LXR/Lang/generic.conf',
+  
+  # Paths for CVS module
+  'cvspath' => '/bin:/usr/local/bin:/usr/bin:/usr/sbin',
 
  },
 

Index: AllTests.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/AllTests.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- AllTests.pm	4 Mar 2002 15:11:27 -0000	1.1
+++ AllTests.pm	4 May 2005 23:21:09 -0000	1.2
@@ -14,6 +14,8 @@
 	my $class = shift;
 	my $suite = Test::Unit::TestSuite->empty_new("LXR Tests");
 	$suite->add_test(Test::Unit::TestSuite->new("ConfigTest"));
+	$suite->add_test(Test::Unit::TestSuite->new("SecurityTest"));
+	$suite->add_test(Test::Unit::TestSuite->new("CVSTest"));
 
 	return $suite;
 }

[Lxr-commits] CVS: lxr .htaccess,1.6,1.7

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20746/lxr

Modified Files:
	.htaccess 
Log Message:
Add test cases for Security and for some CVS bugs.

Enable taint mode for mod_perl - should reduce security vulnerabilities

Index: .htaccess
===================================================================
RCS file: /cvsroot/lxr/lxr/.htaccess,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- .htaccess	13 Jul 2004 13:39:44 -0000	1.6
+++ .htaccess	4 May 2005 23:21:09 -0000	1.7
@@ -14,6 +14,7 @@
 SetHandler perl-script
 PerlHandler Apache::Registry
 PerlSetEnv PERL5LIB lib
+PerlTaintCheck On
 ForceType text/html
 PerlSendHeader On
 </Files>

[Lxr-commits] CVS: lxr/tests SecurityTest.pm,NONE,1.1

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20331/lxr/tests

Added Files:
	SecurityTest.pm 
Log Message:
Fix for security vulnerability:  malicious values in 'version' can reveal files outside the
source tree.

Fixes bug [ 1194360 ] directory traversal

--- NEW FILE: SecurityTest.pm ---
# Test cases for the various security exploits.
# 
# Uses the associated lxr.conf file

package SecurityTest;
use strict;

use Test::Unit;
use lib "..";
use lib "../lib";

use LXR::Files;
use LXR::Config;
use LXR::Common qw(:html);
use Cwd;
use File::Spec;

use base qw(Test::Unit::TestCase);

use vars qw($root);

$config = new LXR::Config("http://test/lxr", "./lxr.conf");

sub new {
	my $self = shift()->SUPER::new(@_);
#	$self->{config} = {};
	return $self;
}

# define tests
sub test_fixpaths {
	my $self = shift;

	$ENV{'SERVER_NAME'} = 'test';
	$ENV{'SERVER_PORT'} = 80;
	$ENV{'SCRIPT_NAME'} = '/lxr/source';
	$ENV{'PATH_INFO'} = '/a/test/path';

	# Need to preserve signal handlers round call to httpinit as
	# it sets up the LXR signal handlers.
	
	my $die = $SIG{'__DIE__'};
	my $warn = $SIG{'__WARN__'};
	
	httpinit;
	my $node = "/../test/..//abit/./../././../........././";
	$node = LXR::Common::fixpaths($node);
	
	$SIG{'__DIE__'} = $die;
	$SIG{'__WARN__'} = $warn;
	
	$self->assert($node eq '/abit/./........././', "fixpaths is $node");	
}

sub test_version_path_exploit {
	# Check that the version string is properly scrubbed
	# Should only be able to set version to the values
	# defined in lxr.conf
	my $self = shift;

	$ENV{'SERVER_NAME'} = 'test';
	$ENV{'SERVER_PORT'} = 80;
	$ENV{'SCRIPT_NAME'} = '/lxr/source';
	$ENV{'PATH_INFO'} = '/a/test/path';
	$ENV{'QUERY_STRING'} = 'v=../../;virtroot=testpath;dbname=notapath';

	# Need to preserve signal handlers round call to httpinit as
	# it sets up the LXR signal handlers.
	
	my $die = $SIG{'__DIE__'};
	my $warn = $SIG{'__WARN__'};
	
	httpinit;
	
	$SIG{'__DIE__'} = $die;
	$SIG{'__WARN__'} = $warn;

	$self->assert($release eq '1.0.6', '$release not washed');
	$self->assert($config->variable('v') eq '1.0.6', '$config->variable(v) not washed');	
	
	$ENV{'QUERY_STRING'} = '?v=hi%20hippy/../..;file=/some/path;version=../..';
	$die = $SIG{'__DIE__'};
	$warn = $SIG{'__WARN__'};
	
	httpinit;
	
	$SIG{'__DIE__'} = $die;
	$SIG{'__WARN__'} = $warn;
	$self->assert($release eq '1.0.6', '$release not washed');
	$self->assert($config->variable('v') eq $release, '$release not washed');

	$ENV{'QUERY_STRING'} = '?version=hi../..';
	$die = $SIG{'__DIE__'};
	$warn = $SIG{'__WARN__'};
	
	httpinit;
	
	$SIG{'__DIE__'} = $die;
	$SIG{'__WARN__'} = $warn;
	$self->assert($release eq '1.0.6', "release not washed, was $release");
	$self->assert($config->variable('v') eq $release, "release not washed, was $release");

}

sub test_config {
	# Check that parameters in URL cannot alter config variables
	
	my $self = shift;

	$ENV{'SERVER_NAME'} = 'test';
	$ENV{'SERVER_PORT'} = 80;
	$ENV{'SCRIPT_NAME'} = '/lxr/source';
	$ENV{'PATH_INFO'} = '/a/test/path';
	$ENV{'QUERY_STRING'} = 'v=../../;virtroot=testpath;dbname=notapath';

	# Need to preserve signal handlers round call to httpinit as
	# it sets up the LXR signal handlers.
	
	my $die = $SIG{'__DIE__'};
	my $warn = $SIG{'__WARN__'};
	
	httpinit;
	
	$SIG{'__DIE__'} = $die;
	$SIG{'__WARN__'} = $warn;
	$self->assert($config->{'dbname'} ne 'notapath', 'dbname messed');
	$self->assert($config->{'virtroot'} eq '/lxr', 'virtroot set');
}	
1;

[Lxr-commits] CVS: lxr/lib/LXR Common.pm,1.50,1.51

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20222/lxr/lib/LXR

Modified Files:
	Common.pm 
Log Message:
Fix for security vulnerability:  malicious values in 'version' can reveal files outside the
source tree.

Fixes bug [ 1194360 ] directory traversal

Index: Common.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Common.pm,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -d -r1.50 -r1.51
--- Common.pm	26 Jul 2004 20:47:43 -0000	1.50
+++ Common.pm	4 May 2005 23:19:33 -0000	1.51
@@ -172,9 +172,6 @@
 	$t =~ s/\+/ /g;
 	$t =~ s/\%([\da-f][\da-f])/pack("C", hex($1))/gie;
 
-	# Paranoia check. Regexp-searches in Glimpse won't work.
-	# if ($t =~ tr/;<>*|\`&$!#()[]{}:\'\"//) {
-
 	return ($t);
 }
 
@@ -458,42 +455,22 @@
 	print("\n");
 }
 
-# init - Returns the array ($config, $HTTP, $Path)
-#
-# Path:
-# file	- Name of file without path
-# realf - The current file
-# real	- The directory portion of the current file
-# root	- The root of the sourcecode, same as sourceroot in $config
-# virtf - Name of file within the sourcedir
-# virt	- Directory portion of same
-# xref	- Links to the different portions of the patname
-#
+# httpinit - parses and cleans up the URL parameters and sets up the various variables
+#            Also prints the HTTP header & sets up the signal handlers
+#			This is also where we protect from malicious input
+#      
 # HTTP:
 # path_info -
 # param		- Array of parameters
 # this_url	- The current url
 #
-# config:
-# maplist -		A list of the different mappings
-#				that are applied to the filename
-# sourcedirhead - Corresponds to the configig options
-# sourcehead -
-# htmldir -
-# sourceroot -
-# htmlhead -
-# incprefix -
-# virtroot -
-# glimpsebin -
-# srcrootname -
-# baseurl -
-# htmltail -
 sub httpinit {
 	$SIG{__WARN__} = \&warning;
 	$SIG{__DIE__}  = \&fatal;
 
 	$HTTP->{'path_info'} = http_wash($ENV{'PATH_INFO'});
 
+	$HTTP->{'path_info'} = clean_path($HTTP->{'path_info'});
 	$HTTP->{'this_url'} = 'http://' . $ENV{'SERVER_NAME'};
 	$HTTP->{'this_url'} .= ':' . $ENV{'SERVER_PORT'}
 	  if $ENV{'SERVER_PORT'} != 80;
@@ -501,13 +478,20 @@
 	$HTTP->{'this_url'} .= '?' . $ENV{'QUERY_STRING'}
 	  if $ENV{'QUERY_STRING'};
 
+	# 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 };
 
+	# But do clean up these
 	$HTTP->{'param'}->{'v'} ||= $HTTP->{'param'}->{'version'};
 	$HTTP->{'param'}->{'a'} ||= $HTTP->{'param'}->{'arch'};
 	$HTTP->{'param'}->{'i'} ||= $HTTP->{'param'}->{'identifier'};
 
-	$identifier = $HTTP->{'param'}->{'i'};
+	$identifier = clean_identifier($HTTP->{'param'}->{'i'});
+	# remove the param versions to prevent unclean versions being used
+	delete $HTTP->{'param'}->{'i'};
+	delete $HTTP->{'param'}->{'identifier'};
+	
 	$config     = new LXR::Config($HTTP->{'this_url'});
 	die "Can't find config for " . $HTTP->{'this_url'} if !defined($config);
 	$files = new LXR::Files($config->sourceroot);
@@ -517,14 +501,54 @@
 
 	foreach ($config->allvariables) {
 		$config->variable($_, $HTTP->{'param'}->{$_}) if $HTTP->{'param'}->{$_};
+		delete $HTTP->{'param'}->{$_};
 	}
 
-	$release  = $config->variable('v');
+	$release  = clean_release($config->variable('v'));
+	$config->variable('v', $release);  # put back into config obj
+	
+	$HTTP->{'param'}->{'file'} = clean_path($HTTP->{'param'}->{'file'});
 	$pathname = fixpaths($HTTP->{'path_info'} || $HTTP->{'param'}->{'file'});
 
 	printhttp;
 }
 
+sub clean_release {
+	my $release = shift;
+	my @rels= $config->varrange('v');
+	my %test;
+	@test{@rels} = undef;
+	
+	if(!exists $test{$release}) {
+		$release = $config->vardefault('v');
+	}
+	return $release;
+}
+
+sub clean_identifier {
+	my $id = shift;
+
+	$id =~ s/(^[\w`:.,]+).*/$1/ if defined $id;
+
+	return $id;
+}
+
+sub clean_path {
+	# Cleans up a string to path
+	my $path = shift;
+	
+	if(defined $path) {
+		# First suppress anything after a dodgy character
+		$path =~ s!(^[\w_+-,.%^/]+).*!$1!;
+		# Clean out /../
+		while ($path =~ m!/../!) {
+			$path = s!/\.\./!/!g;
+		}
+	}
+	
+	return $path;
+}
+	
 sub httpclean {
 	$config = undef;
 	$files  = undef;

[Lxr-commits] CVS: lxr/templates lxr.conf,1.24,1.25

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/templates
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8439/lxr/templates

Modified Files:
	lxr.conf 
Log Message:
tcl is not supported in generic.conf yet - so comment out.
Fixes bug [ 1042310 ] No langid for language tcl

Index: lxr.conf
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/lxr.conf,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- lxr.conf	10 Aug 2004 16:14:25 -0000	1.24
+++ lxr.conf	30 Apr 2005 21:30:07 -0000	1.25
@@ -25,6 +25,9 @@
 
 		# Location of the ectags.conf file
 		'ectagsconf' => '/path/to/lib/LXR/Lang/ectags.conf',
+ 		
+ 		# Paths for CVS module
+  		'cvspath' => '/bin:/usr/local/bin:/usr/bin:/usr/sbin',
 
 	},
 
@@ -189,7 +192,7 @@
 			# 's-Lang' => [ 's-Lang', '(?i)\.sl$',                'LXR::Lang::Generic' ],
 			'SQL' => [ 'SQL', '(?i)\.sql$|\.pks$|\.pkb$',               'LXR::Lang::Generic' ],
 			'VB'  => [ 'VB',  '(?i)\.bas$|\.cls$|\.ctl$|\.frm$|\.vbs$', 'LXR::Lang::Generic' ],
-			'tcl' => [ 'tcl', '(?i)\.tcl$|\.wish$',                     'LXR::Lang::Generic' ],
+			#'tcl' => [ 'tcl', '(?i)\.tcl$|\.wish$',                     'LXR::Lang::Generic' ],
 		},
 
 		# Maps interpreter names to languages.  The format is:

[Lxr-commits] CVS: lxr/lib/LXR/Index Postgres.pm,1.19,1.20

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Index
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24751/lxr/lib/LXR/Index

Modified Files:
	Postgres.pm 
Log Message:
Fix missing ${prefix} tags.

Index: Postgres.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Index/Postgres.pm,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- Postgres.pm	18 Oct 2004 20:45:37 -0000	1.19
+++ Postgres.pm	30 Apr 2005 01:35:54 -0000	1.20
@@ -57,12 +57,12 @@
 
 	$files_select =
 	  $dbh->prepare("select fileid from ${prefix}files where filename = ? and revision = ?");
-	$filenum_nextval = $dbh->prepare("select nextval('filenum')");
+	$filenum_nextval = $dbh->prepare("select nextval('${prefix}filenum')");
 	$files_insert    = $dbh->prepare("insert into ${prefix}files values (?, ?, ?)");
 
 	$symbols_byname = $dbh->prepare("select symid from ${prefix}symbols where symname = ?");
 	$symbols_byid   = $dbh->prepare("select symname from ${prefix}symbols where symid = ?");
-	$symnum_nextval = $dbh->prepare("select nextval('symnum')");
+	$symnum_nextval = $dbh->prepare("select nextval('${prefix}symnum')");
 	$symbols_insert = $dbh->prepare("insert into ${prefix}symbols values (?, ?)");
 	$symbols_remove = $dbh->prepare("delete from ${prefix}symbols where symname = ?");
 
@@ -99,7 +99,7 @@
 		  . "and f.fileid = r.fileid and "
 		  . "s.symname = ? and r.release = ?");
 
-	$declid_nextnum = $dbh->prepare("select nextval('declnum')");
+	$declid_nextnum = $dbh->prepare("select nextval('${prefix}declnum')");
 
 	$decl_select =
 	  $dbh->prepare(

[Lxr-commits] CVS: lxr/tests AllTests.pm,1.1.4.2,1.1.4.3

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv875

Modified Files:
      Tag: bk-dev-branch
	AllTests.pm 
Log Message:



Index: AllTests.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/AllTests.pm,v
retrieving revision 1.1.4.2
retrieving revision 1.1.4.3
diff -u -d -r1.1.4.2 -r1.1.4.3
--- AllTests.pm	13 Feb 2005 19:35:04 -0000	1.1.4.2
+++ AllTests.pm	29 Apr 2005 20:59:15 -0000	1.1.4.3
@@ -14,9 +14,8 @@
 	my $class = shift;
 	my $suite = Test::Unit::TestSuite->empty_new("LXR Tests");
 	$suite->add_test(Test::Unit::TestSuite->new("ConfigTest"));
-	$suite->add_test(Test::Unit::TestSuite->new("BKTest"));
 	$suite->add_test(Test::Unit::TestSuite->new("PlainTest"));
-
+	$suite->add_test(Test::Unit::TestSuite->new("BKTest"));
 	return $suite;
 }
 

[Lxr-commits] CVS: lxr/tests PlainTest.pm,NONE,1.1.2.1

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1842

Added Files:
      Tag: bk-dev-branch
	PlainTest.pm 
Log Message:
tests for the Plain.pm module


--- NEW FILE: PlainTest.pm ---
# Test cases for the LXR::Files::Plain module
# Uses the associated lxr.conf file

package PlainTest;
use strict;

use Test::Unit;
use lib "..";
use lib "../lib";

use LXR::Files;
use LXR::Config;
use LXR::Common;

use base qw(Test::Unit::TestCase);

use vars qw($root);

$root = "/Users/malcolmbox/dev/lxr-src/";

$config = new LXR::Config("http://test/lxr", "./lxr.conf");

sub new {
	my $self = shift()->SUPER::new(@_);
#	$self->{config} = {};
	return $self;
}

# define tests

# test that a files object can be created
sub test_creation {
	my $self = shift;
	$self->assert(defined($self->{'plain'}), "Failed to create Files::Plain");
	$self->assert($self->{'plain'}->isa("LXR::Files::Plain"), "Not a Plain object");
}

# Access some of the values to check what is found
sub test_root {
	my $self = shift;
	$self->assert($self->{'plain'}->{rootpath} eq $self->{'config'}->{'dir'},
		   "rootpath failed $self->{plain}->{rootpath} $self->{'config'}->{'dir'}");
}

# Test the get_dir function.  Depends on the ctags 5.5.4 release being in place

sub test_getdir {
	my $self = shift;
	my $f = $self->{'plain'};
	
	my @files = sort($f->getdir("/",'5.5.4'));  # use different releases to disambiguate
	my @files2 = sort($f->getdir("", '5.5.4')); # should now produce same result
	$self->assert_deep_equals(\@files, \@files2);
	
	# Check for invalid behaviours
	@files = $f->getdir("/COPYING", '5.5.4');
	$self->assert($#files == -1);
	@files = $f->getdir("tests", '5.5.4');
	$self->assert($#files == -1);
	@files = $f->getdir("notthere/", '5.5.4');
	$self->assert($#files == -1);
}

# Test the get_file method.

sub test_getfile {
	my $self = shift;
	my $f = $self->{'plain'};
	
	my $file = $f->getfile("/COPYING", '5.5.4');
	local ($/) = undef;
	open FILE, "<". "$root/5.5.4/COPYING" || die "Can't open file";
	my $ref = <FILE>;
	$self->assert($file eq $ref, "Files not matching");
}

# set_up and tear_down are used to
# prepare and release resources need for testing

# Prepare a config object
 sub set_up {
	my $self = shift;
	$self->{'plain'} = new LXR::Files("$root");
 	$self->{'config'}->{'dir'} = "$root";
 	}

 sub tear_down {
	my $self = shift;
#	$self->{config} = undef;
 }




1;

[Lxr-commits] CVS: lxr/tests/bk-test-repository/SCCS s.file1,1.1.2.2,1.1.2.3 s.ChangeSet,1.1.2.2,1.1.2.3

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests/bk-test-repository/SCCS
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20271/tests/bk-test-repository/SCCS

Modified Files:
      Tag: bk-dev-branch
	s.file1 s.ChangeSet 
Log Message:
Fix Files initialisation in genxref
Fix diff
Update tests and bk repository

Index: s.file1
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/bk-test-repository/SCCS/Attic/s.file1,v
retrieving revision 1.1.2.2
retrieving revision 1.1.2.3
diff -u -d -r1.1.2.2 -r1.1.2.3
--- s.file1	13 Feb 2005 23:07:07 -0000	1.1.2.2
+++ s.file1	22 Feb 2005 23:12:04 -0000	1.1.2.3
@@ -1,4 +1,10 @@
-
H48546
+
H56354
+
s 00002/00000/00009
+
d D 1.3 05/02/19 21:45:29 malcolm 4 3
+
c A comment here
+
cC
+
cK14870
+
e
 
s 00005/00000/00004
 
d D 1.2 05/02/13 22:41:55 malcolm 3 2
 
cC
@@ -29,5 +35,4 @@
 
f x 0x921
 
t
 
T
-x^EŒK
-Ã0ñV§x'ؽ@»è"ëž@‰•Ú`dpTrýÊ«€OŸ™°"‘•zÂˊ`ÛvbÍ`í>´ªB½à*l`\]³Œã×<–‰ÂŠq9̉i©Z­rƒ¢ÕÖ {aýÊ)FôšˆÿÝ;<ã…·½¥©Ž3Eú€Ô2
\ No newline at end of file
+x^EN;ƒ0«OñN€Ú´CæžÀ@,G#®_‡¥’õdû}ìnÄ@–倗å„iš‰5‚µú¸£ˆ&ªWfãªÓ¾œÅ»½D¢nă8Æݳ˜;ZŠ¨˜p=ÑפhŜY×t$#z7‹ëþ;¼B†ø¼i¿6×mKj¨Šãœ61]ÑÞ¥îã2‡GƒÛZèÓk?;
\ No newline at end of file

Index: s.ChangeSet
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/bk-test-repository/SCCS/Attic/s.ChangeSet,v
retrieving revision 1.1.2.2
retrieving revision 1.1.2.3
diff -u -d -r1.1.2.2 -r1.1.2.3
--- s.ChangeSet	13 Feb 2005 23:07:07 -0000	1.1.2.2
+++ s.ChangeSet	22 Feb 2005 23:12:04 -0000	1.1.2.3
@@ -1,4 +1,11 @@
-
H38752
+
H53661
+
s 00001/00000/00001
+
d D 1.13 05/02/19 21:46:16 malcolm 14 13
+
c file1:
+
c   A comment here
+
cC
+
cK44279
+
e
 
s 00001/00000/00001
 
d D 1.12 05/02/13 22:42:04 malcolm 13 12
 
c 
@@ -101,6 +108,9 @@
 
f x 0x1161
 
t
 
T
+
I 14
+malcolm@serenity|file1|20050213142029|09970|bd06fd0928163df malcolm@serenity|file1|20050219214529|14870
+
E 14
 
I 13
 malcolm@serenity|file1|20050213142029|09970|bd06fd0928163df malcolm@serenity|file1|20050213224155|11818
 
E 13

[Lxr-commits] CVS: lxr/tests/bk-test-repository/BitKeeper/etc/SCCS x.cmark,1.1.2.2,1.1.2.3

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests/bk-test-repository/BitKeeper/etc/SCCS
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20271/tests/bk-test-repository/BitKeeper/etc/SCCS

Modified Files:
      Tag: bk-dev-branch
	x.cmark 
Log Message:
Fix Files initialisation in genxref
Fix diff
Update tests and bk repository

Index: x.cmark
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/bk-test-repository/BitKeeper/etc/SCCS/Attic/x.cmark,v
retrieving revision 1.1.2.2
retrieving revision 1.1.2.3
diff -u -d -r1.1.2.2 -r1.1.2.3
--- x.cmark	13 Feb 2005 23:07:06 -0000	1.1.2.2
+++ x.cmark	22 Feb 2005 23:12:02 -0000	1.1.2.3
@@ -1 +1 @@
-malcolm@serenity|ChangeSet|20050213224204|44268
+malcolm@serenity|ChangeSet|20050219214616|44279

[Lxr-commits] CVS: lxr/tests BKTest.pm,1.1.2.10,1.1.2.11

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20271/tests

Modified Files:
      Tag: bk-dev-branch
	BKTest.pm 
Log Message:
Fix Files initialisation in genxref
Fix diff
Update tests and bk repository

Index: BKTest.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/Attic/BKTest.pm,v
retrieving revision 1.1.2.10
retrieving revision 1.1.2.11
diff -u -d -r1.1.2.10 -r1.1.2.11
--- BKTest.pm	20 Feb 2005 23:44:55 -0000	1.1.2.10
+++ BKTest.pm	22 Feb 2005 23:12:02 -0000	1.1.2.11
@@ -180,6 +180,17 @@
 	$self->assert_deep_equals(\@entries, [ sort ('file2') ]);
 }
 
+# test getdir() ordering - dirs before files, all alphabetical
+sub test_getdir_part3 {
+	my $self = shift;
+	my $bk   = $self->{'bk'};
+
+	my @nodes = $bk->getdir('/', '@1.13');
+	$self->assert($nodes[0] =~ m!/$!);
+	my @expected = ('firstdir/', 'seconddir/', 'sourcedir/', 'file1');
+	$self->assert_deep_equals(\@nodes, \@expected);
+}
+
 # Test the cache of bitkeeper trees
 
 sub test_cache_creation {

[Lxr-commits] CVS: lxr diff,1.15,1.15.2.1 genxref,1.36,1.36.2.1

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20271

Modified Files:
      Tag: bk-dev-branch
	diff genxref 
Log Message:
Fix Files initialisation in genxref
Fix diff
Update tests and bk repository

Index: diff
===================================================================
RCS file: /cvsroot/lxr/lxr/diff,v
retrieving revision 1.15
retrieving revision 1.15.2.1
diff -u -d -r1.15 -r1.15.2.1
--- diff	26 Oct 2004 17:08:07 -0000	1.15
+++ diff	22 Feb 2005 23:12:06 -0000	1.15.2.1
@@ -31,6 +31,7 @@
 
 use LXR::Common qw(:html);
 use Local;
+use FileHandle;
 
 sub htmlsub {
 	my ($s, $l) = @_;

Index: genxref
===================================================================
RCS file: /cvsroot/lxr/lxr/genxref,v
retrieving revision 1.36
retrieving revision 1.36.2.1
diff -u -d -r1.36 -r1.36.2.1
--- genxref	21 Jul 2004 20:44:30 -0000	1.36
+++ genxref	22 Feb 2005 23:12:08 -0000	1.36.2.1
@@ -51,6 +51,7 @@
   --version=VERSION  Generate tokens for the given version of the code.
   --allversions      Generate tokens for all versions of the code (default).
   --reindexall       Purges existing index data
+  
 Report bugs at http://sourceforge.net/projects/lxr/.
 END_HELP
 	exit 0;
@@ -67,7 +68,7 @@
 
 die("No matching configuration") unless $config->sourceroot;
 
-$files = new LXR::Files($config->sourceroot);
+$files = new LXR::Files($config->sourceroot, $config->sourceparams);
 die "Can't create file access object " . $config->sourceroot
   if !defined($files);
 $index = new LXR::Index($config->dbname, O_RDWR | O_CREAT);

[Lxr-commits] CVS: lxr/lib/LXR/Files BK.pm,1.1.2.11,1.1.2.12

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Files
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv600/lib/LXR/Files

Modified Files:
      Tag: bk-dev-branch
	BK.pm 
Log Message:
Sort the files & directories returned from getdir()

Index: BK.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Files/Attic/BK.pm,v
retrieving revision 1.1.2.11
retrieving revision 1.1.2.12
diff -u -d -r1.1.2.11 -r1.1.2.12
--- BK.pm	20 Feb 2005 23:44:55 -0000	1.1.2.11
+++ BK.pm	21 Feb 2005 08:25:08 -0000	1.1.2.12
@@ -55,7 +55,10 @@
 	$self->fill_cache($release);
 	$pathname = canonise($pathname);
 	$pathname = File::Spec->rootdir() if $pathname eq '';
-	return keys %{ $tree_cache{$release}->{$pathname} };
+	my @nodes = keys %{ $tree_cache{$release}->{$pathname} };
+	my @dirs = grep m!/$!, @nodes;
+	my @files = grep !m!/$!, @nodes;
+	return (sort(@dirs), sort(@files));
 }
 
 sub getfile {

[Lxr-commits] CVS: lxr/lib/LXR Common.pm,1.50.2.1,1.50.2.2

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17503/lib/LXR

Modified Files:
      Tag: bk-dev-branch
	Common.pm 
Log Message:
Tests for new 'sourceparams' config directive, and fix for typo in usage

Index: Common.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Common.pm,v
retrieving revision 1.50.2.1
retrieving revision 1.50.2.2
diff -u -d -r1.50.2.1 -r1.50.2.2
--- Common.pm	20 Feb 2005 23:44:54 -0000	1.50.2.1
+++ Common.pm	21 Feb 2005 00:07:00 -0000	1.50.2.2
@@ -510,7 +510,7 @@
 	$identifier = $HTTP->{'param'}->{'i'};
 	$config     = new LXR::Config($HTTP->{'this_url'});
 	die "Can't find config for " . $HTTP->{'this_url'} if !defined($config);
-	$files = new LXR::Files($config->sourceroot, $config->sourceparam);
+	$files = new LXR::Files($config->sourceroot, $config->sourceparams);
 	die "Can't create Files for " . $config->sourceroot if !defined($files);
 	$index = new LXR::Index($config->dbname);
 	die "Can't create Index for " . $config->dbname if !defined($index);

[Lxr-commits] CVS: lxr/tests lxr.conf,1.1.4.1,1.1.4.2 ConfigTest.pm,1.2.2.1,1.2.2.2

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17503/tests

Modified Files:
      Tag: bk-dev-branch
	lxr.conf ConfigTest.pm 
Log Message:
Tests for new 'sourceparams' config directive, and fix for typo in usage

Index: lxr.conf
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/lxr.conf,v
retrieving revision 1.1.4.1
retrieving revision 1.1.4.2
diff -u -d -r1.1.4.1 -r1.1.4.2
--- lxr.conf	13 Feb 2005 19:35:04 -0000	1.1.4.1
+++ lxr.conf	21 Feb 2005 00:07:00 -0000	1.1.4.2
@@ -92,7 +92,7 @@
   # The name to display for this source tree
   'sourcerootname'	=> 'Example',
 
-
+  'sourceparams' => {'cachepath' => '/a/path/to/cache', 'param2' => 'secondparam'},
   # The DBI identifier for the database to use
   # For mysql, the format is dbi:mysql:dbname=<name>
   # for Postgres, it is dbi:Pg:dbname=<name>

Index: ConfigTest.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/ConfigTest.pm,v
retrieving revision 1.2.2.1
retrieving revision 1.2.2.2
diff -u -d -r1.2.2.1 -r1.2.2.2
--- ConfigTest.pm	4 Dec 2004 23:31:15 -0000	1.2.2.1
+++ ConfigTest.pm	21 Feb 2005 00:07:00 -0000	1.2.2.2
@@ -52,6 +52,17 @@
 	$self->assert($#vars == 1, "Too many variables returned got @vars");
 }
 
+# Test access to the sourceparams section
+
+sub test_sourceparams {
+	my $self = shift;
+	my $config = $self->{'config'};
+	
+	my $params = $config->sourceparams;
+	$self->assert_equals($$params{'cachepath'}, '/a/path/to/cache');
+	$self->assert_equals($$params{'param2'}, 'secondparam');
+}
+
 # Test multiple config block with common substrings work
 # Bug 525825
 sub test_multi_config {

[Lxr-commits] CVS: lxr/lib/LXR/Files BK.pm,1.1.2.10,1.1.2.11

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Files
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11983/lib/LXR/Files

Modified Files:
      Tag: bk-dev-branch
	BK.pm 
Log Message:
Add a disk-based cache for the results of the 'bk rset' command.
This prevents this from taking too long on subsequent invocations - 
bk rset being a slow operation.

As a disk-based cache this can get out of sync with the repository, 
there is currently no code to detect this.  The idea is that this would be
manually deleted before running genxref, which would have the side
effect of creating an up-to-date cache.

Index: BK.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Files/Attic/BK.pm,v
retrieving revision 1.1.2.10
retrieving revision 1.1.2.11
diff -u -d -r1.1.2.10 -r1.1.2.11
--- BK.pm	20 Feb 2005 21:42:25 -0000	1.1.2.10
+++ BK.pm	20 Feb 2005 23:44:55 -0000	1.1.2.11
@@ -28,17 +28,20 @@
 use Time::Local;
 use LXR::Common;
 
-use vars qw(%tree_cache @ISA);
+use vars qw(%tree_cache @ISA $memcachecount $diskcachecount);
 
 @ISA = ("LXR::Files");
+$memcachecount = 0;
+$diskcachecount = 0;
 
 sub new {
-	my ($self, $rootpath) = @_;
+	my ($self, $rootpath, $params) = @_;
 
 	$self = bless({}, $self);
 	$self->{'rootpath'} = $rootpath;
 	$self->{'rootpath'} =~ s!/*$!!;
-
+	die "Must specify a cache directory when using BitKeeper" if !(ref($params) eq 'HASH');
+	$self->{'cache'} = $$params{'cachepath'};
 	return $self;
 }
 
@@ -202,6 +205,7 @@
 
 	# Not in cache, so need to build
 	my @all_entries = $self->get_tree($release);
+	$memcachecount++;
 
 	my %newtree = ();
 	my ($entry, $path, $file, $vol, @dirs);
@@ -231,12 +235,32 @@
 
 sub get_tree {
 	my ($self, $release) = @_;
-
-	# This command provide 3 part output - the current filename, the historical filename & the revision
-	my $fileh = $self->openbkcommand("bk rset -h -l$release 2>/dev/null |");
-	my $line_to_junk = <$fileh>;    # Remove the Changelist|Changelist line at start
-	my @files        = <$fileh>;
-	close X;
+	
+	# Return entire tree as provided by 'bk rset'
+	# First, check if cache exists
+	
+	my $fileh = new IO::File;
+	
+	if (-r $self->cachename($release)) {
+		$fileh->open($self->cachename($release)) or die "Whoops, can't open cached version";
+	} else {
+		# This command provide 3 part output - the current filename, the historical filename & the revision
+		$fileh = $self->openbkcommand("bk rset -h -l$release 2>/dev/null |");
+		my $line_to_junk = <$fileh>;    # Remove the Changelist|Changelist line at start
+		# Now create the cached copy if we can
+		if(open(CACHE, ">", $self->cachename($release))) {
+			$diskcachecount++;
+			my @data = <$fileh>;
+			close $fileh;
+			print CACHE @data;
+			close CACHE;
+			$fileh = new IO::File;
+			$fileh->open($self->cachename($release)) or die "Couldn't open cached version!";
+		}
+	}
+		
+	my @files = <$fileh>;
+	close $fileh;
 	chomp @files;
 
 	# remove any BitKeeper metadata except for deleted files
@@ -245,6 +269,11 @@
 	return @files;
 }
 
+sub cachename {
+	my ($self, $release) = @_;
+	return $self->{'cache'}."/treecache-".$release;
+}
+ 
 sub canonise {
 	my $path = shift;
 	$path =~ s!^/!!;
@@ -270,3 +299,4 @@
 	return $tree_cache{$release}{$path}{$file};
 }
 
+1;
\ No newline at end of file

[Lxr-commits] CVS: lxr/tests BKTest.pm,1.1.2.9,1.1.2.10

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11983/tests

Modified Files:
      Tag: bk-dev-branch
	BKTest.pm 
Log Message:
Add a disk-based cache for the results of the 'bk rset' command.
This prevents this from taking too long on subsequent invocations - 
bk rset being a slow operation.

As a disk-based cache this can get out of sync with the repository, 
there is currently no code to detect this.  The idea is that this would be
manually deleted before running genxref, which would have the side
effect of creating an up-to-date cache.

Index: BKTest.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/tests/Attic/BKTest.pm,v
retrieving revision 1.1.2.9
retrieving revision 1.1.2.10
diff -u -d -r1.1.2.9 -r1.1.2.10
--- BKTest.pm	19 Feb 2005 22:22:44 -0000	1.1.2.9
+++ BKTest.pm	20 Feb 2005 23:44:55 -0000	1.1.2.10
@@ -14,10 +14,11 @@
 
 use base qw(Test::Unit::TestCase);
 
-use vars qw($bkpath $bkrefdir);
+use vars qw($bkpath $bkrefdir $bkcache	);
 
 $bkpath   = getcwd() . "/bk-test-repository";
 $bkrefdir = getcwd() . "/bk-reference-files/";
+$bkcache  = getcwd() . "/bk-cache-dir";
 
 sub new {
 	my $self = shift()->SUPER::new(@_);
@@ -33,6 +34,7 @@
 	my $self = shift;
 	$self->assert(defined($self->{'bk'}), "Failed to create Files::BK");
 	$self->assert($self->{'bk'}->isa("LXR::Files::BK"), "Not a BK object");
+	$self->assert($self->{'bk'}->{'cache'} eq $bkcache);
 }
 
 # Access some of the values to check what is found
@@ -56,7 +58,7 @@
 sub new {
 	my ($proto, $rootpath) = @_;
 	my $class = ref($proto) || $proto;
-	my $self  = $class->SUPER::new($rootpath);
+	my $self  = $class->SUPER::new($rootpath, {'cachepath' => ''});
 
 	bless($self, $class);
 	return $self;
@@ -178,6 +180,59 @@
 	$self->assert_deep_equals(\@entries, [ sort ('file2') ]);
 }
 
+# Test the cache of bitkeeper trees
+
+sub test_cache_creation {
+	my $self = shift;
+	my $bk   = $self->{'bk'};
+
+	# First nuke the cache directory & the memory cache
+	$self->clear_disk_cache();
+	
+	# Now ask for a specific tree
+	$bk->getdir('/', '@1.10');
+	$self->assert(-r $bk->cachename('@1.10'));
+	$bk->getdir('/sourcedir', '@1.3');
+	$self->assert(-r $bk->cachename('@1.3'));
+	
+	$self->clear_disk_cache();
+}	
+
+# Test the disk cache usage
+
+sub test_cache_usage {
+	my $self = shift;
+	my $bk = $self->{'bk'};
+	
+	# Test strategy is to clear the cache, create a cache file for a version
+	# that is known not to exist, then check that the info from that cached
+	# version is returned.
+	# First nuke the cache directory & the memory cache
+	$self->clear_disk_cache();
+
+	# Create the new information
+	open(X, ">", $bk->cachename('testversion')) or die "Can't create test cache entry";
+	print X "foobar|foobar|1.1\n";
+	print X "another|another|1.2\n";
+	print X "somewhere/other|somewhere/new|1.3\n";
+	close X;
+	
+	my @entries = sort $bk->getdir('/', 'testversion');
+	$self->assert_deep_equals(\@entries, [sort ("foobar", "another", "somewhere/")]);
+	
+	$self->clear_disk_cache();
+}
+
+sub clear_disk_cache {
+	my $self = shift;
+	
+	system('rm -rf '.$bkcache);
+	$self->assert(!-d $bkcache);	
+	system('mkdir '.$bkcache);
+	$self->assert(-d $bkcache);
+	%LXR::Files::BK::tree_cache = ('' => '');
+}
+
 # Tests for the cache manipulation commands
 sub test_fileexists {
 	my $self = shift;
@@ -348,7 +403,7 @@
 	my ($self) = shift;
 	my $bk = $self->{'bk'};
 	
-	$self->assert_equals($bk->getfiletime('/file1', '@1.3'), timegm(30,20,14,13,02,2005));
+	$self->assert_equals($bk->getfiletime('/file1', '@1.3'), timegm(30,20,14,13,01,2005)); # Note months is 0..11
 	$self->assert_equals($bk->getfiletime('/file1', '@1.3'), $bk->getfiletime('file1', '@1.11'));
 	$self->assert(!defined($bk->getfiletime('/sourcedir/', '@1.12')));
 }
@@ -400,7 +455,7 @@
 # Prepare a config object
 sub set_up {
 	my $self = shift;
-	$self->{'bk'} = new LXR::Files("bk:$bkpath");
+	$self->{'bk'} = new LXR::Files("bk:$bkpath", {'cachepath' => $bkcache});
 	$self->{'config'}->{'dir'} = "$bkpath";
 }
 

[Lxr-commits] CVS: lxr/lib/LXR Files.pm,1.8.2.4,1.8.2.5 Common.pm,1.50,1.50.2.1

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11983/lib/LXR

Modified Files:
      Tag: bk-dev-branch
	Files.pm Common.pm 
Log Message:
Add a disk-based cache for the results of the 'bk rset' command.
This prevents this from taking too long on subsequent invocations - 
bk rset being a slow operation.

As a disk-based cache this can get out of sync with the repository, 
there is currently no code to detect this.  The idea is that this would be
manually deleted before running genxref, which would have the side
effect of creating an up-to-date cache.

Index: Files.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Files.pm,v
retrieving revision 1.8.2.4
retrieving revision 1.8.2.5
diff -u -d -r1.8.2.4 -r1.8.2.5
--- Files.pm	14 Feb 2005 00:50:25 -0000	1.8.2.4
+++ Files.pm	20 Feb 2005 23:44:54 -0000	1.8.2.5
@@ -23,7 +23,7 @@
 use strict;
 
 sub new {
-	my ( $self, $srcroot ) = @_;
+	my ( $self, $srcroot, $params ) = @_;
 	my $files;
 
 	if ( $srcroot =~ /^CVS:(.*)/i ) {
@@ -34,7 +34,7 @@
 	elsif ( $srcroot =~ /^bk:(.*)/i ) {
 		require LXR::Files::BK;
 		$srcroot = $1;
-		$files   = new LXR::Files::BK($srcroot);
+		$files   = new LXR::Files::BK($srcroot, $params);
 	}
 	else {
 		require LXR::Files::Plain;

Index: Common.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Common.pm,v
retrieving revision 1.50
retrieving revision 1.50.2.1
diff -u -d -r1.50 -r1.50.2.1
--- Common.pm	26 Jul 2004 20:47:43 -0000	1.50
+++ Common.pm	20 Feb 2005 23:44:54 -0000	1.50.2.1
@@ -510,7 +510,7 @@
 	$identifier = $HTTP->{'param'}->{'i'};
 	$config     = new LXR::Config($HTTP->{'this_url'});
 	die "Can't find config for " . $HTTP->{'this_url'} if !defined($config);
-	$files = new LXR::Files($config->sourceroot);
+	$files = new LXR::Files($config->sourceroot, $config->sourceparam);
 	die "Can't create Files for " . $config->sourceroot if !defined($files);
 	$index = new LXR::Index($config->dbname);
 	die "Can't create Index for " . $config->dbname if !defined($index);

[Lxr-commits] CVS: lxr/templates lxr.conf,1.24,1.24.2.1

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/templates
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11983/templates

Modified Files:
      Tag: bk-dev-branch
	lxr.conf 
Log Message:
Add a disk-based cache for the results of the 'bk rset' command.
This prevents this from taking too long on subsequent invocations - 
bk rset being a slow operation.

As a disk-based cache this can get out of sync with the repository, 
there is currently no code to detect this.  The idea is that this would be
manually deleted before running genxref, which would have the side
effect of creating an up-to-date cache.

Index: lxr.conf
===================================================================
RCS file: /cvsroot/lxr/lxr/templates/lxr.conf,v
retrieving revision 1.24
retrieving revision 1.24.2.1
diff -u -d -r1.24 -r1.24.2.1
--- lxr.conf	10 Aug 2004 16:14:25 -0000	1.24
+++ lxr.conf	20 Feb 2005 23:44:55 -0000	1.24.2.1
@@ -105,8 +105,17 @@
 		# server access does NOT work.
 		#     'sourceroot'	=> 'cvs:/hom/karsk/a/CVSROOT/linux',
 
+		# For a BitKeeper repository, specify bk: followed by the path to the 
+		# repository.  For BK it is also necessary to specify a 'cachepath' parameter in
+		# the 'sourceparams' value below.  This should point to a directory where the 
+		# code can write and read files.
+		#     'sourceroot' => 'bk:/some/repository/here',
+		
 		# The name to display for this source tree
 		'sourcerootname' => 'Example',
+		
+		# Any parameters to the source access method should be specified below
+		'sourceparams' => {'cachepath' => '/a/path/here'},
 
 		# The DBI identifier for the database to use
 		# For mysql, the format is dbi:mysql:dbname=<name>

[Lxr-commits] CVS: lxr/lib/LXR/Files BK.pm,1.1.2.9,1.1.2.10

[Malcolm B. <mb...@us...>]

Update of /cvsroot/lxr/lxr/lib/LXR/Files
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14969/lib/LXR/Files

Modified Files:
      Tag: bk-dev-branch
	BK.pm 
Log Message:
Fix off-by-one error in months

Index: BK.pm
===================================================================
RCS file: /cvsroot/lxr/lxr/lib/LXR/Files/Attic/BK.pm,v
retrieving revision 1.1.2.9
retrieving revision 1.1.2.10
diff -u -d -r1.1.2.9 -r1.1.2.10
--- BK.pm	19 Feb 2005 22:22:09 -0000	1.1.2.9
+++ BK.pm	20 Feb 2005 21:42:25 -0000	1.1.2.10
@@ -99,7 +99,7 @@
 		chomp $time;
 		my ($yr, $mth, $day, $hr, $min, $sec) =
 		  $time =~ m/(....)(..)(..)(..)(..)(..)/;
-		$info->{'filetime'} = timegm($sec, $min, $hr, $day, $mth, $yr);
+		$info->{'filetime'} = timegm($sec, $min, $hr, $day, $mth-1, $yr);
 	}
 
 	return $info->{'filetime'};