More test cases and framework stuff. t/62-api.t is currently not working.

git-svn-id: https://ledger-smb.svn.sourceforge.net/svnroot/ledger-smb/trunk@2403 4979c152-3d1c-0410-bac9-87ea11338e46

7 files changed, 351 insertions, 74 deletions

diff --git a/LedgerSMB/DBTest.pm b/LedgerSMB/DBTest.pm
new file mode 100644
index 00000000..915bfc0b
--- /dev/null
+++ b/LedgerSMB/DBTest.pm
@@ -0,0 +1,126 @@
+
+=head1 NAME
+
+LedgerSMB::DBTest - LedgerSMB commit filter for test cases.
+
+=head1 SYOPSIS
+
+This module creates a DBI-like interface but ensures autocommit is off, 
+and filters commit statements such that they don't do anything.  This can be 
+used for making API test cases which involve DB commits safe for production 
+environments.
+
+=head1 USAGE
+
+Both LedgerSMB.pm and LedgerSMB/Form.pm assign a global database handler for all
+database access within a script in the dbh property (for example,
+$request->{dbh} or $form->{dbh}).  By setting this early to a
+LedgerSMB::DBTest (instead of a DBI object), the tests can be made safe.
+
+However, there are a few limitations to be aware of.  One cannot run tests
+through the standard request handler and use this module. Hence this is limited
+to unit tests of files in the LedgerSMB, scripts, and bin directories.
+
+Here is an example of how this could be done:
+
+ my $lsmb = LedgerSMB->new();
+ $lsmb->merge($testdata);
+ my $dbh = LedgerSMB::DBTest->connect("dbi:Pg:dbname=$company", "$username",
+     "$password",)
+ $lsmb->{dbh} = $dbh;
+
+
+=head1 METHODS
+
+=over
+
+=item connect($dsn, $user, $pass)
+
+Connects to the database and returns a LedgerSMB::DBTest object
+
+=item commit()
+
+Tests the current transaction (issues a 'SELECT 1;' to the database).  If this
+is successful returns 1, if not, rolls back and returns false.
+
+Note that this means all past tests are rolled back and this is inconsistent
+with normal transactional behavior.
+
+=item prepare()
+
+Returns a statement handle, via the private DBI database handle.
+
+=item do() 
+
+passes this statement on to the private database handle
+
+=item errstr()
+
+passes this call on to the private database handle
+
+=item err()
+
+passes this call on to the private database handle
+
+=item rollback()
+
+passes this call on to the private database handle.  Note that this will roll
+back all statements issues through this object.
+
+=back
+
+=cut
+
+use DBI;
+package LedgerSMB::DBTest;
+
+sub DISTROY {
+    my ($self) = @_;
+    $self->disconnect;
+}
+
+sub connect{
+    my ($class, $dsn, $user, $pass) = @_;
+    my $self = {};
+    $self->{_dbh} = DBI->connect($dsn, $user, $pass, {AutoCommit => 0 });
+    bless $self, $class;
+    return $self;
+}
+
+sub disconnect {
+    my ($self) = @_;
+    $self->rollback;
+    $self->{_dbh}->disconnect;
+}
+
+sub do {
+    my ($self, $statement) = @_;
+    return $self->{_dbh}->do($statement);
+}
+
+sub err{
+    my ($self) = @_;
+    return $self->{_dbh}->err;
+}
+
+sub errstr{
+    my ($self) = @_;
+    return $self->{_dbh}->errstr;
+}
+
+sub prepare{
+    my ($self, $statement) = @_;
+    return $self->{_dbh}->prepare($statement);
+}
+
+sub rollback {
+    my ($self) = @_;
+    return $self->{_dbh}->rollback;
+}
+
+sub state{
+    my ($self) = @_;
+    return $self->{_dbh}->state;
+}
+
+1;
diff --git a/README.tests b/README.tests
index ebbdac82..52bea2ae 100644
--- a/README.tests
+++ b/README.tests
@@ -8,3 +8,27 @@ Test file number allocation:
 90 - 99: Packaging checks
 
 Environment variables can be used as flags to disable/enable tests >= 40
