scripts/t: Improve test coverage

debian/changelog

@@ -16,6 +16,8 @@ dpkg (1.18.4) UNRELEASED; urgency=low
   * Make dpkg-architecture warning on non-matching GNU system type compiler
     agnostic.
   * Add ‘.gitreview’ to the default dpkg-source ignore lists.
+  * Test suite:
+    - Improve perl code test coverage.
   * Build system:
     - Set PERL5LIB globally for the test suite to the local modules directory,
       to avoid using the system modules. Regression introduced in dpkg 1.17.8.

scripts/t/Dpkg_Arch.t

@@ -16,10 +16,14 @@
 use strict;
 use warnings;
 
-use Test::More tests => 42;
+use Test::More tests => 53;
 
 use_ok('Dpkg::Arch', qw(debarch_to_debtriplet debarch_to_multiarch
-                        debarch_eq debarch_is debarch_is_wildcard));
+                        debarch_eq debarch_is debarch_is_wildcard
+                        debarch_to_cpuattrs
+                        debtriplet_to_debarch gnutriplet_to_debarch
+                        get_host_gnu_type
+                        get_valid_arches));
 
 my @tuple_new;
 my @tuple_ref;
@@ -83,4 +87,26 @@ ok(debarch_is_wildcard('gnu-any-any'), '<abi>-any-any is a wildcard');
 ok(debarch_is_wildcard('any-linux-any'), 'any-<os>-any is a wildcard');
 ok(debarch_is_wildcard('any-any-amd64'), 'any-any-<cpu> is a wildcard');
 
+is(debarch_to_cpuattrs(undef), undef, 'undef cpu attrs');
+is_deeply([ debarch_to_cpuattrs('amd64') ], [ qw(64 little) ], 'amd64 cpu attrs');
+
+is(debtriplet_to_debarch(undef, undef, undef), undef, 'undef debtriplet');
+is(debtriplet_to_debarch('gnu', 'linux', 'amd64'), 'amd64', 'known debtriplet');
+is(debtriplet_to_debarch('unknown', 'unknown', 'unknown'), undef, 'unknown debtriplet');
+
+is(gnutriplet_to_debarch(undef), undef, 'undef gnutriplet');
+is(gnutriplet_to_debarch('unknown-unknown-unknown'), undef, 'unknown gnutriplet');
+is(gnutriplet_to_debarch('x86_64-linux-gnu'), 'amd64', 'known gnutriplet');
+
+is(scalar get_valid_arches(), 403, 'expected amount of known architectures');
+
+{
+    local $ENV{CC} = 'false';
+    is(get_host_gnu_type(), '', 'CC does not support -dumpmachine');
+
+    $ENV{CC} = 'echo CC';
+    is(get_host_gnu_type(), 'CC -dumpmachine',
+       'CC does not report expected synthetic result for -dumpmachine');
+}
+
 1;

scripts/t/Dpkg_BuildEnv.t

@@ -16,12 +16,35 @@
 use strict;
 use warnings;
 
-use Test::More tests => 1;
+use Test::More tests => 14;
 
 BEGIN {
     use_ok('Dpkg::BuildEnv');
 }
 
