From 75808db17caf8b960b351e3408e74142f4c85aac Mon Sep 17 00:00:00 2001 From: Daniel Baumann Date: Sun, 14 Apr 2024 15:42:30 +0200 Subject: Adding upstream version 2.117.0. Signed-off-by: Daniel Baumann --- lib/Lintian/Check/Documentation/Devhelp.pm | 87 +++ .../Check/Documentation/Devhelp/Standard.pm | 47 ++ lib/Lintian/Check/Documentation/Doxygen.pm | 75 +++ lib/Lintian/Check/Documentation/Examples.pm | 48 ++ lib/Lintian/Check/Documentation/Manual.pm | 663 +++++++++++++++++++++ lib/Lintian/Check/Documentation/Texinfo.pm | 195 ++++++ 6 files changed, 1115 insertions(+) create mode 100644 lib/Lintian/Check/Documentation/Devhelp.pm create mode 100644 lib/Lintian/Check/Documentation/Devhelp/Standard.pm create mode 100644 lib/Lintian/Check/Documentation/Doxygen.pm create mode 100644 lib/Lintian/Check/Documentation/Examples.pm create mode 100644 lib/Lintian/Check/Documentation/Manual.pm create mode 100644 lib/Lintian/Check/Documentation/Texinfo.pm (limited to 'lib/Lintian/Check/Documentation') diff --git a/lib/Lintian/Check/Documentation/Devhelp.pm b/lib/Lintian/Check/Documentation/Devhelp.pm new file mode 100644 index 0000000..cd186a5 --- /dev/null +++ b/lib/Lintian/Check/Documentation/Devhelp.pm @@ -0,0 +1,87 @@ +# documentation/devhelp -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2022 Felix Lechner +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Devhelp; + +use v5.20; +use warnings; +use utf8; + +use List::SomeUtils qw(none); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +# *.devhelp and *.devhelp2 files must be accessible from a directory in +# the devhelp search path: /usr/share/devhelp/books and +# /usr/share/gtk-doc/html. We therefore look for any links in one of +# those directories to another directory. The presence of such a link +# blesses any file below that other directory. +has reachable_folders => ( + is => 'rw', + lazy => 1, + default => sub { + my ($self) = @_; + + my @reachable_folders; + + for my $item (@{$self->processable->installed->sorted_list}) { + + # in search path + next + unless $item->name + =~ m{^ usr/share/ (?: devhelp/books | gtk-doc/html ) / }x; + + next + unless length $item->link; + + my $followed = $item->link_normalized; + + # drop broken links + push(@reachable_folders, $followed) + if length $followed; + } + + return \@reachable_folders; + } +); + +sub visit_installed_files { + my ($self, $item) = @_; + + # locate Devhelp files not discoverable by Devhelp + $self->pointed_hint('stray-devhelp-documentation', $item->pointer) + if $item->name =~ m{ [.]devhelp2? (?: [.]gz )? $}x + && $item->name !~ m{^ usr/share/ (?: devhelp/books | gtk-doc/html ) / }x + && (none { $item->name =~ /^\Q$_\E/ } @{$self->reachable_folders}); + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation/Devhelp/Standard.pm b/lib/Lintian/Check/Documentation/Devhelp/Standard.pm new file mode 100644 index 0000000..05d77db --- /dev/null +++ b/lib/Lintian/Check/Documentation/Devhelp/Standard.pm @@ -0,0 +1,47 @@ +# documentation/devhelp/standard -- lintian check script -*- perl -*- + +# Copyright (C) 2022 Felix Lechner +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Devhelp::Standard; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_installed_files { + my ($self, $item) = @_; + + $self->pointed_hint('old-devhelp-standard', $item->pointer) + if $item->name =~ m{ [.]devhelp (?: [.]gz )? $}x; + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation/Doxygen.pm b/lib/Lintian/Check/Documentation/Doxygen.pm new file mode 100644 index 0000000..206a4b8 --- /dev/null +++ b/lib/Lintian/Check/Documentation/Doxygen.pm @@ -0,0 +1,75 @@ +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 1999 Joey Hess +# Copyright (C) 2000 Sean 'Shaleh' Perry +# Copyright (C) 2002 Josip Rodin +# Copyright (C) 2007 Russ Allbery +# Copyright (C) 2013-2018 Bastien ROUCARIES +# Copyright (C) 2017-2020 Chris Lamb +# Copyright (C) 2020-2021 Felix Lechner +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Doxygen; + +use v5.20; +use warnings; +use utf8; + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +sub visit_patched_files { + my ($self, $item) = @_; + + return + unless $item->is_file; + + $self->pointed_hint('source-contains-prebuilt-doxygen-documentation', + $item->parent_dir->pointer) + if $item->basename =~ m{^doxygen.(?:png|sty)$} + && $self->processable->source_name ne 'doxygen'; + + return + unless $item->basename =~ /\.(?:x?html?\d?|xht)$/i; + + my $contents = $item->decoded_utf8; + return + unless length $contents; + + my $lowercase = lc($contents); + + # Identify and ignore documentation templates by looking + # for the use of various interpolated variables. + # + $self->pointed_hint('source-contains-prebuilt-doxygen-documentation', + $item->pointer) + if $lowercase =~ m{pointed_hint('empty-manual-page', $item->pointer); + return; + + } elsif ($first =~ /^\.so\s+(.+)?$/) { + my $dest = $1; + if ($dest =~ m{^([^/]+)/(.+)$}) { + + my ($manxorlang, $remainder) = ($1, $2); + + if ($manxorlang !~ /^man\d+$/) { + # then it's likely a language subdir, so let's run + # the other component through the same check + if ($remainder =~ m{^([^/]+)/(.+)$}) { + + my $rest = $2; + $self->pointed_hint( + 'bad-so-link-within-manual-page', + $item->pointer) + unless $rest =~ m{^[^/]+\.\d(?:\S+)?(?:\.gz)?$}; + + } else { + $self->pointed_hint( + 'bad-so-link-within-manual-page', + $item->pointer); + } + } + + } else { + $self->pointed_hint('bad-so-link-within-manual-page', + $item->pointer); + } + return; + } + } + + # If it's not a .so link, use lexgrog to find out if the + # man page parses correctly and make sure the short + # description is reasonable. + # + # This check is currently not applied to pages in + # language-specific hierarchies, because those pages are + # not currently scanned by mandb (bug #29448), and because + # lexgrog can't handle pages in all languages at the + # moment, leading to huge numbers of false negatives. When + # man-db is fixed, this limitation should be removed. + if ($page_path =~ m{/man/man\d/}) { + + delete local $ENV{$_} + for grep { $_ ne 'PATH' && $_ ne 'TMPDIR' } keys %ENV; + local $ENV{LC_ALL} = 'C.UTF-8'; + + my @command = ('lexgrog', $item->unpacked_path); + + my $stdout; + my $stderr; + + run3(\@command, \undef, \$stdout, \$stderr); + + my $exitcode = $?; + my $status = ($exitcode >> $WAIT_STATUS_SHIFT); + + $self->pointed_hint('bad-whatis-entry', $item->pointer) + if $status == 2; + + if ($status != 0 && $status != 2) { + my $message = "Non-zero status $status from @command"; + $message .= $COLON . $NEWLINE . $stderr + if length $stderr; + + warn encode_utf8($message); + + } else { + my $desc = $stdout; + $desc =~ s/^[^:]+: \"(.*)\"$/$1/; + + if ($desc =~ /(\S+)\s+-\s+manual page for \1/i) { + $self->pointed_hint('useless-whatis-entry',$item->pointer); + + } elsif ($desc =~ /\S+\s+-\s+programs? to do something/i) { + $self->pointed_hint('manual-page-from-template', + $item->pointer); + } + } + } + + # If it's not a .so link, run it through 'man' to check for errors. + # If it is in a directory with the standard man layout, cd to the + # parent directory before running man so that .so directives are + # processed properly. (Yes, there are man pages that include other + # pages with .so but aren't simple links; rbash, for instance.) + { + delete local $ENV{$_} + for grep { $_ ne 'PATH' && $_ ne 'TMPDIR' } keys %ENV; + local $ENV{LC_ALL} = 'C.UTF-8'; + + local $ENV{MANROFFSEQ} = $EMPTY; + + # set back to 80 when Bug#892423 is fixed in groff + local $ENV{MANWIDTH} = $WIDE_SCREEN; + + my $stdout; + my $stderr; + + my @command = qw(man --warnings -E UTF-8 -l -Tutf8 -Z); + push(@command, $item->unpacked_path); + + my $localdir = path($item->unpacked_path)->parent->stringify; + $localdir =~ s{^(.*)/man\d\b}{$1}s; + + my $savedir = getcwd; + chdir($localdir) + or die encode_utf8('Cannot change directory ' . $localdir); + + run3(\@command, \undef, \$stdout, \$stderr); + + my $exitcode = $?; + my $status = ($exitcode >> $WAIT_STATUS_SHIFT); + + my @lines = split(/\n/, $stderr); + + my $position = 1; + for my $line (@lines) { + + chomp $line; + + # Devel::Cover causes some annoying deep recursion + # warnings and sometimes in our child process. + # Filter them out, but only during coverage. + next + if $ENV{LINTIAN_COVERAGE} + && $line =~ m{ + \A Deep [ ] recursion [ ] on [ ] subroutine [ ] + "[^"]+" [ ] at [ ] .*B/Deparse.pm [ ] line [ ] + \d+}xsm; + + # ignore progress information from man + next + if $line =~ /^Reformatting/; + + next + if $line =~ /^\s*$/; + + # ignore errors from gzip; dealt with elsewhere + next + if $line =~ /^\bgzip\b/; + + # ignore wrapping failures for Asian man pages (groff problem) + if ($language =~ /^(?:ja|ko|zh)/) { + next + if $line =~ /warning \[.*\]: cannot adjust line/; + next + if $line =~ /warning \[.*\]: can\'t break line/; + } + + # ignore wrapping failures if they contain URLs (.UE is an + # extension for marking the end of a URL). + next + if $line + =~ /:(\d+): warning \[.*\]: (?:can\'t break|cannot adjust) line/ + && ( $manfile[$1 - 1] =~ m{(?:https?|ftp|file)://.+}i + || $manfile[$1 - 1] =~ m{^\s*\.\s*UE\b}); + + # ignore common undefined macros from pod2man << Perl 5.10 + next + if $line =~ /warning: (?:macro )?\'(?:Tr|IX)\' not defined/; + + $line =~ s/^[^:]+: //; + $line =~ s/^://; + + $self->pointed_hint('groff-message', + $item->pointer($position), $line); + } continue { + ++$position; + } + + chdir($savedir) + or die encode_utf8('Cannot change directory ' . $savedir); + + } + + # Now we search through the whole man page for some common errors + my $position = 1; + my $seen_python_traceback; + for my $line (@manfile) { + + chomp $line; + + next + if $line =~ /^\.\\\"/; # comments .\" + + if ($line =~ /^\.TH\s/) { + + # title header + my $consumed = $line; + $consumed =~ s/ [.]TH \s+ //msx; + + my ($delimited, $after_names) = extract_delimited($consumed); + unless (length $delimited) { + $consumed =~ s/ ^ \s* \S+ , //gmsx; + $consumed =~ s/ ^ \s* \S+ //msx; + $after_names = $consumed; + } + + my ($th_section) = extract_delimited($after_names); + if (length $th_section) { + + # drop initial delimiter + $th_section =~ s/ ^. //msx; + + # drop final delimiter + $th_section =~ s/ .$ //msx; + + # unescape + $th_section =~ s/ [\\](.) /$1/gmsx; + + } elsif (length $after_names + && $after_names =~ / ^ \s* (\S+) /msx) { + $th_section = $1; + } + + $self->pointed_hint( + 'wrong-manual-section', + $item->pointer($position), + "$fn_section != $th_section" + )if length $th_section && fc($th_section) ne fc($fn_section); + } + + if ( ($line =~ m{(/usr/(dict|doc|etc|info|man|adm|preserve)/)}) + || ($line =~ m{(/var/(adm|catman|named|nis|preserve)/)})){ + # FSSTND dirs in man pages + # regexes taken from checks/files + $self->pointed_hint('FSSTND-dir-in-manual-page', + $item->pointer($position), $1); + } + + if ($line eq '.SH "POD ERRORS"') { + $self->pointed_hint('pod-conversion-message', + $item->pointer($position)); + } + + if ($line =~ /Traceback \(most recent call last\):/) { + $self->pointed_hint('python-traceback-in-manpage', + $item->pointer) + unless $seen_python_traceback; + $seen_python_traceback = 1; + } + + # Check for spelling errors if the manpage is English + my $stag_emitter + = $self->spelling_tag_emitter('typo-in-manual-page', + $item->pointer($position)); + check_spelling($self->data, $line, + $self->group->spelling_exceptions, + $stag_emitter, 0) + if $page_path =~ m{/man/man\d/}; + + } continue { + ++$position; + } + } + + # most man pages are zipped + my $bytes; + if ($item->file_type =~ /gzip compressed/) { + + my $path = $item->unpacked_path; + gunzip($path => \$bytes) + or die encode_utf8("gunzip $path failed: $GunzipError"); + + } elsif ($item->file_type =~ /^troff/ || $item->file_type =~ /text$/) { + $bytes = $item->bytes; + } + + return + unless length $bytes; + + # another check complains about invalid encoding + return + unless valid_utf8($bytes); + + my $contents = decode_utf8($bytes); + my @lines = split(/\n/, $contents); + + my $position = 1; + for my $line (@lines) { + + # see Bug#554897 and Bug#507673; exclude string variables + $self->pointed_hint('acute-accent-in-manual-page', + $item->pointer($position)) + if $line =~ /\\'/ && $line !~ /^\.\s*ds\s/; + + } continue { + $position++; + } + + return; +} + +sub installable { + my ($self) = @_; + + # no man pages in udebs + return + if $self->processable->type eq 'udeb'; + + my %local_user_executables; + my %local_admin_executables; + + for my $item (@{$self->processable->installed->sorted_list}) { + + next + unless $item->is_symlink || $item->is_file; + + my ($name, $path, undef) = fileparse($item->name); + + $local_user_executables{$name} = $item + if any { $path eq $_ } @user_locations; + + $local_admin_executables{$name} = $item + if any { $path eq $_ } @admin_locations; + } + + my %local_executables= (%local_user_executables, %local_admin_executables); + my @local_commands = keys %local_executables; + + my @direct_reliants + =@{$self->group->direct_reliants($self->processable) // []}; + my @reliant_files = map { @{$_->installed->sorted_list} } @direct_reliants; + + # for executables, look at packages relying on the current processable + my %distant_executables; + for my $item (@reliant_files) { + + next + unless $item->is_file || $item->is_symlink; + + my ($name, $path, undef) = fileparse($item, qr{\..+$}); + + $distant_executables{$name} = $item + if any { $path eq $_ } (@user_locations, @admin_locations); + } + + my @distant_commands = keys %distant_executables; + my @related_commands = (@local_commands, @distant_commands); + + my @direct_prerequisites + =@{$self->group->direct_dependencies($self->processable) // []}; + my@prerequisite_files + = map { @{$_->installed->sorted_list} } @direct_prerequisites; + + # for manpages, look at packages the current processable relies upon + my %distant_manpages; + for my $item (@prerequisite_files) { + + next + unless $item->is_file || $item->is_symlink; + + my ($name, $path, undef) = fileparse($item, qr{\..+$}); + + next + unless $path =~ m{^usr/share/man/\S+}; + + next + unless $path =~ m{man\d/$}; + + my ($language) = ($path =~ m{/([^/]+)/man\d/$}); + $language //= $EMPTY; + $language = $EMPTY if $language eq 'man'; + + $distant_manpages{$name} //= []; + + push @{$distant_manpages{$name}}, + {file => $item, language => $language}; + } + + my %local_manpages = %{$self->local_manpages}; + my %related_manpages = (%local_manpages, %distant_manpages); + + # provides sorted output + my $related + = List::Compare->new(\@local_commands, [keys %related_manpages]); + my @documented = $related->get_intersection; + my @manpage_missing = $related->get_Lonly; + + my @english_missing = grep { + none {$_->{language} eq $EMPTY} + @{$related_manpages{$_} // []} + } @documented; + + for my $command (keys %local_admin_executables) { + + my $item = $local_admin_executables{$command}; + my @manpages = @{$related_manpages{$command} // []}; + + my @sections = grep { defined } map { $_->{section} } @manpages; + $self->pointed_hint('manual-page-for-system-command', $item->pointer) + if $item->is_regular_file + && any { $_ == $USER_COMMAND_SECTION } @sections; + } + + for (map {$local_executables{$_}} @english_missing) { + $self->pointed_hint('no-english-manual-page', $_->pointer) + unless $_->name =~ m{/libexec/}; + } + + for (map {$local_executables{$_}} @manpage_missing) { + $self->pointed_hint('no-manual-page', $_->pointer) + unless $_->name =~ m{/libexec/}; + } + + # surplus manpages only for this package; provides sorted output + my $local = List::Compare->new(\@related_commands, [keys %local_manpages]); + my @surplus_manpages = $local->get_Ronly; + + # filter out sub commands, underscore for libreswan; see Bug#947258 + for my $command (@related_commands) { + @surplus_manpages = grep { !/^$command(?:\b|_)/ } @surplus_manpages; + } + + for my $manpage (map { @{$local_manpages{$_} // []} } @surplus_manpages) { + + my $item = $manpage->{file}; + my $section = $manpage->{section}; + + $self->pointed_hint('spare-manual-page', $item->pointer) + if $section == $USER_COMMAND_SECTION + || $section == $SYSTEM_COMMAND_SECTION; + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/lib/Lintian/Check/Documentation/Texinfo.pm b/lib/Lintian/Check/Documentation/Texinfo.pm new file mode 100644 index 0000000..cc4be39 --- /dev/null +++ b/lib/Lintian/Check/Documentation/Texinfo.pm @@ -0,0 +1,195 @@ +# documentation/texinfo -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2001 Josip Rodin +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::Check::Documentation::Texinfo; + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Unicode::UTF8 qw(encode_utf8); +use List::SomeUtils qw(uniq); + +use Lintian::Util qw(normalize_link_target); + +use Moo; +use namespace::clean; + +with 'Lintian::Check'; + +const my $EMPTY => q{}; + +sub binary { + my ($self) = @_; + + my $info_dir + = $self->processable->installed->resolve_path('usr/share/info/'); + return + unless $info_dir; + + # Read package contents... + for my $item ($info_dir->descendants) { + + next + unless $item->is_symlink + || $item->is_file; + + # Ignore dir files. That's a different error which we already catch in + # the files check. + next + if $item->basename =~ /^dir(?:\.old)?(?:\.gz)?/; + + # Analyze the file names making sure the documents are named + # properly. Note that Emacs 22 added support for images in + # info files, so we have to accept those and ignore them. + # Just ignore .png files for now. + my @fname_pieces = split(m{ [.] }x, $item->basename); + my $extension = pop @fname_pieces; + + if ($extension eq 'gz') { # ok! + if ($item->is_file) { + + # compressed with maximum compression rate? + if ($item->file_type !~ m/gzip compressed data/) { + $self->pointed_hint( + 'info-document-not-compressed-with-gzip', + $item->pointer); + + } else { + if ($item->file_type !~ m/max compression/) { + $self->pointed_hint( +'info-document-not-compressed-with-max-compression', + $item->pointer + ); + } + } + } + + } elsif ($extension =~ m/^(?:png|jpe?g)$/) { + next; + + } else { + push(@fname_pieces, $extension); + $self->pointed_hint('info-document-not-compressed',$item->pointer); + } + + my $infoext = pop @fname_pieces; + unless ($infoext && $infoext =~ /^info(-\d+)?$/) { # it's not foo.info + + # it's not foo{,-{1,2,3,...}} + $self->pointed_hint('info-document-has-wrong-extension', + $item->pointer) + if @fname_pieces; + } + + # If this is the main info file (no numeric extension). make + # sure it has appropriate dir entry information. + if ( $item->basename !~ /-\d+\.gz/ + && $item->file_type =~ /gzip compressed data/) { + + # unsafe symlink, skip. Actually, this should never + # be true as "$file_type" for symlinks will not be + # "gzip compressed data". But for good measure. + next + unless $item->is_open_ok; + + open(my $fd, '<:gzip', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my ($section, $start, $end); + while (my $line = <$fd>) { + + $section = 1 + if $line =~ /^INFO-DIR-SECTION\s+\S/; + + $start = 1 + if $line =~ /^START-INFO-DIR-ENTRY\b/; + + $end = 1 + if $line =~ /^END-INFO-DIR-ENTRY\b/; + } + + close $fd; + + $self->pointed_hint('info-document-missing-dir-section', + $item->pointer) + unless $section; + + $self->pointed_hint('info-document-missing-dir-entry', + $item->pointer) + unless $start && $end; + } + + # Check each [image src=""] form in the info files. The src + # filename should be in the package. As of Texinfo 5 it will + # be something.png or something.jpg, but that's not enforced. + # + # See Texinfo manual (info "(texinfo)Info Format Image") for + # details of the [image] form. Bytes \x00,\x08 introduce it + # (and distinguishes it from [image] appearing as plain text). + # + # String src="..." part has \" for literal " and \\ for + # literal \, though that would be unlikely in filenames. For + # the tag() message show $src unbackslashed since that's the + # filename sought. + # + if ($item->is_file && $item->basename =~ /\.info(?:-\d+)?\.gz$/) { + + open(my $fd, '<:gzip', $item->unpacked_path) + or die encode_utf8('Cannot open ' . $item->unpacked_path); + + my $position = 1; + while (my $line = <$fd>) { + + my @missing; + while ($line =~ /[\0][\b]\[image src="((?:\\.|[^\"])+)"/smg) { + + my $src = $1; + $src =~ s/\\(.)/$1/g; # unbackslash + + push(@missing, $src) + unless $self->processable->installed->lookup( + normalize_link_target('usr/share/info', $src)); + } + + $self->pointed_hint('info-document-missing-image-file', + $item->pointer($position), $_) + for uniq @missing; + + } continue { + ++$position; + } + + close $fd; + } + } + + return; +} + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et -- cgit v1.2.3