+
+LSMB_TEST_DB must be set to a defined value if databases are going to be tested.
+
+if LSMB_NEW_DB is set, test 40 (when it is complete) will create a database with
+the name from this environment variable, and subsequent database tests will run
+against that database.  If this is not set, and PGDATABASE is set, tests will 
+run on that database. If neither are set, the tests will bail out.
+
+Special notes on specific test cases:
+
+42-dbobject.t:  Some tests will run even if LSMB_TEST_DB is not enabled.  These 
+tests do not require a database connection.
+
+43-dbtest.t:  This runs defined test cases from sql/modules/test/.  If new
+scripts are added, they must be listed in this script as well.
+
+62-api.t uses request hashes defined in t/data/62-request-data.  This
+script employs a database commit filter to prevent commits to the db.  It is
+safe to run on existing databases.
+
+63-lwp.t will re-use the request hashes defined in test/data/62-request-data.
+It does NOT employ a commit filter, so is NOT safe to run against production
+data.  It will only run if the environment variable LSMB_TEST_LWN is set to true.
+
diff --git a/t/11-ledgersmb.t b/t/11-ledgersmb.t
index 0ddf29ab..be112bef 100644
--- a/t/11-ledgersmb.t
+++ b/t/11-ledgersmb.t
@@ -12,7 +12,7 @@ use Math::BigFloat;
 
 use LedgerSMB::Sysconfig;
 use LedgerSMB;
-
+my $lsmb;
 sub redirect {
 	print "redirected\n";
 }