-# TODO: Add actual test cases.
+$ENV{DPKG_TEST_VAR_A} = 100;
+$ENV{DPKG_TEST_VAR_B} = 200;
+delete $ENV{DPKG_TEST_VAR_Z};
+
+is(scalar Dpkg::BuildEnv::list_accessed(), 0, 'no accessed variables');
+is(scalar Dpkg::BuildEnv::list_modified(), 0, 'no modified variables');
+
+is(Dpkg::BuildEnv::get('DPKG_TEST_VAR_A'), 100, 'get value');
+
+is(scalar Dpkg::BuildEnv::list_accessed(), 1, '1 accessed variables');
+is(scalar Dpkg::BuildEnv::list_modified(), 0, 'no modified variables');
+
+is(Dpkg::BuildEnv::get('DPKG_TEST_VAR_B'), 200, 'get value');
+Dpkg::BuildEnv::set('DPKG_TEST_VAR_B', 300);
+is(Dpkg::BuildEnv::get('DPKG_TEST_VAR_B'), 300, 'set value');
+
+is(scalar Dpkg::BuildEnv::list_accessed(), 2, '2 accessed variables');
+is(scalar Dpkg::BuildEnv::list_modified(), 1, '1 modified variable');
+
+ok(Dpkg::BuildEnv::has('DPKG_TEST_VAR_A'), 'variables is present');
+ok(!Dpkg::BuildEnv::has('DPKG_TEST_VAR_Z'), 'variables is not present');
+
+is(scalar Dpkg::BuildEnv::list_accessed(), 3, '2 accessed variables');
+is(scalar Dpkg::BuildEnv::list_modified(), 1, '1 modified variable');
 
 1;

scripts/t/Dpkg_BuildFlags.t

@@ -16,12 +16,37 @@
 use strict;
 use warnings;
 
-use Test::More tests => 1;
+use Test::More tests => 15;
 
 BEGIN {
     use_ok('Dpkg::BuildFlags');
 }
 
-# TODO: Add actual test cases.
+my $bf = Dpkg::BuildFlags->new();
+
+ok($bf->has('CPPFLAGS'), 'CPPFLAGS is present');
+is($bf->get_origin('CPPFLAGS'), 'vendor', 'CPPFLAGS has a vendor origin');
+
+$bf->set('DPKGFLAGS', '-Wflag -On -fsome', 'system');
+is($bf->get('DPKGFLAGS'), '-Wflag -On -fsome', 'get flag');
+is($bf->get_origin('DPKGFLAGS'), 'system', 'flag has a system origin');
+ok(!$bf->is_maintainer_modified('DPKGFLAGS'), 'set marked flag as non-maint modified');
+
+$bf->strip('DPKGFLAGS', '-On', 'user', undef);
+is($bf->get('DPKGFLAGS'), '-Wflag -fsome', 'get stripped flag');
+is($bf->get_origin('DPKGFLAGS'), 'user', 'flag has a user origin');
+ok(!$bf->is_maintainer_modified('DPKGFLAGS'), 'strip marked flag as non-maint modified');
+
+$bf->append('DPKGFLAGS', '-Wl,other', 'vendor', 0);
+is($bf->get('DPKGFLAGS'), '-Wflag -fsome -Wl,other', 'get appended flag');
+is($bf->get_origin('DPKGFLAGS'), 'vendor', 'flag has a vendor origin');
+ok(!$bf->is_maintainer_modified('DPKGFLAGS'), 'append marked flag as non-maint modified');
+
+$bf->prepend('DPKGFLAGS', '-Idir', 'env', 1);
+is($bf->get('DPKGFLAGS'), '-Idir -Wflag -fsome -Wl,other', 'get prepended flag');
+is($bf->get_origin('DPKGFLAGS'), 'env', 'flag has an env origin');
+ok($bf->is_maintainer_modified('DPKGFLAGS'), 'prepend marked flag as maint modified');
+
+# TODO: Add more test cases.
 
 1;

scripts/t/Dpkg_BuildProfiles.t

@@ -16,10 +16,12 @@
 use strict;
 use warnings;
 
-use Test::More tests => 6;
+use Test::More tests => 8;
 
 BEGIN {
-    use_ok('Dpkg::BuildProfiles', qw(parse_build_profiles));
+    use_ok('Dpkg::BuildProfiles', qw(parse_build_profiles
+                                     set_build_profiles
+                                     get_build_profiles));
 }
 
 # TODO: Add actual test cases.
@@ -46,4 +48,14 @@ $formula = [ [ qw(nocheck nodoc) ], [ qw(stage1) ] ];
 is_deeply([ parse_build_profiles('<nocheck nodoc> <stage1>') ], $formula,
     'parse build profiles formula AND, OR');
 
