From 649c883728fd4dcfc830aaa0a19ae82405ff2697 Mon Sep 17 00:00:00 2001
From: Andreas Romeyke <andreas.romeyke@slub-dresden.de>
Date: Thu, 16 Feb 2023 11:12:23 +0100
Subject: [PATCH] - added xtra tests
---
xt/cleannamespaces.t | 9 ++
xt/compile.t | 29 ++++++
xt/eol.t | 8 ++
xt/fixme.t | 15 ++++
xt/no_nested_exists.t | 71 +++++++++++++++
xt/no_use_v5xxx.t | 25 ++++++
xt/nodiagnostics.t | 24 +++++
xt/portability.t | 48 ++++++++++
xt/unused_subroutines.t | 193 ++++++++++++++++++++++++++++++++++++++++
9 files changed, 422 insertions(+)
create mode 100644 xt/cleannamespaces.t
create mode 100644 xt/compile.t
create mode 100644 xt/eol.t
create mode 100644 xt/fixme.t
create mode 100644 xt/no_nested_exists.t
create mode 100644 xt/no_use_v5xxx.t
create mode 100644 xt/nodiagnostics.t
create mode 100644 xt/portability.t
create mode 100644 xt/unused_subroutines.t
diff --git a/xt/cleannamespaces.t b/xt/cleannamespaces.t
new file mode 100644
index 0000000..2b8d923
--- /dev/null
+++ b/xt/cleannamespaces.t
@@ -0,0 +1,9 @@
+use strict;
+use warnings;
+use Test::More;
+plan skip_all => "Test::CleanNamespaces required for testing module namespaces"
+ unless eval "use Test::CleanNamespaces; 1";
+my @modules = Test::CleanNamespaces->find_modules;
+namespaces_clean( @modules );
+done_testing;
+1;
\ No newline at end of file
diff --git a/xt/compile.t b/xt/compile.t
new file mode 100644
index 0000000..10d3594
--- /dev/null
+++ b/xt/compile.t
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+use Test::More;
+use Perl::Version;
+my $required_module_version = '2.3.1';
+
+
+plan skip_all => "Test::Compile required for testing file compileabilty"
+ unless eval "use Test::Compile; 1";
+plan skip_all => "Test::Compile version $required_module_version required because fixed prove compatibility"
+ unless (Perl::Version->new($Test::Compile::VERSION) >= Perl::Version->new($required_module_version));
+
+my $test = Test::Compile->new();
+$test->verbose => undef;
+
+
+my @modules = $test->all_pm_files("lib");
+my @binaries = $test->all_pl_files("bin", "example_scripts");
+
+my $tests = scalar(@modules) + scalar(@binaries);
+plan tests => $tests;
+foreach my $file (@modules) {
+ ok($test->pm_file_compiles($file), "checking file $file");
+}
+foreach my $file (@binaries) {
+ ok($test->pl_file_compiles($file), "checking file $file");
+}
+
+1;
\ No newline at end of file
diff --git a/xt/eol.t b/xt/eol.t
new file mode 100644
index 0000000..6f0ffdb
--- /dev/null
+++ b/xt/eol.t
@@ -0,0 +1,8 @@
+use strict;
+use warnings;
+use Test::More;
+use Path::Tiny;
+plan skip_all => "Test::EOL required for testing filenames portability"
+ unless eval "use Test::EOL; 1";
+my @whitelist_dirs = path('.')->children( qr/^(?!(cpan_build$|build$|.git$))/ );
+all_perl_files_ok( @whitelist_dirs );
\ No newline at end of file
diff --git a/xt/fixme.t b/xt/fixme.t
new file mode 100644
index 0000000..a002945
--- /dev/null
+++ b/xt/fixme.t
@@ -0,0 +1,15 @@
+use strict;
+use warnings;
+use Test::More;
+BEGIN {
+ plan skip_all => "these tests are for release candidate testing\n(enable it with RELEASE_TESTING=1)"
+ unless $ENV{RELEASE_TESTING};
+}
+plan skip_all => "Test::Fixme required for testing unresolved FIXME or TODO issues"
+ unless eval "use Test::Fixme; 1";
+run_tests(
+ where => 'lib',
+ match => qr/# *(TODO|FIXME|BUG)\b/i,
+ filename_match => qr/\.(pm|pl)$/
+);
+1;
\ No newline at end of file
diff --git a/xt/no_nested_exists.t b/xt/no_nested_exists.t
new file mode 100644
index 0000000..bae0815
--- /dev/null
+++ b/xt/no_nested_exists.t
@@ -0,0 +1,71 @@
+#search all modules as file paths
+use strict;
+use warnings;
+use File::Find;
+use Path::Tiny;
+use Test::More;
+
+my @modules;
+sub wanted {
+ $File::Find::name =~ m#SLUB/LZA/.+\.pm$# && -f $_ && push @modules, $File::Find::name;
+}
+find(\&wanted, "lib/");
+
+# allowed: exists $foo->{$bar}
+# allowed: exists $foo->{$bar} and exists $foo->{$bar}->{$baz}
+# forbidden: exists $foo->{$bar}->{$baz}
+#my $rx_exists=qr{(?!(&&|and) *)(?<=exists)};
+#my $rx_hash_or_hashref=qr/(\$[a-z_]+)((->)?{[^}]*})((->)?{[^}]*})/;
+#my $regex_match=qr/$rx_exists $rx_hash_or_hashref/;
+use diagnostics;
+foreach my $module (@modules) {
+ my @lines = path($module)->lines;
+ my $errors = 0;
+ for (my $i=0; $i<=$#lines; $i++) {
+ next unless $lines[$i]=~m/exists/;
+ my $reversed_line = reverse scalar $lines[$i];
+ # aus "exists $foo->{bar}->{baz}"
+ # wird "}zab{>-}rab{>-oof$ stsixe"
+ # aus "exists $foo->{bar} and exists $foo->{bar}->{baz}"
+ # wird "}zab{>-}rab{>-oof$ stsixe dna }rab{>-oof$ stsixe"
+ # damit haben wir mit Trenner ' dna ' folgende Teilstrings:
+ # "}zab{>-}rab{>-oof$ stsixe" und
+ # "}rab{>-oof$ stsixe"
+ # Damit können wir nach Teilstrings suchen
+ # my $ref = qr/\}[^{]*{/;
+ # m/($ref>-)($ref>-){1,}[a-z]*\$/ würde auf den Hashref matchen, in $1 hätten wir Treffer für n-ten Hashref-teil, in $2 Treffer für Rest
+ # was wir fordern, ist, dass lookahead der Rest mit ' dna ' verbunden ist:
+ # m/($ref>-)($ref>-){1,}([a-z]*\$)(?= dna $2$3)/g
+ my $rx_ref = qr/\}[^{]*{/;
+ no warnings;
+ if ($reversed_line=~m/($rx_ref(?:>-)?)($rx_ref(?:>-)?){1,}([a-z]*\$ stsixe)(?! dna $2$3)/g) {
+ use warnings;
+ #print "line=$lines[$i]\n";
+ my $lineno = $i + 1;
+ $errors++;
+ my $match1 = reverse scalar $1;
+ my $match2 = reverse scalar $2;
+ my $match3 = reverse scalar $3;
+ fail("module $module uses 'exists' on nested hash or hashrefs, but this is dangerous,
+ because values will be generated, see 'perldoc -f exists' for details.
+ Here the problematic code:
+ ---------- snip ---------
+ $match3$match2$match1
+ ---------- snap ---------
+ (line $lineno)
+ better use pattern like this:
+ ---------- snip ---------
+ $match3$match2 and $match3$match2$match1
+ ---------- snap ---------
+
+");
+
+ }
+ }
+ if ($errors == 0) {
+ pass("module $module");
+ }
+}
+
+done_testing();
+1;
diff --git a/xt/no_use_v5xxx.t b/xt/no_use_v5xxx.t
new file mode 100644
index 0000000..2b39d71
--- /dev/null
+++ b/xt/no_use_v5xxx.t
@@ -0,0 +1,25 @@
+use strict;
+use warnings;
+use Test::More;
+use File::Find;
+use Path::Tiny;
+
+
+#search all modules as file paths
+my @modules;
+sub wanted {
+ $File::Find::name=~ m#SLUB/LZA/.+\.pm$# && -f $_ && push @modules, $File::Find::name;
+}
+find(\&wanted, "lib/");
+
+foreach my $module (@modules) {
+ my $content = path( $module )->slurp;
+ if ($content =~ m/^use v(5\.\d\d);/m) {
+ fail("module $module has 'use v$1;', you should use 'use feature qw(...);' instead.");
+ } else {
+ pass("module $module is fine.");
+ }
+}
+
+done_testing();
+1;
diff --git a/xt/nodiagnostics.t b/xt/nodiagnostics.t
new file mode 100644
index 0000000..7aefebf
--- /dev/null
+++ b/xt/nodiagnostics.t
@@ -0,0 +1,24 @@
+use strict;
+use warnings;
+use Test::More;
+use File::Find;
+use Path::Tiny;
+
+
+#search all modules as file paths
+my @modules;
+sub wanted {
+ $File::Find::name=~ m#SLUB/LZA/.+\.(pm|t)$# && -f $_ && push @modules, $File::Find::name;
+}
+find(\&wanted, "lib/", "t/");
+
+foreach my $module (@modules) {
+ my $content = path( $module )->slurp;
+ if ($content =~ m/^use diagnostics;/m) {
+ fail("module $module has 'use diagnostics;', but should only be used for debugging. It could be enabled via 'perl -Mdiagnostics=-traceonly my_script.pl'");
+ } else {
+ pass("module $module is fine.");
+ }
+}
+done_testing();
+1;
diff --git a/xt/portability.t b/xt/portability.t
new file mode 100644
index 0000000..b35ee1c
--- /dev/null
+++ b/xt/portability.t
@@ -0,0 +1,48 @@
+use strict;
+use warnings;
+use Test::More;
+use Path::Tiny;
+
+plan skip_all => "Test::Portability::Files required for testing filenames portability"
+ unless eval "use Test::Portability::Files; 1";
+
+#options(all_tests => 1); # to be hyper-strict
+options(
+ #test_mac_length => 1,
+ test_space => 1,
+ test_symlink => 1,
+ test_special_chars => 1,
+ test_windows_reserved => 1,
+ test_case => 1,
+);
+my $manifestfile;
+BEGIN{
+ # prepare, because we want to check only *.t an *.pm and *.pl files
+ use File::Find;
+ my $module_base_dir = path(__FILE__)->parent->parent;
+
+ my $lib_dir = $module_base_dir->child("lib");
+ my $t_dir = $module_base_dir->child("t");
+ $manifestfile = $module_base_dir->child("MANIFEST")->absolute();
+ if ($manifestfile->is_file) {
+ $manifestfile->remove();
+ }
+
+ sub wanted {
+ m/.*\.(p[ml]|t)$/ &&
+ -f _ &&
+ $manifestfile->append($File::Find::name) &&
+ $manifestfile->append("\n");
+ }
+ find(\&wanted, $lib_dir->stringify, $t_dir->stringify);
+
+}
+# tests
+run_tests();
+
+#clean up
+if ($manifestfile->is_file) {
+ $manifestfile->remove();
+
+}
+1;
\ No newline at end of file
diff --git a/xt/unused_subroutines.t b/xt/unused_subroutines.t
new file mode 100644
index 0000000..61d9a4c
--- /dev/null
+++ b/xt/unused_subroutines.t
@@ -0,0 +1,193 @@
+use strict;
+use warnings;
+use Test::More;
+use File::Find;
+use Path::Tiny;
+use List::Util;
+
+BEGIN {
+ plan skip_all => "these tests are for release candidate testing\n(enable it with RELEASE_TESTING=1)"
+ unless $ENV{RELEASE_TESTING};
+}
+# only finds first depth of derived classes!
+
+#search all modules as file paths
+my @modules;
+my @binaries;
+
+# find all Perl-Module paths
+sub wantedpm {
+ $File::Find::name=~ m#SLUB/LZA/.+\.pm$# && -f $_ && push @modules, $File::Find::name;
+}
+
+# find all Perl-Script paths
+sub wantedpl {
+ $File::Find::name=~ m#\.pl$# && -f $_ && push @binaries, $File::Find::name;
+}
+
+sub _find_used_modules {
+ my $module_or_binary = shift;
+ my @content = path( $module_or_binary )->lines({chomp=>1});
+ my @used_modules;
+ foreach my $line (@content) {
+ if ( $line =~ m/use ([A-Za-z0-9:]+)\b/ ) {
+ push @used_modules, $1;
+ } elsif ($line =~ m/with ['"]([A-Za-z0-9:]+)["'];/) {
+ push @used_modules, $1;
+ }
+ }
+ my $contents = join("", @content);
+ if ($contents =~ m/with qw\s*[(]([A-Za-z0-9: ]+)[)];/m) {
+ my @found_modules = grep {length($_) > 1} split(/ +/, $1);
+ push @used_modules, @found_modules;
+ }
+ return @used_modules;
+}
+
+# maps Module-Paths to Module-namespace
+sub modulepath_to_moduleuse { # maps lib/Foo/Bar/Baz.pm to Foo::Bar::Baz
+ my $module_path = shift;
+ my $module = $module_path;
+ $module =~ s#lib/##;
+ $module =~ s#\.pm$##;
+ $module =~ s#/#::#g;
+ return $module;
+}
+
+# find all subs which are exported by a Module-path
+sub get_exported_subs {
+ my $module_path = shift;
+ my $module = modulepath_to_moduleuse($module_path);
+ my $code_string = "use $module; return grep {defined &{\"${module}::\$_\"} } keys \%${module}::;";
+ no strict 'refs';
+ my @modules = eval "\@${module}::EXPORT;";
+ my @exported = grep {$_=~m/^[a-z_]/} eval $code_string;
+ use strict 'refs';
+ if (scalar @exported == 0) {
+ return @exported
+ };
+ return @modules;
+}
+
+find(\&wantedpm, "lib/");
+find(\&wantedpl, "bin");
+
+
+my %subs;
+# MODULE -> delivers METHOD -> USED BY -> with COUNT
+my %required; # special case for moose roles
+# ROLE -> sub -> count
+my %has_exported; # to check if module has used Export.pm
+
+# first find all subs
+# read each module and search for a sub definition, build hash %subs
+foreach my $module (@modules) {
+ if (List::Util::any {m/use Exporter/} path( $module )->lines({chomp=>1}) ) {
+ $has_exported{ $module } = 1;
+ }
+ my @content = grep {/^\s*sub\s+/} path( $module )->lines({chomp=>1});
+ foreach my $line (@content) {
+ if ($line=~ m/^\s*sub\s+([_A-Za-z0-9:]+)/) {
+ my $sub = $1;
+ if (defined $sub && length $sub > 1) {
+ my $use = modulepath_to_moduleuse($module);
+ $subs{$use}{$sub}=undef;
+ }
+ }
+ }
+}
+
+# find required (Moose)
+foreach my $module (@modules) {
+ my $content = path( $module )->slurp;
+ if (
+ ($content=~m/use Moose/) &&
+ ($content=~m#requires\s*\(([^\)]*)\)#mx)
+ ) {
+ my $requires = $1;
+ #p($requires);
+ my @subs = split /,/, $requires;
+ @subs = grep {defined $_ && length $_ > 0} map {
+ s/\s*//g;
+ s/'//g;
+ $_;
+ } @subs;
+ foreach my $require (@subs) {
+ $required{modulepath_to_moduleuse($module)}{$require}++;
+ }
+ }
+}
+# second find which modules are used
+foreach my $module_or_binary (@modules, @binaries) {
+ # find all used modules
+ my @used_modules = _find_used_modules( $module_or_binary);
+ push @used_modules, modulepath_to_moduleuse($module_or_binary); # check itself
+ my @content = path( $module_or_binary )->lines({chomp=>1});
+ foreach my $line (@content) {
+ foreach my $um (@used_modules) {
+ foreach my $sub (keys %{$subs{$um}}) {
+ if ($line =~ m/$sub/) {
+# print STDERR "um=$um, sub=$sub, module=$module_or_binary line=$line\n";
+ $subs{$um}{$sub}{$module_or_binary}++; # add self used
+ }
+ }
+ }
+ }
+}
+# check also if parent obj class uses required
+foreach my $module_or_binary (@modules) {
+ # find all used modules
+ my @used_modules = _find_used_modules($module_or_binary);
+ foreach my $parent (@used_modules) {
+ next unless exists $required{ $parent};
+ foreach my $sub (keys %{$required{$parent}}) {
+ #warn "found parent class $parent of $module_or_binary with sub $sub\n";
+ if ($sub =~ m/^_build/) {
+ # workaround, build methods only visibly used in parent
+ }
+ $subs{modulepath_to_moduleuse($module_or_binary)}{$sub}{$module_or_binary}++;
+ }
+ }
+}
+# now print unused modules
+foreach my $module (sort @modules) {
+ my $use = modulepath_to_moduleuse($module);
+ if ($use =~ m/SLUB::LZA::Rosetta::API$/) {
+ pass "module '$module', because 1:1 API mapping";
+ next;
+ }
+ my $res=1;
+ my @exported_subs = get_exported_subs( $module);
+ my $is_exported = exists $has_exported{ $module };
+ foreach my $sub (sort keys %{$subs{$use}}) {
+ if ($sub =~ m/DEMOLISH/) { next;} # perlish subroutines
+ if ($sub =~ m/BUILD/) { next;} # moose-ish subroutines
+ if ($sub =~ m/get_dotgraph/) {next;} # needed for doc/, make fsm.svg to control FSM in Eventcallback
+ my $all_used = 0;
+ # reduce all exported matches
+ foreach my $where_used_path (sort keys %{ $subs{$use}{$sub} }) {
+ my $where_used = modulepath_to_moduleuse($where_used_path);
+ if ($where_used eq $use) {
+ $all_used--; # reduce by one because self-match 'sub foo…'
+ my $test_if_exported = $is_exported && (List::Util::any {$_ eq $sub} @exported_subs);
+ if ($test_if_exported) {
+ $all_used--;
+ } # reduce by one because exported via Exporter-module
+ }
+ $all_used+= $subs{$use}{$sub}{$where_used_path};
+ }
+ if ($all_used <1) {
+ $res = undef;
+ fail "module '$module', subroutine '$sub' unused or module not imported via 'use $use;'";
+ #print "-------------------\n";
+ #use Data::Printer; p( $subs{$use}{$sub} );
+ #print "module '$module' has exported: ", ($is_exported?"yes":"no"), "\n";
+ #print "module '$module' has ff. functions (outside callable): \n\t", join("\n\t", @exported_subs), "\n";
+
+ }
+ } if ($res) {
+ pass "module '$module', all subroutines used";
+ }
+}
+done_testing();
+1;
--
GitLab