[Lxr-commits] CVS: lxr-tools/tests AllTests.pm, NONE, 1.1 BKTest.pm, NONE, 1.1 CVSTest.pm, NONE, 1.

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/lxr/lxr-tools/tests
In directory ddv4jf1.ch3.sourceforge.com:/tmp/cvs-serv4979/tests

Added Files:
	AllTests.pm BKTest.pm CVSTest.pm ConfigTest.pm PlainTest.pm 
	README SecurityTest.pm TestRunner.pl lxr.conf test-versions 
Log Message:
Add tests from lxr module here

--- NEW FILE: AllTests.pm ---
package AllTests;

use ConfigTest;

use Test::Unit::TestRunner;
use Test::Unit::TestSuite;

sub new {
	my $class = shift;
	return bless {}, $class;
}

sub suite {
	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"));
	$suite->add_test(Test::Unit::TestSuite->new("PlainTest"));
#	$suite->add_test(Test::Unit::TestSuite->new("BKTest"));
	return $suite;
}

1;

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

package BKTest;
use strict;

use Test::Unit;
use Cwd;
use Time::Local;
use lib "..";
use lib "../lib";

use LXR::Files;

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

use vars qw($bkpath $bkrefdir $bkcache	);

$bkpath   = getcwd() . "../../lxr-tools/test-data/bk-test-repository";
$bkrefdir = getcwd() . "../../lxr-tools/test-data/bk-reference-files/";
$bkcache  = getcwd() . "../../lxr-tools/test-data/bk-cache-dir";

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

	#	$self->{config} = {};
	return $self;
}

# define tests