@@ -34,7 +34,7 @@ sub lsmb_error_func {
 ##547	merge
 
 
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 my %myconfig;
 my $utfstr;
 my @r;
@@ -43,7 +43,7 @@ ok(defined $lsmb);
 isa_ok($lsmb, 'LedgerSMB');
 
 # $lsmb->escape checks
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 $utfstr = "\xd8\xad";
 utf8::decode($utfstr);
 ok(!$lsmb->escape, 'escape: (undef)');
@@ -61,7 +61,7 @@ TODO: {
 }
 
 # $lsmb->is_blank checks
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 $lsmb->{blank} = '    ';
 $lsmb->{notblank} = ' d   ';
 TODO: {
@@ -74,7 +74,7 @@ is($lsmb->is_blank('name' => 'notblank'), 0, 'is_blank: notblank');
 is($lsmb->is_blank('name' => 'blank'), 1, 'is_blank: blank');
 
 # $lsmb->is_run_mode checks
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 $ENV{GATEWAY_INTERFACE} = 'foo';
 is($lsmb->is_run_mode('cgi'), 1, 'is_run_mode: CGI - CGI');
 is($lsmb->is_run_mode('cli'), 0, 'is_run_mode: CGI - CLI');
@@ -101,7 +101,7 @@ is($lsmb->is_run_mode('foo'), 0, 'is_run_mode: CLI - (bad mode)');
 is($lsmb->is_run_mode, 0, 'is_run_mode: CLI - (unknown mode)');
 
 # $lsmb->num_text_rows checks
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 is($lsmb->num_text_rows('string' => "apple\npear", 'cols' => 10, 'max' => 5),
 	2, 'num_text_rows: 2 rows, no column breakage, max 5 rows');
 is($lsmb->num_text_rows('string' => "apple\npear", 'cols' => 10, 'max' => 1),
@@ -124,7 +124,7 @@ is($lsmb->num_text_rows('string' => "012345 67890123456789", 'cols' => 10),
 	3, 'num_text_rows: 3 rows, word and non column breakage, no max row count');
 
 # $lsmb->debug checks
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 @r = trap{$lsmb->debug()};
 #SKIP: {like($trap->stdout, qr|\n\$VAR1 = bless\( {[\n\s]+'action' => '',[\n\s]+'dbversion' => '\d+\.\d+\.\d+',[\n\s]+'path' => 'bin/mozilla',[\n\s]+'version' => '$lsmb->{version}'[\n\s]+}, 'LedgerSMB' \);|,
 #	'debug: $lsmb->debug');
@@ -138,9 +138,18 @@ SKIP: {
 	my @str = <$FH>;
 	close($FH);
 	chomp(@str);
-	#FIXME test broken below:  
-	#like(join("\n", @str), qr|\$VAR1 = 'file';\n\$VAR2 = 't/var/lsmb-11.$$';\n\$VAR3 = bless\( {[\n\s]+'action' => '',[\n\s]+'dbversion' => '\d+\.\d+\.\d+',[\n\s]+'file' => 't/var/lsmb-11.$$',[\n\s]+'path' => 'bin/mozilla',[\n\s]+'version' => '$lsmb->{version}'[\n\s]+}, 'LedgerSMB' \);|,
-	#	'debug: $lsmb with file, contents');
+	cmp_ok(grep (/\s?\$VAR1\s=\sbless/, @str), '>', 0, 
+		'Debug Contents, var1 type'); 
+	cmp_ok(grep (/'action' => ''/, @str), '>', 0,
+		'Debug contents, blank action');
+	cmp_ok(grep (/'dbversion' => '\d+\.\d+\.\d+'/, @str), '>', 0,
+		'Debug contents, dbversion format');
+	cmp_ok(grep (/'path' => 'bin\/mozilla'/, @str), '>', 0,
+		'Debug contents, path');
+	cmp_ok(grep (/'version' => '$lsmb->{version}'/, @str), '>', 0,
+		'Debug contents, version match');
+	cmp_ok(grep (/'file' => 't\/var\/lsmb-11.$$'/, @str), '>', 0,
+		'Debug contents file attribute match');
 	is(unlink("t/var/lsmb-11.$$"), 1, "debug: removing t/var/lsmb-11.$$");
 	ok(!-e "t/var/lsmb-11.$$", "debug: t/var/lsmb-11.$$ removed");
 };
@@ -152,7 +161,7 @@ like($trap->die, qr/No such file or directory/,
 ok(!-e $lsmb->{file}, "debug: file creation failed");
 
 # $lsmb->new checks
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 ok(defined $lsmb, 'new: blank, defined');
 isa_ok($lsmb, 'LedgerSMB', 'new: blank, correct type');
 ok(defined $lsmb->{action}, 'new: blank, action defined');
@@ -160,41 +169,21 @@ ok(defined $lsmb->{dbversion}, 'new: blank, dbversion defined');
 ok(defined $lsmb->{path}, 'new: blank, path defined');
 ok(defined $lsmb->{version}, 'new: blank, version defined');
 
-#my $lsmb = LedgerSMB->new();
-#ok(defined $lsmb, 'new: action set, defined');
-#isa_ok($lsmb, 'LedgerSMB', 'new: action set, correct type');
-#ok(defined $lsmb->{action}, 'new: action set, action defined');
-#is($lsmb->{action}, 'apple_sauce', 'new: action set, action processed');
-#ok(defined $lsmb->{dbversion}, 'new: action set, dbversion defined');
-#ok(defined $lsmb->{path}, 'new: action set, path defined');
-#ok(defined $lsmb->{version}, 'new: action set, version defined');
-
-#my $lsmb = LedgerSMB->new();
-#ok(defined $lsmb, 'new: lynx, defined');
-#isa_ok($lsmb, 'LedgerSMB', 'new: lynx, correct type');
-#ok(defined $lsmb->{action}, 'new: lynx, action defined');
-#ok(defined $lsmb->{dbversion}, 'new: lynx, dbversion defined');
-#ok(defined $lsmb->{path}, 'new: lynx, path defined');
-#is($lsmb->{path}, 'bin/lynx', 'new: lynx, path carried through');
-#ok(defined $lsmb->{lynx}, 'new: lynx, lynx defined');
-#is($lsmb->{lynx}, 1, 'new: lynx, lynx enabled');
-#ok(defined $lsmb->{menubar}, 'new: lynx, menubar defined (deprecated)');
-#is($lsmb->{menubar}, 1, 'new: lynx, menubar enabled (deprecated)');
-#ok(defined $lsmb->{version}, 'new: lynx, version defined');
-
-# THe test cases below are incomplete and need to be finished
-#@r = trap {$lsmb = LedgerSMB->new()};
-#is($trap->die, "Error: Access Denied\n",
-#	'new: directory traversal 1 caught');
-#@r = trap {$lsmb = LedgerSMB->new()};
-#is($trap->die, "Error: Access Denied\n",
-#	'new: directory traversal 2 caught');
-#@r = trap {$lsmb = LedgerSMB->new()};
-#is($trap->die, "Error: Access Denied\n",
-#	'new: directory traversal 3 caught');
+$lsmb = LedgerSMB->new('path=bin/lynx');
+ok(defined $lsmb, 'new: lynx, defined');
+isa_ok($lsmb, 'LedgerSMB', 'new: lynx, correct type');
+ok(defined $lsmb->{action}, 'new: lynx, action defined');
+ok(defined $lsmb->{dbversion}, 'new: lynx, dbversion defined');
+ok(defined $lsmb->{path}, 'new: lynx, path defined');
+is($lsmb->{path}, 'bin/lynx', 'new: lynx, path carried through');
+ok(defined $lsmb->{lynx}, 'new: lynx, lynx defined');
+is($lsmb->{lynx}, 1, 'new: lynx, lynx enabled');
+ok(defined $lsmb->{menubar}, 'new: lynx, menubar defined (deprecated)');
+is($lsmb->{menubar}, 1, 'new: lynx, menubar enabled (deprecated)');
+ok(defined $lsmb->{version}, 'new: lynx, version defined');
 
 # $lsmb->redirect checks
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 ok(!defined $lsmb->{callback}, 'redirect: No callback set');
 @r = trap{$lsmb->redirect};
 is($trap->stdout, "redirected\n", 'redirect: No message or callback redirect');
@@ -210,49 +199,47 @@ is($trap->stdout, "redirected\n", 'redirect: callback, no message redirect');
 @r = trap{$lsmb->redirect('msg' => "hello world\n")};
 is($trap->stdout, "redirected\n", 'redirect: callback and message redirect');
 
-# Commenting out tests that have to hit db, since this doesn't work so well with
-# 1.3
 # $lsmb->call_procedure checks
-#my $lsmb = LedgerSMB->new();
-#$lsmb->{dbh} = ${LedgerSMB::Sysconfig::GLOBALDBH};
-#@r = $lsmb->call_procedure('procname' => 'character_length', 
-#	'args' => ['month']);
-#is($#r, 0, 'call_procedure: correct return length (one row)');
-#is($r[0]->{'character_length'}, 5, 
-#	'call_procedure: single arg, non-numeric return');
-#
-#@r = $lsmb->call_procedure('procname' => 'trunc', 'args' => [57.1, 0]);
-#is($r[0]->{'trunc'}, Math::BigFloat->new('57'), 
-#	'call_procedure: two args, numeric return');
-#
-#@r = $lsmb->call_procedure('procname' => 'pi', 'args' => []);
-#like($r[0]->{'pi'}, qr/^3.14/, 
-#	'call_procedure: empty arg list, non-numeric return');
+SKIP: {
+	skip 'Skipping call_procedure tests, no db specified' 
+		if !defined $ENV{PGDATABASE};
+	$lsmb = LedgerSMB->new();
+	$lsmb->{dbh} = DBI->connect("dbi:Pg:dbname=$ENV{PGDATABASE}", 
+		undef, undef, {AutoCommit => 0 });
+	@r = $lsmb->call_procedure('procname' => 'character_length', 
+		'args' => ['month']);
+	is($#r, 0, 'call_procedure: correct return length (one row)');
+	is($r[0]->{'character_length'}, 5, 
+		'call_procedure: single arg, non-numeric return');
+
+	@r = $lsmb->call_procedure('procname' => 'trunc', 'args' => [57.1, 0]);
+	is($r[0]->{'trunc'}, Math::BigFloat->new('57'), 
+		'call_procedure: two args, numeric return');
 
-##
-##TODO: {
-##	local $TODO = 'Breaks when no arglist given';
-##	@r = $lsmb->call_procedure('procname' => 'pi');
-##	like($r[0]->{'pi'}, qr/^3.14/, 
-##		'call_procedure: no args, non-numeric return');
-##}
+	@r = $lsmb->call_procedure('procname' => 'pi', 'args' => []);
+	like($r[0]->{'pi'}, qr/^3.14/, 
+		'call_procedure: empty arg list, non-numeric return');
+	@r = $lsmb->call_procedure('procname' => 'pi');
+	like($r[0]->{'pi'}, qr/^3.14/, 
+		'call_procedure: no args, non-numeric return');
+}
 
 # $lsmb->merge checks
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 $lsmb->merge({'apple' => 1, 'pear' => 2, 'peach' => 3}, 'keys' => ['apple', 'pear']);
 ok(!defined $lsmb->{peach}, 'merge: Did not add unselected key');
 is($lsmb->{apple}, 1, 'merge: Added unselected key apple');
 is($lsmb->{pear}, 2, 'merge: Added unselected key pear');
 like($lsmb->{path}, qr#bin/(lynx|mozilla)#, 'merge: left existing key');
 
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 $lsmb->merge({'apple' => 1, 'pear' => 2, 'peach' => 3});
 is($lsmb->{apple}, 1, 'merge: No key, added apple');
 is($lsmb->{pear}, 2, 'merge: No key, added pear');
 is($lsmb->{peach}, 3, 'merge: No key, added peach');
 like($lsmb->{path}, qr#bin/(lynx|mozilla)#, 'merge: No key, left existing key');
 
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 $lsmb->merge({'apple' => 1, 'pear' => 2, 'peach' => 3}, 'index' => 1);
 is($lsmb->{apple_1}, 1, 'merge: Index 1, added apple as apple_1');
 is($lsmb->{pear_1}, 2, 'merge: Index 1, added pear as pear_1');
@@ -260,7 +247,7 @@ is($lsmb->{peach_1}, 3, 'merge: Index 1, added peach as peach_1');
 like($lsmb->{path}, qr#bin/(lynx|mozilla)#, 'merge: Index 1, left existing key');
 
 # $lsmb->is_allowed_role checks
-my $lsmb = LedgerSMB->new();
+$lsmb = LedgerSMB->new();
 $lsmb->{_roles} = ['apple', 'pear'];
 is($lsmb->is_allowed_role({allowed_roles => ['pear']}), 1, 
 	'is_allowed_role: allowed role');
diff --git a/t/43-dbtest.t b/t/43-dbtest.t
index 812c382b..9cc9fd15 100644
--- a/t/43-dbtest.t
+++ b/t/43-dbtest.t
@@ -1,11 +1,17 @@
 use Test::More;
 use strict;
 
-if (!defined $ENV{PGDATABASE}){
-	plan skip_all => 'PGDATABASE Environment Variable not set up';
+if (!defined $ENV{LSMB_TEST_DB}){
+	plan skip_all => 'Skipping all.  Told not to test db.';
 }
 else {
 	plan tests => 50;
+	if (defined $ENV{LSMB_NEW_DB}){
+		$ENV{PGDATABASE} = $ENV{LSMB_NEW_DB};
+	}
+	if (!defined $ENV{PGDATABASE}){
+		die "We were told to run tests, but no database specified!";
+        }
 }
 
 my @testscripts = qw(Account Business_type Company Draft Payment 
diff --git a/t/62-api.t b/t/62-api.t
new file mode 100644
index 00000000..0e897f35
--- /dev/null
+++ b/t/62-api.t
@@ -0,0 +1,76 @@
+BEGIN { 
+	use LedgerSMB;
+	use Test::More;
+	use LedgerSMB::Template;
+	use LedgerSMB::DBTest;
+}
+
+our $test_case_defs = {
+};
+
+if (defined $ENV{LSMB_TEST_DB}){
+	if (defined $ENV{LSMB_NEW_DB}){
+		$ENV{PGDATABASE} = $ENV{LSMB_NEW_DB};
+	}
+	if (!defined $ENV{PGDATABASE}){
+		die "Oops...  LSMB_TEST_DB set but no db selected!";
+	}
+	plan 'no_plan';
+} else {
+	plan skip_all => 'Skipping, LSMB_TEST_DB environment variable not set.';
+}
+
+do 't/data/62-request-data'; # Import test case hashes
+
+for (qw(	admin.pl     drafts.pl     login.pl      payment.pl      
+		report.pl    employee.pl   menu.pl       vendor.pl
+		customer.pl  inventory.pl  migration.pl  recon.pl        
+		vouchers.pl)){
+
+	do "$_";
+} # Import new code namespaces
+
+my $dbh = LedgerSMB::DBTest->connect("dbi:Pg:dbname=$ENV{PGDATABASE}", undef, undef);
+
+print scalar @$test_request_data ." test case scenarios defined";
+
+for my $test (@$test_request_data){
+	if (lc $test->{_codebase} eq 'old'){
+		old_code_test::_load_script($test->{module});
+		$old_code_test::form = new Form();
+		for (keys (%$test)){
+			$form->{$_} = $test->{$_};
+		}
+		ok(eval ("old_code_test::$test->{action}()"), 
+			"$test->{_test_id}: Action Successful");
+	} else {
+		my $request = LedgerSMB->new();
+		$request->merge($test);
+		my $script = $test->{module};
+		$script =~ s/\.pl$//;
+		ok(eval "LedgerSMB::Scripts::$script::$request->{action}(\$request)");
+	}
+	for (@{$test_case_defs->{"$test->{_test_id}"}}){
+		&$_;
+	}
+	ok($dbh->rollback, "$test->{_test_id}: rollback");
+}
+
+package LedgerSMB::Template;
+
+# Don't render templates.  Just return so we can run tests on data structures.
+sub render {
+	return 1;
+}
+
+package old_code_test;
+# Keeps old code isolated in a different namespace, and provides for reasonable 
+# reload facilities.
+our $form;
+
+sub _load_script {
+	do "bin/arapprn.pl";
+	do "bin/arap.pl";
+	do "bin/io.pl";
+	do "bin/$1[0]";
+}
diff --git a/t/63-lwp.t b/t/63-lwp.t
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/t/63-lwp.t
diff --git a/t/data/62-request-data b/t/data/62-request-data
new file mode 100644
index 00000000..ae8c6d0e
--- /dev/null
+++ b/t/data/62-request-data
@@ -0,0 +1,58 @@
+
+our $test_request_data = [
+	# AR/AP Transaction Screen Tests
+	{
+		'_test_id'  => 'AR Transaction Screen',
+		'_codebase' => 'old',
+		'module'    => 'ar.pl',
+		'action'    => 'add'
+	},
+	{
+		'_test_id'  => 'AP Transaction Screen',
+		'_codebase' => 'old',
+		'module'    => 'ap.pl',
+		'action'    => 'add'
+	},
+	# Create Batch Screens
+	{
+		'_test_id'   => 'AR Transaction Voucher Screen',
+		'_codebase'  => 'new',
+		'action'     => 'create_batch',
+		'batch_type' => 'recievable',
+		'module'     => 'vouchers.pl',
+	},
+	{
+		'_test_id'   => 'AP Transaction Voucher Screen',
+		'_codebase'  => 'new',
+		'action'     => 'create_batch',
+		'batch_type' => 'payable',
+		'module'     => 'vouchers.pl',
+	},
+	{
+		'_test_id'   => 'Payment Transaction Voucher Screen',
+		'_codebase'  => 'new',
+		'action'     => 'create_batch',
+		'batch_type' => 'payment',
+		'module'     => 'vouchers.pl',
+	},
+	{
+		'_test_id'   => 'Payment Reversal Transaction Voucher Screen',
+		'_codebase'  => 'new',
+		'action'     => 'create_batch',
+		'batch_type' => 'payment_reversal',
+		'module'     => 'vouchers.pl',
+	},
+	{
+		'_test_id'   => 'GL Transaction Voucher Screen',
+		'_codebase'  => 'new',
+		'action'     => 'create_batch',
+		'batch_type' => 'gl',
+		'module'     => 'vouchers.pl',
+	},
+];
+
+
+opendir (D62, 't/data/62.d');
+for my $testfile (readdir(D62)){
+	do "t/data/62.d/$testfile";
+};