+{
+    local $ENV{DEB_BUILD_PROFILES} = 'cross nodoc profile.name';
+    is_deeply([ get_build_profiles() ], [ qw(cross nodoc profile.name) ],
+        'get active build profiles from environment');
+}
+
+set_build_profiles(qw(nocheck stage1));
+is_deeply([ get_build_profiles() ], [ qw(nocheck stage1) ],
+    'get active build profiles explicitly set');
+
 1;

scripts/t/Dpkg_Dist_Files.t

@@ -16,7 +16,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 24;
+use Test::More tests => 25;
 
 use_ok('Dpkg::Dist::Files');
 
@@ -107,6 +107,8 @@ foreach my $f ($dist->get_files()) {
               "Detail for individual dist file $filename, via get_file()");
 }
 
+is($dist->parse_filename('file%invalid'), undef, 'invalid filename');
+
 $expected = <<'FILES';
 BY-HAND-file webdocs optional
 added-on-the-fly void wish

scripts/t/Dpkg_Exit.t

@@ -16,12 +16,43 @@
 use strict;
 use warnings;
 
-use Test::More tests => 1;
+use Test::More tests => 5;
 
 BEGIN {
     use_ok('Dpkg::Exit');
 }
 
-# TODO: Add actual test cases.
+my $track = 0;
+
+sub test_handler {
+    $track++;
+}
+
+Dpkg::Exit::run_exit_handlers();
+
+is($track, 0, 'no handlers run');
+
+Dpkg::Exit::push_exit_handler(\&test_handler);
+Dpkg::Exit::pop_exit_handler();
+
+Dpkg::Exit::run_exit_handlers();
+
+is($track, 0, 'push/pop; no handlers run');
+
+Dpkg::Exit::push_exit_handler(\&test_handler);
+
+Dpkg::Exit::run_exit_handlers();
+
+is($track, 1, 'push; handler run');
+
+# Check the exit handlers, must be the last thing done.
+sub exit_handler {
+    pass('exit handler invoked');
+    exit 0;
+}
+
+Dpkg::Exit::push_exit_handler(\&exit_handler);
+
+kill 'INT', $$;
 
 1;

scripts/t/Dpkg_Package.t

@@ -16,7 +16,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 6;
+use Test::More tests => 7;
 
 use_ok('Dpkg::Package');
 
@@ -26,4 +26,6 @@ ok(pkg_name_is_illegal('%_&'), 'package name has invalid chars');
 ok(pkg_name_is_illegal('ABC'), 'package name has uppercase chars');
 ok(pkg_name_is_illegal('-abc'), 'package name has a dash');
 
+is(pkg_name_is_illegal('pkg+name-1.0'), undef, 'package name is valid');
+
 1;

scripts/t/Dpkg_Substvars.t

@@ -16,7 +16,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 35;
+use Test::More tests => 37;
 
 use Dpkg ();
 use Dpkg::Arch qw(get_host_arch);
@@ -38,6 +38,17 @@ is($s->get('var2'), 'Some other value', 'var2');
 is($s->get('var3'), 'Yet another value', 'var3');
 is($s->get('var4'), undef, 'no var4');
 
+# Set automatic variable
+$s->set_as_auto('var_auto', 'auto');
+is($s->get('var_auto'), 'auto', 'get var_auto');
+
+$expected = <<'VARS';
+var1=Some value
+var2=Some other value
+var3=Yet another value
+VARS
+is($s->output(), $expected, 'No automatic variables output');
+
 # overriding
 $s->set('var1', 'New value');
 is($s->get('var1'), 'New value', 'var1 updated');
@@ -76,14 +87,18 @@ is($s->substvars('This is a string ${var1} with variables ${binary:Version}'),
                  'This is a string New value with variables 1:2.3.4~5-6.7.8~nmu9+b0',
                  'substvars simple');
 
