+sub self_test {
+ my @lsfiles = ();
+ my @good_links = ();
+ my @bad_links = ();
+ my @section_headers = ();
+ my $index = 0;
+
+ @lsfiles = vcs_list_files($lk_path);
+
+ for my $x (@self_test_info) {
+ $index++;
+
+ ## Section header duplication and missing section content
+ if (($self_test eq "" || $self_test =~ /\bsections\b/) &&
+ $x->{line} =~ /^\S[^:]/ &&
+ defined $self_test_info[$index] &&
+ $self_test_info[$index]->{line} =~ /^([A-Z]):\s*\S/) {
+ my $has_S = 0;
+ my $has_F = 0;
+ my $has_ML = 0;
+ my $status = "";
+ if (grep(m@^\Q$x->{line}\E@, @section_headers)) {
+ print("$x->{file}:$x->{linenr}: warning: duplicate section header\t$x->{line}\n");
+ } else {
+ push(@section_headers, $x->{line});
+ }
+ my $nextline = $index;
+ while (defined $self_test_info[$nextline] &&
+ $self_test_info[$nextline]->{line} =~ /^([A-Z]):\s*(\S.*)/) {
+ my $type = $1;
+ my $value = $2;
+ if ($type eq "S") {
+ $has_S = 1;
+ $status = $value;
+ } elsif ($type eq "F" || $type eq "N") {
+ $has_F = 1;
+ } elsif ($type eq "M" || $type eq "R" || $type eq "L") {
+ $has_ML = 1;
+ }
+ $nextline++;
+ }
+ if (!$has_ML && $status !~ /orphan|obsolete/i) {
+ print("$x->{file}:$x->{linenr}: warning: section without email address\t$x->{line}\n");
+ }
+ if (!$has_S) {
+ print("$x->{file}:$x->{linenr}: warning: section without status \t$x->{line}\n");
+ }
+ if (!$has_F) {
+ print("$x->{file}:$x->{linenr}: warning: section without file pattern\t$x->{line}\n");
+ }
+ }
+
+ next if ($x->{line} !~ /^([A-Z]):\s*(.*)/);
+
+ my $type = $1;
+ my $value = $2;
+
+ ## Filename pattern matching
+ if (($type eq "F" || $type eq "X") &&
+ ($self_test eq "" || $self_test =~ /\bpatterns\b/)) {
+ $value =~ s@\.@\\\.@g; ##Convert . to \.
+ $value =~ s/\*/\.\*/g; ##Convert * to .*
+ $value =~ s/\?/\./g; ##Convert ? to .
+ ##if pattern is a directory and it lacks a trailing slash, add one
+ if ((-d $value)) {
+ $value =~ s@([^/])$@$1/@;
+ }
+ if (!grep(m@^$value@, @lsfiles)) {
+ print("$x->{file}:$x->{linenr}: warning: no file matches\t$x->{line}\n");
+ }
+
+ ## Link reachability
+ } elsif (($type eq "W" || $type eq "Q" || $type eq "B") &&
+ $value =~ /^https?:/ &&
+ ($self_test eq "" || $self_test =~ /\blinks\b/)) {
+ next if (grep(m@^\Q$value\E$@, @good_links));
+ my $isbad = 0;
+ if (grep(m@^\Q$value\E$@, @bad_links)) {
+ $isbad = 1;
+ } else {
+ my $output = `wget --spider -q --no-check-certificate --timeout 10 --tries 1 $value`;
+ if ($? == 0) {
+ push(@good_links, $value);
+ } else {
+ push(@bad_links, $value);
+ $isbad = 1;
+ }
+ }
+ if ($isbad) {
+ print("$x->{file}:$x->{linenr}: warning: possible bad link\t$x->{line}\n");
+ }
+
+ ## SCM reachability
+ } elsif ($type eq "T" &&
+ ($self_test eq "" || $self_test =~ /\bscm\b/)) {
+ next if (grep(m@^\Q$value\E$@, @good_links));
+ my $isbad = 0;
+ if (grep(m@^\Q$value\E$@, @bad_links)) {
+ $isbad = 1;
+ } elsif ($value !~ /^(?:git|quilt|hg)\s+\S/) {
+ print("$x->{file}:$x->{linenr}: warning: malformed entry\t$x->{line}\n");
+ } elsif ($value =~ /^git\s+(\S+)(\s+([^\(]+\S+))?/) {
+ my $url = $1;
+ my $branch = "";
+ $branch = $3 if $3;
+ my $output = `git ls-remote --exit-code -h "$url" $branch > /dev/null 2>&1`;
+ if ($? == 0) {
+ push(@good_links, $value);
+ } else {
+ push(@bad_links, $value);
+ $isbad = 1;
+ }
+ } elsif ($value =~ /^(?:quilt|hg)\s+(https?:\S+)/) {
+ my $url = $1;
+ my $output = `wget --spider -q --no-check-certificate --timeout 10 --tries 1 $url`;
+ if ($? == 0) {
+ push(@good_links, $value);
+ } else {
+ push(@bad_links, $value);
+ $isbad = 1;
+ }
+ }
+ if ($isbad) {
+ print("$x->{file}:$x->{linenr}: warning: possible bad link\t$x->{line}\n");
+ }
+ }
+ }
+}
+
+sub ignore_email_address {
+ my ($address) = @_;
+
+ foreach my $ignore (@ignore_emails) {
+ return 1 if ($ignore eq $address);
+ }
+
+ return 0;
+}
+