# test that a bk files object can be created
sub test_creation {
	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
sub test_root {
	my $self = shift;
	$self->assert(
		$self->{'bk'}->{rootpath} eq $self->{'config'}->{'dir'},
		"rootpath failed $self->{bk}->{rootpath} $self->{'config'}->{'dir'}"
	);
}

# Test the getdir function

package LXR::Files::BK::Test;
use LXR::Files::BK;

use vars qw(@ISA);

@ISA = ("LXR::Files::BK");

sub new {
	my ($proto, $rootpath) = @_;
	my $class = ref($proto) || $proto;
	my $self  = $class->SUPER::new($rootpath, {'cachepath' => ''});

	bless($self, $class);
	return $self;
}

sub set_tree {
	my ($self) = shift;
	$self->{tree} = \@_;
}

sub get_tree {
	my ($self) = shift;
	return @{ $self->{'tree'} };
}

1;

package BKTest;

# Test the tree building & caching for the getdir function.
#  Uses the BK::Test module to stub out real BK commands
#  so entire operation carried out on virtual trees

sub test_getdir_part1 {
	my $self = shift;
	my $bk   = new LXR::Files::BK::Test("/");
	$bk->set_tree("README|README|1.1", "src/file1|src/file1|1.1",
		"src/file2|src/file2|1.1",
		"src/tests/newtest/test1|src/tests/newtest/test1|1.3");

	my @files =
	  sort($bk->getdir("/", 'test1'));  # use different releases to disambiguate
	$self->assert_deep_equals(\@files, [ sort "README", "src/" ]);
	@files = sort ($bk->getdir("", 'test1'));  # Check that interprets "" as "/"
	$self->assert_deep_equals(\@files, [ sort "README", "src/" ]);
	@files = sort($bk->getdir("src/", 'test1'));
	$self->assert_deep_equals(\@files, [ sort "file1", "file2", "tests/" ]);
	@files = sort($bk->getdir("src/tests/newtest/", 'test1'));
	$self->assert_deep_equals(\@files, [ sort "test1" ]);
	@files = sort($bk->getdir("src/tests/", 'test1'));
	$self->assert_deep_equals(\@files, [ sort "newtest/" ]);
	@files = sort($bk->getdir("src/tests/newtest/", 'test1'));
	$self->assert_deep_equals(\@files, [ sort "test1" ]);

	$bk->set_tree(
		"BitKeeper/deleted/.del-README-34243232432|README|1.2",
		"src/file1|src/file1|1.2",
		"src/file2|src/file2|1.2",
		"src/tests/newtest/test1|src/tests/newtest/test1|1.2",
		"src/tests/newtest/test2|src/tests/newtest/test2|1.2",
		"Config|Config|1.2"
	);
	@files =
	  sort($bk->getdir("src/tests/newtest/", 'test1')); # Check cache is working
	$self->assert_deep_equals(\@files, ["test1"]);
	@files =
	  sort($bk->getdir("src/tests/newtest/", 'test2'))
	  ;    # Should pick up new entry
	$self->assert_deep_equals(\@files, [ "test1", "test2" ]);
	@files =
	  sort($bk->getdir("src/tests/", 'test2'))
	  ;    # Should still only see one copy of dir
	$self->assert_deep_equals(\@files, ["newtest/"]);
	@files =
	  sort($bk->getdir("src/tests/newtest/", 'test1'))
	  ;    # Check cache is still ok
	$self->assert_deep_equals(\@files, ["test1"]);

	# Now tests with invalid paths on entry
	@files = sort($bk->getdir("src/tests", 'test2'));
	$self->assert($#files == -1);
}

# Test the get_tree function and ensure it is giving the right answers
sub test_get_tree {
	my $self = shift;
	my $bk   = $self->{'bk'};

	my @versions = (1.5, 1.7, 1.6, 1.8);
	foreach (@versions) {
		my @tree = sort $bk->get_tree('@' . $_);
		open(X, "${bkrefdir}bk-file-tree-$_")
		  || die "Can't read ${bkrefdir}bk-file-tree-$_";
		my @answer = sort <X>;
		close X;
		chomp @answer;
		$self->assert_deep_equals(\@tree, \@answer, "Failed for version $_");
	}
}

# Now test the getdir function with the full tree
sub test_getdir_part2 {
	my $self = shift;
	my $bk   = $self->{'bk'};

	# A revision with no deletions
	my @entries = sort $bk->getdir('/firstdir/', '@1.3');
	$self->assert(scalar(@entries) == 2, "entries is $#entries");
	$self->assert_deep_equals(\@entries, [ sort ("file2", "file3") ]);
	@entries = sort($bk->getdir('/seconddir/', '@1.6'));
	$self->assert_deep_equals(\@entries, [ sort ("file4", "thirddir/") ]);

	# Check the full recursive tree
	@entries = sort $bk->getdir('/', '@1.11');
	$self->assert_deep_equals(\@entries, [sort ("file1", "firstdir/", "seconddir/", "sourcedir/")]);
	@entries = sort $bk->getdir('/sourcedir/', '@1.11');
	$self->assert_deep_equals(\@entries, [sort ("cobol.c", "main.c", "subdir1/")]);

	# Now a revision after some files have been deleted
	@entries = sort $bk->getdir('firstdir/', '@1.6');
	$self->assert(scalar(@entries) == 0);
	@entries = sort $bk->getdir('seconddir/', '@1.6');
	$self->assert_deep_equals(\@entries, [ sort ('thirddir/', 'file4') ]);
	@entries = sort $bk->getdir('seconddir/thirddir/', '@1.6');
	$self->assert_deep_equals(\@entries, [ sort ('file5') ]);

	# Now after a file in firstdir has been recreated
	@entries = sort $bk->getdir('firstdir/', '@1.8');
	$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 {
	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;
	my $bk   = $self->{'bk'};

	# These all exist
	$self->assert($bk->file_exists('/file1',                    '@1.2'));
	$self->assert($bk->file_exists('/file1',                    '@1.6'));
	$self->assert($bk->file_exists('/file1',                    '@1.8'));
	$self->assert($bk->file_exists('/firstdir/file2',           '@1.3'));
	$self->assert($bk->file_exists('/firstdir/file3',           '@1.5'));
	$self->assert($bk->file_exists('/seconddir/thirddir/file5', '@1.6'));

	# And these don't
	$self->assert(!$bk->file_exists('/file1',                    '@1.1'));
	$self->assert(!$bk->file_exists('/file2',                    '@1.3'));
	$self->assert(!$bk->file_exists('/firstdir/',                '@1.8'));
	$self->assert(!$bk->file_exists('/firstdir/file2',           '@1.2'));
	$self->assert(!$bk->file_exists('/firstdir/file3',           '@1.6'));
	$self->assert(!$bk->file_exists('/seconddir/thirddir/file4', '@1.6'));
}

sub test_getfileinfo {
	my $self = shift;
	my $bk   = $self->{'bk'};

	# These all exist
	$self->assert(defined($bk->getfileinfo('/file1', '@1.2')));
	$self->assert($bk->getfileinfo('/file1', '@1.6')->{'revision'} == 1.1);
	$self->assert($bk->getfileinfo('/file1', '@1.8')->{'curpath'} eq 'file1');
	my $info = $bk->getfileinfo('/firstdir/file2', '@1.3');
	$self->assert($info->{'revision'} == 1.1);
	$self->assert(
		$info->{'curpath'} eq 'BitKeeper/deleted/.del-file2~7a40a14b3cb5ac42');

	# And these don't
	$self->assert(!defined($bk->getfileinfo('/file1', '@1.1')));
	$self->assert(!defined($bk->getfileinfo('/file2', '@1.3')));
}

# Some basic getfile tests
# Check for correct & incorrect pathnames and versions
sub test_getfile {
	my $self = shift;
	my $bk   = $self->{'bk'};

	my $data = $bk->getfile("/firstdir/file2", '@1.3');
	open(FILE, '<', $bkrefdir . 'firstdir^file2^@1.3')
	  || die "Can't open file to check contents firstdir^file2^\@1.3";
	local ($/) = undef;
	my $check = <FILE>;
	close FILE;
	$self->assert($check eq $data, "File read didn't match");

# Pathnames must start with a "/" for CVS/Plain but we'll accept without - for now!
	$data = $bk->getfile("firstdir/file2", '@1.3');
	$self->assert($check eq $data, "File read didn't match");
	$data = $bk->getfile("/an/impossible/path/that/doesn/t/exist", '@131');
	$self->assert(!defined($data));
	$data = '';
	$data = $bk->getfile("include/linux/jffs.h", '@1345');
	$self->assert(!defined($data));
}

# Detailed getfile tests
# Checking here that we can correctly recover:
#  - the same file at two different revisions
#  - a file that has been deleted
#  - a file that has been deleted and then reconstructed
#      (i.e. the new dir/file is different to dir/file at a previous revision
#  - a file that has been moved
sub test_getfile2 {
	my $self = shift;
	my $bk   = $self->{'bk'};

	# These are all valid versions with contents
	my @versions = (
		'/seconddir/file4',          '@1.4',     # rev 1
		'/seconddir/file4',          '@1.7',     # rev 2
		'/firstdir/file2',           '@1.4',     # before delete
		'/firstdir/file2',           '@1.8',     # after reconstruction
		'/seconddir/thirddir/file5', '@1.6',     # before move
		'/seconddir/thirddir/file6', '@1.9',     # after move
		'/seconddir/file7',          '@1.10',    # after move to new dir
	);

	while (scalar(@versions)) {
		my $file      = shift @versions;
		my $ver       = shift @versions;
		my $data      = $bk->getfile($file, $ver);
		my $checkfile = substr($file, 1);
		$checkfile =~ s{/}{^}g;
		$checkfile = $bkrefdir . $checkfile . '^' . $ver;
		open(X, '<', $checkfile) or die "Can't open file $checkfile";
		local ($/) = undef;
		my $check = <X>;
		close X;
		$self->assert_equals($data, $check, "Failed for $file, $ver");
	}
}

sub test_getfilehandle {
	my ($self) = shift;
	my $bk = $self->{'bk'};

	$self->assert(defined($bk->getfilehandle("/firstdir/file2",  '@1.3')));
	$self->assert(defined($bk->getfilehandle("/seconddir/file4", '@1.6')));
	$self->assert(defined($bk->getfilehandle('file1',            '@1.2')));
	$self->assert(
		!defined($bk->getfilehandle("/random/path/to/nowhere", '@1.1449')));
	$self->assert(!defined($bk->getfilehandle("/file1",          '1.1')));
	$self->assert(!defined($bk->getfilehandle("/firstdir/file3", '@1.8')));
	$self->assert(!defined($bk->getfilehandle("/seconddir/file7", '@1.8')));
	$self->assert(!defined($bk->getfilehandle("/seconddir/thirddir/file5", '@1.10')));
}

# Test filerev
#  Need to ensure that the filerevs are < 255 chars & sensible!
#  Oh, and they change when the file changes!
sub test_filerev {
	my ($self) = shift;
	my $bk = $self->{'bk'};

	# A file that has changed contents
	my $rev = $bk->filerev('/file1', '@1.3');
	$self->assert($rev);
	$self->assert_not_equals($rev, $bk->filerev('/file1', '@1.12'));

	# A file that hasn't changed
	$rev = $bk->filerev('/firstdir/file2', '@1.3');
	$self->assert_equals($rev, $bk->filerev('/firstdir/file2', '@1.5'));
	$self->assert(length($rev) < 255);

	# A file that has been deleted & recreated
	$rev = $bk->filerev('/firstdir/file2', '@1.5');
	$self->assert_not_equals($rev, $bk->filerev('/firstdir/file2', '@1.9'));
}

# Test isdir
#  Assuming that pathname will always end in / if it's a dir
#  - this may not be correct!
sub test_isdir {
	my ($self) = shift;
	my $bk = $self->{'bk'};

	$self->assert($bk->isdir('/firstdir/', '@1.3'));
	$self->assert($bk->isdir('/seconddir/thirddir/','@1.6'));
	$self->assert(!$bk->isdir('/not/a/dir/', '@1.3'));
	$self->assert(!$bk->isdir('/seconddir/file2/', '@1.4'));
	$self->assert(!$bk->isdir('/file1','@1.11'));
	$self->assert(!$bk->isdir('/sourcedir/main.c', '@1.12'));
	$self->assert(!$bk->isdir('/sourcedir/', '@1.10')); 
}

sub test_isfile {
	my ($self) = shift;
	my $bk = $self->{'bk'};

	$self->assert($bk->isfile('/file1', '@1.12'));
	$self->assert($bk->isfile('/sourcedir/main.c', '@1.12'));
	$self->assert(!$bk->isfile('/sourcedir/main.c', '@1.9'));
	$self->assert(!$bk->isfile('/seconddir/thirddir/', '@1.9'));
}

# Test the getfiletime function
#  tests are assuming that undef is OK for a directory
sub test_getfiletime {
	my ($self) = shift;
	my $bk = $self->{'bk'};

	$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')));
}

# Test the getfilesize
sub test_getfilesize {
	my ($self) = shift;
	my $bk = $self->{'bk'};

	$self->assert_equals($bk->getfilesize('/file1', '@1.3'), 60);
	$self->assert_equals($bk->getfilesize('/file1', '@1.3'), $bk->getfilesize('file1', '@1.11'));
	$self->assert(!defined($bk->getfilesize('/sourcedir/main.c', '@1.9')));
}

# Test getauthor

sub test_getauthor {
	my ($self) = shift;
	my $bk = $self->{'bk'};

	$self->assert_equals('malcolm', $bk->getauthor('/file1', '@1.3'));
	$self->assert_equals('malcolm', $bk->getauthor('/sourcedir/cobol.c', '@1.13'));
	$self->assert_null($bk->getauthor('/sourcedir/cobol.c', '@1.3'));
}

# Test getannotations
#  Only problem is that I don't have a clue what this function should return - so
#  for now we're stubbing it out a la Plain.pm

sub test_getannotations {
	my ($self) = shift;
	my $bk = $self->{'bk'};

	$self->assert_deep_equals([], [ $bk->getannotations('/file1', '@1.3') ]);
}

# Tests of helper functions in BK.pm
sub test_canonise {
	my ($self) = shift;
	my $bk = $self->{'bk'};
	$self->assert(
		LXR::Files::BK::canonise('/path/to/somewhere') eq 'path/to/somewhere');
	$self->assert(LXR::Files::BK::canonise('/') eq '');
}

# 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->{'bk'} = new LXR::Files("bk:$bkpath", {'cachepath' => $bkcache});
	$self->{'config'}->{'dir'} = "$bkpath";
}

sub tear_down {
	my $self = shift;

	#	$self->{config} = undef;
}

1;

--- NEW FILE: CVSTest.pm ---
# Test cases for the LXR::Files::CVS 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('INSTALL','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;

	# This test module relies on the CVSROOT env variable pointing to a test CVS repository
	$self->assert(defined($ENV{'CVSROOT'}), 'CVSROOT must be defined');

	$self->{'cvs'} = new LXR::Files("cvs:$ENV{'CVSROOT'}");
 	$self->{'config'}->{'dir'} = "$ENV{'CVSROOT'}/";
 	}

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

1;

--- NEW FILE: ConfigTest.pm ---
# Test cases for the LXR::Config module
# Uses the associated lxr.conf file

package ConfigTest;
use strict;

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

use LXR::Config;

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

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

# define tests

# test that the config object was created successfully
sub test_creation {
	my $self = shift;
	$self->assert(defined($self->{config}), "Config init failed");
}

# Access some of the values to check what is found
sub test_access {
	my $self = shift;
	$self->assert($self->{config}->swishindex eq '/test/lxr/bin/swish-e',
		   "swishindex read failed");
	$self->assert($self->{config}->baseurl eq 'http://test/lxr/',
		   "Config accessed wrong baseurl " . $self->{config}->baseurl);
}

# test access to the variables section
sub test_variables {
	my $self = shift;
	$self->assert($self->{config}->variable('v') eq '1.0.6',
		   "Variable default not correct");
	$self->assert(($self->{config}->varrange('v'))[1] =~ /hi hippy/,
		   "Variable value missing");
}

sub test_allvariables {
	my $self = shift;
	my @vars = $self->{config}->allvariables();
    $self->assert(grep {$_ eq 'v'} @vars, "allvariables didn't return v");
	$self->assert(grep {$_ eq 'a'} @vars, "allvariables didn't return a");
	$self->assert($#vars == 1, "Too many variables returned got @vars");
}

sub test_config_error {
	my $self = shift;
	my $t;

	eval {new LXR::Config("/a/path", "./lxr.conf")};
	$t = $@;
	$self->assert(defined($t), "Didn't fail to find config");
	$self->assert_matches(qr/--url parameter should be a URL \(e\.g\. http:/, $t);
}

# 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 {
	my $self = shift;
	my $test = eval {new LXR::Config("http://test/lxr-wibble", "./lxr.conf");};
	$self->assert(!defined($test), "Should not have matched");
	}

# 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->{config} = new LXR::Config("http://test/lxr", "./lxr.conf");
 	}

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

1;

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

package PlainTest;
use strict;

use FindBin;

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 = "$FindBin::Bin/test-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("/aFile.txt", '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("/aFile.txt", '5.5.4');
	local ($/) = undef;
	open FILE, "<". "$root/5.5.4/aFile.txt" || 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;

--- NEW FILE: README ---
To run these tests:

- Make sure Test::Unit is installed
- Execute TestRunner.pl AllTests

Note: If you wish to run the Bitkeeper tests you will need to:
- Grab the lxr-tools module from CVS to the same top-level as the lxr tree
(so you have /mydir/lxr and /mydir/lxr-tools)
- untar the bk-test-repository.tgz file in lxr-tools/test-data
- uncomment the BKTest line in AllTests.pm

--- 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_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 '/a/test/path/', "pathname not washed, got $pathname");

	$ENV{'PATH_INFO'} = '';
	$ENV{'QUERY_STRING'} = 'file=/a/test/path++many';
	$die = $SIG{'__DIE__'};
	$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'} = '';
	$die = $SIG{'__DIE__'};
	$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");

	$ENV{'PATH_INFO'} = '/ab/-/path+!/some/%chars,v';
	$ENV{'QUERY_STRING'} = '';
	$die = $SIG{'__DIE__'};
	$warn = $SIG{'__WARN__'};
	httpinit;
	$SIG{'__DIE__'} = $die;
	$SIG{'__WARN__'} = $warn;
	$self->assert($pathname eq '/ab/-/path+!/some/%chars,v', "pathname not washed, got $pathname");
}