+# Add a test prefix to error and warning messages.
+$s->set_msg_prefix('test ');
+
 my $output;
 $SIG{__WARN__} = sub { $output .= $_[0] };
 is($s->substvars('This is a string with unknown variable ${blubb}'),
                  'This is a string with unknown variable ',
                  'substvars missing');
 delete $SIG{__WARN__};
-is($output, 'Dpkg_Substvars.t: warning: unknown substitution variable ${blubb}'."\n"
-          , 'missing variables warning');
+is($output,
+   'Dpkg_Substvars.t: warning: test unknown substitution variable ${blubb}' . "\n",
+   'missing variables warning');
 
 # Recursive replace
 $s->set('rvar', 'recursive ${var1}');
@@ -101,10 +116,12 @@ $output = '';
 $SIG{__WARN__} = sub { $output .= $_[0] };
 $s->warn_about_unused();
 delete $SIG{__WARN__};
-is($output, "Dpkg_Substvars.t: warning: unused substitution variable \${var2}\n",
-          , 'unused variables warnings');
+is($output,
+   'Dpkg_Substvars.t: warning: test unused substitution variable ${var2}' . "\n",
+   'unused variables warnings');
 
 # Disable warnings for a certain variable
+$s->set_as_used('var_used', 'used');
 $s->mark_as_used('var2');
 $output = '';
 $SIG{__WARN__} = sub { $output .= $_[0] };
@@ -112,6 +129,8 @@ $s->warn_about_unused();
 delete $SIG{__WARN__};
 is($output, '', 'disabled unused variables warnings');
 
+$s->delete('var_used');
+
 # Variable filters
 my $sf;
 

scripts/t/Dpkg_Vars.t

@@ -16,12 +16,23 @@
 use strict;
 use warnings;
 
-use Test::More tests => 1;
+use Test::More tests => 6;
 
 BEGIN {
     use_ok('Dpkg::Vars');
 }
 
-# TODO: Add actual test cases.
+eval { set_source_package('foo%bar') };
+ok($@, 'cannot set invalid source package name');
+is(get_source_package(), undef, 'invalid source package name unset');
+
+set_source_package('source');
+is(get_source_package(), 'source', 'set/get source package name');
+
+set_source_package('source');
+is(get_source_package(), 'source', 'reset/get same source package name');
+
+eval { set_source_package('other') };
+ok($@, 'cannot set different source package name');
 
 1;

scripts/t/Dpkg_Version.t

@@ -30,7 +30,7 @@ my @ops = ('<', '<<', 'lt',
 	   '>=', 'ge',
 	   '>', '>>', 'gt');
 
-plan tests => scalar(@tests) * (3 * scalar(@ops) + 4) + 13;
+plan tests => scalar(@tests) * (3 * scalar(@ops) + 4) + 18;
 
 sub dpkg_vercmp {
      my ($a, $cmp, $b) = @_;
@@ -100,6 +100,18 @@ ok(!$ver->is_valid(), 'version does not start with digit 1/2');
 $ver = Dpkg::Version->new('0:foo5.2');
 ok(!$ver->is_valid(), 'version does not start with digit 2/2');
 
+# Native and non-native versions
+$ver = Dpkg::Version->new('1.0');
+ok($ver->is_native(), 'upstream version is native');
+$ver = Dpkg::Version->new('1:1.0');
+ok($ver->is_native(), 'upstream version w/ epoch is native');
+$ver = Dpkg::Version->new('1:1.0:1.0');
+ok($ver->is_native(), 'upstream version w/ epoch and colon is native');
+$ver = Dpkg::Version->new('1.0-1');
+ok(!$ver->is_native(), 'upstream version w/ revision is not native');
+$ver = Dpkg::Version->new('1.0-1.0-1');
+ok(!$ver->is_native(), 'upstream version w/ dash and revision is not native');
+
 # Other tests
 $ver = Dpkg::Version->new('1.2.3-4');
 is($ver || 'default', '1.2.3-4', 'bool eval returns string representation');