sub test_filename_compat {
	# Checking for ability to deal with ++ in the filename
	my $self = shift;

	$ENV{'SERVER_NAME'} = 'test';
	$ENV{'SERVER_PORT'} = 80;
	$ENV{'SCRIPT_NAME'} = '/lxr/source';
	$ENV{'PATH_INFO'} = '/a/test/file++name';
	$ENV{'QUERY_STRING'} = '';

	# 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 '/a/test/file++name', "pathname corrupted, got $pathname");
}

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;

--- NEW FILE: TestRunner.pl ---
#!perl -w

use strict;

use Test::Unit::Debug qw(debug_pkgs);
use Test::Unit::TestRunner;

# Uncomment and edit to debug individual packages.
#debug_pkgs(qw/Test::Unit::TestCase/);

my $testrunner = Test::Unit::TestRunner->new();
$testrunner->start(@ARGV);

--- NEW FILE: lxr.conf ---
# -*- mode: perl -*-
# Configuration file for Test suite
#
(
 {
  # Global configuration

  # Path to glimpse executable.
  # Define this OR the swish-e variables depending which search engine you want to use.
  'glimpsebin'	=> '/test/lxr/bin/glimpse',

  # Location of SWISH-E indexer binary
  'swishindex' => '/test/lxr/bin/swish-e',

  # Location of SWISH-E search binary
  'swishsearch' => '/test/lxr/bin/swish-e',

  # Path to Exuberant Ctags executable
  'ectagsbin'	=> '/test/lxr/bin/ctags',

  # Place where lxr can write temporary files
  'tmpdir'		=> '/tmp',

  # Location of the Generic.pm config file
  'genericconf' => '../lib/LXR/Lang/generic.conf',

  # Paths for CVS module
  'cvspath' => '/bin:/usr/local/bin:/usr/bin:/usr/sbin',

 },

 {
     # Configuration for http://192.168.1.3/lxr.
     # baseurl is used to select configuration block.

     'baseurl'		=> 'http://test/lxr',  # Put your URL here
     'virtroot'		=> '/lxr',                    # The bit after the / above

     'variables' => {
					 # Define typed variable "v".  This is the list of versions to index.
					 'v' => {'name'    => 'Version',
							 # This can come from a file, a function or be explicitly
							 # ennumerated.
							 # From a file:
							 'range'   => [ readfile('test-versions') ], 
							 # Explicitly:
							 # 'range' => [qw(v1 v2 v3.1 v4 experimental)],
							 # If files within a tree can have different versions,
							 # e.g in a CVS tree, 'range' can be specified as a
							 # function to call for each file:
							 #'range'   => sub { return 
							 #			($files->allreleases($LXR::Common::pathname),
							 #			 $files->allrevisions($LXR::Common::pathname))
							 #			}, # deferred function call.

							 # The default version to display
							 'default' => '1.0.6'},

					 # Define typed variable "a".  First value is default.
					 'a' => {'name'    => 'Architecture',
							 'range'   => [qw(i386 alpha arm m68k mips ppc sparc sparc64)]},
					},

  # These do funky things to paths in the system - you probably don't need them.
  'maps' => {
			 '/include/asm[^\/]*/' => '/include/asm-$a/',
			 '/arch/[^\/]+/'       => '/arch/$a/',
			},

  # Templates used for headers and footers
  'htmlhead'		=> 'html-head.html',
  'htmltail'		=> 'html-tail.html',
  'htmldir'		=> 'html-dir.html',
  'htmlident'        => 'html-ident.html',

  'sourcehead'	=> 'html-head.html',
  'sourcedirhead'	=> 'html-head.html',
  'stylesheet'       => 'lxr.css',

  # sourceroot - where to get the source files from

  # For ordinary directories, this specifies a directory which has each version as a
  # subdirectory e.g.
  #  indexed-src/version1/...
  #  indexed-src/version2/...
  # The names of the version directories must match the values for the Version
  # variable above.
  'sourceroot'	=> '/home/malcolm/indexed-src',
  # Alternatively, this can specify a CVS repository by setting the value to "cvs:"
  # followed by the path to the repository.  Note this must be file accessible - remote
  # server access does NOT work.
  #     'sourceroot'	=> 'cvs:/hom/karsk/a/CVSROOT/linux',

  # 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>
  # for Oracle, it is dbi:Oracle:host=localhost;sid=DEVMMS;port=1521
  'dbname'		=> 'dbi:mysql:dbname=lxr',

  # If you need to specify the username or password for the database connection,
  # uncomment the following two lines
  #  'dbpass'		=> 'foo',
  #  'dbuser'		=> 'lxr',

  # For using glimpse, the directory to store the .glimpse files in is required
  'glimpsedir' => '/path/to/glimpse/databases',

  # Location of swish-e index database files if using swish-e
  'swishdir' => '/a/directory/here/',

  # where to look for include files inside the sourcetree.  This is used to hyperlink
  # to included files.
  'incprefix'	=> ['/include', '/include/linux'],

  # Which extensions to treat as images when browsing.  If a file is an image,
  # it is displayed.
  'graphicfile' => '(?i)\.(gif|jpg|jpeg|pjpg|pjpeg|xbm|png)$',  #'

  # How to map files to languages
  # Note that the string for the key and the first entry in the
  # array MUST match
  'filetype' => {
				 # Format is
				 # Language name, filepatten regexp, module to invoke,
                 # (optional )tabwidth
				 # Note that to have another language supported by Generic.pm,
				 # you must ensure that:
				 # a) exuberant ctags supports it
				 # b) generic.conf is updated to specify information about the language
				 # c) the name of the language given here matches the entry in generic.conf
				 'C' => ['C', '\.c$' #'
				  , 'LXR::Lang::Generic', '8'],
				 'C++' => ['C++', '\.C$|((?i)\.c\+\+$|\.cc$|\.cpp$|\.cxx$|\.h$|\.hh$|\.hpp$|\.hxx$|\.h\+\+$)' #'
				  , 'LXR::Lang::Generic', '8'],

# Some languages are commented out until the relevant entries in generic.conf are made
# The list here is the set supported by ctags 5.0.1
# 				 ['Beta', '(?i)\.bet$' #'
# 				  , 'LXR::Lang::Generic'],
# 				 ['Cobol', '(?i)\.cob$'  #'
# 				  , 'LXR::Lang::Generic'],
# 				 ['Eiffel', '(?i)\.e$'   #'
# 				  , 'LXR::Lang::Generic'],
# 				 ['Fortran', '(?i)\.f$|\.for$|\.ftn$|\.f77$|\.f90$|\.f95$'   #'
# 				  , 'LXR::Lang::Generic'],
				 'Java' => ['Java', '(?i)\.java$'   #'
				  , 'LXR::Lang::Java', '4'],
# 				 ['Lisp', '(?i)\.cl$|\.clisp$|\.el$|\.l$|\.lisp$|\.lsp$|\.ml$'   #'
 # 				  , 'LXR::Lang::Generic'],
                  # No tabwidth specified here as an example
 				 'Make' => ['Make', '(?i)\.mak$|makefile*' #'
							, 'LXR::Lang::Generic'],
# 				 ['Pascal', '(?i)\.p$|\.pas$'   #'
# 				  , 'LXR::Lang::Generic'],
				 'Perl' => ['Perl', '(?i)\.pl$|\.pm$|\.perl$'   #'
				  , 'LXR::Lang::Generic', '4'],
 				 'php' => ['php', '(?i)\.php$|\.php3$|\.phtml$'   #'
 				  , 'LXR::Lang::Generic', '2'],
				 'Python' => ['Python', '(?i)\.py$|\.python$'   #'
				  , 'LXR::Lang::Generic', '4'],
# 				 ['rexx', '(?i)\.cmd$|\.rexx$|\.rx$'   #'
# 				  , 'LXR::Lang::Generic'],
# 				 ['ruby', '(?i)\.rb$'   #'
# 				  , 'LXR::Lang::Generic'],
# 				 ['scheme', '(?i)\.sch$|\.scheme$|\.scm$|\.sm$'   #'
# 				  , 'LXR::Lang::Generic'],
# 				 ['shell', '(?i)\.sh$|\.bsh$|\.bash$|\.ksh$|\.zsh$'   #'
# 				  , 'LXR::Lang::Generic'],
# 				 ['s-Lang', '(?i)\.sl$'   #'
# 				  , 'LXR::Lang::Generic'],
# 				 ['tcl', '(?i)\.tcl$|\.wish$'   #'
# 				  , 'LXR::Lang::Generic'],
				},

	'ignoredirs' => [],
  # Maps interpreter names to languages.  The format is:
  #  regexp => langname
  #   regexp is matched against the part after #! on the first line of a file
  #   langname must match one of the keys in filetype above.
  #
  # This mapping is only used if the filename doesn't match a pattern above, so
  # a shell script called shell.c will be recognised as a C file, not a shell file.

  'interpreters' => {
					 'perl' => 'Perl',
#					 'bash' => 'shell',
#					 'csh' => 'shell',
					 'python' => 'Python',
					},

})

--- NEW FILE: test-versions ---
1.0.6
hi hippy
wibble

[Lxr-commits] CVS: lxr-tools/tests AllTests.pm, NONE, 1.1 BKTest.pm, NONE, 1.1 CVSTest.pm, NONE, 1.

[Lxr-commits] CVS: lxr-tools/tests AllTests.pm, NONE, 1.1 BKTest.pm, NONE, 1.1 CVSTest.pm, NONE, 1.1 ConfigTest.pm, NONE, 1.1 PlainTest.pm, NONE, 1.1 README, NONE, 1.1 SecurityTest.pm, NONE, 1.1 TestRunner.pl, NONE, 1.1 lxr.conf, NONE, 1.1 test-versions, NONE, 1.1