+# -*- perl -*-
+# Lintian::Tag::Info -- interface to tag metadata
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2009 Russ Allbery
+#
+# 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, see <http://www.gnu.org/licenses/>.
+
+package Maemian::Tag::Info;
+
+use strict;
+use warnings;
+
+use Carp qw(croak);
+
+use Maemian::Output qw(debug_msg);
+use Text_utils qw(dtml_to_html dtml_to_text split_paragraphs wrap_paragraphs);
+use Util qw(fail read_dpkg_control);
+
+# The URL to a web man page service. NAME is replaced by the man page
+# name and SECTION with the section to form a valid URL. This is used
+# when formatting references to manual pages into HTML to provide a link
+# to the manual page.
+our $MANURL
+ = 'http://manpages.debian.net/cgi-bin/man.cgi?query=NAME&sektion=SECTION';
+
+# Stores the parsed tag information for all known tags. Loaded the first
+# time new() is called.
+our %INFO;
+
+# Stores the parsed manual reference data. Loaded the first time info()
+# is called.
+our %MANUALS;
+
+=head1 NAME
+
+Lintian::Tag::Info - Lintian interface to tag metadata
+
+=head1 SYNOPSIS
+
+ my $tag = Lintian::Tag::Info->new('some-tag');
+ print "Tag info is:\n";
+ print $tag_info->description('text', ' ');
+ print "\nTag info in HTML is:\n";
+ print $tag_info->description('html', ' ');
+
+=head1 DESCRIPTION
+
+This module provides an interface to tag metadata as gleaned from the
+*.desc files describing the checks. Currently, it is only used to format
+and return the tag description, but it provides a framework that can be
+used to retrieve other metadata about tags.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new(TAG)
+
+Creates a new Lintian::Tag::Info object for the given TAG. Returns undef
+if the tag is unknown and throws an exception if there is a parse error
+reading the check description files or if TAG is not specified.
+
+The first time this method is called, all tag metadata will be loaded into
+a memory cache. This information will be used to satisfy all subsequent
+Lintian::Tag::Info object creation, avoiding multiple file reads. This
+however means that a running Lintian process will not notice changes to
+tag metadata on disk.
+
+=cut
+
+# Load all tag data into the %INFO hash. Called by new() if %INFO is
+# empty and hence called the first time new() is called.
+sub _load_tag_data {
+ my $root = $ENV{LINTIAN_ROOT} || '/usr/share/lintian';
+ for my $desc (<$root/checks/*.desc>) {
+ debug_msg(2, "Reading checker description file $desc ...");
+ my ($header, @tags) = read_dpkg_control($desc);
+ unless ($header->{'check-script'}) {
+ fail("missing Check-Script field in $desc");
+ }
+ for my $tag (@tags) {
+ unless ($tag->{tag}) {
+ fail("missing Tag field in $desc");
+ }
+ $tag->{info} = '' unless exists($tag->{info});
+ $INFO{$tag->{tag}} = $tag;
+ }
+ }
+}
+
+# Create a new object for the given tag. We just use the hash created by
+# read_dpkg_control as the object, which means we slowly bless the objects
+# in %INFO as we return them.
+sub new {
+ my ($class, $tag) = @_;
+ croak('no tag specified') unless $tag;
+ _load_tag_data() unless %INFO;
+ if ($INFO{$tag}) {
+ my $self = $INFO{$tag};
+ bless($self, $class) unless ref($self) eq $class;
+ return $self;
+ } else {
+ return;
+ }
+}
+
+=back
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item description([FORMAT [, INDENT]])
+
+Returns the formatted description (the Info field) for a tag. FORMAT must
+be either C<text> or C<html> and defaults to C<text> if no format is
+specified. If C<text>, returns wrapped paragraphs formatted in plain text
+with a right margin matching the Text::Wrap default, preserving as
+verbatim paragraphs that begin with whitespace. If C<html>, return
+paragraphs formatted in HTML.
+
+If INDENT is specified, the string INDENT is prepended to each line of the
+formatted output.
+
+=cut
+
+# Load manual reference data into %MANUALS. This information doesn't have
+# a single unique key and has multiple data values per key, so we don't
+# try to use the Lintian::Data interface. Instead, we read a file
+# delimited by double colons. We do use a path similar to Lintian::Data
+# to keep such files in the same general location.
+sub _load_manual_data {
+ my $root = $ENV{LINTIAN_ROOT} || '/usr/share/lintian';
+ open(REFS, '<', "$root/data/output/manual-references")
+ or fail("can't open $root/data/output/manual-references: $!");
+ local $_;
+ while (<REFS>) {
+ chomp;
+ next if /^\#/;
+ next if /^\s*$/;
+ next unless /^(.+?)::(.*?)::(.+?)::(.*?)$/;
+ my ($manual, $section, $title, $url) = split('::');
+ $MANUALS{$manual}{$section}{title} = $title;
+ $MANUALS{$manual}{$section}{url} = $url;
+ }
+ close REFS;
+}
+
+# Format a reference to a manual in the HTML that Lintian uses internally
+# for tag descriptions and return the result. Takes the name of the
+# manual and the name of the section. Returns an empty string if the
+# argument isn't a known manual.
+sub _manual_reference {
+ my ($manual, $section) = @_;
+ _load_manual_data unless %MANUALS;
+ return '' unless exists $MANUALS{$manual}{''};
+
+ # Start with the reference to the overall manual.
+ my $title = $MANUALS{$manual}{''}{title};
+ my $url = $MANUALS{$manual}{''}{url};
+ my $text = $url ? qq(<a href="$url">$title</a>) : $title;
+
+ # Add the section information, if present, and a direct link to that
+ # section of the manual where possible.
+ if ($section and $section =~ /^[A-Z]+$/) {
+ $text .= " appendix $section";
+ } elsif ($section and $section =~ /^\d+$/) {
+ $text .= " chapter $section";
+ } elsif ($section and $section =~ /^[A-Z\d.]+$/) {
+ $text .= " section $section";
+ }
+ if ($section and exists $MANUALS{$manual}{$section}) {
+ my $title = $MANUALS{$manual}{$section}{title};
+ my $url = $MANUALS{$manual}{$section}{url};
+ $text .= qq[ (<a href="$url">$title</a>)];
+ }
+
+ return $text;
+}
+
+# Format the contents of the Ref attribute of a tag. Handles manual
+# references in the form <keyword> <section>, manpage references in the
+# form <manpage>(<section>), and URLs.
+sub _format_reference {
+ my ($field) = @_;
+ my @refs;
+ for my $ref (split(/,\s*/, $field)) {
+ my $text;
+ if ($ref =~ /^([\w-]+)\s+(.+)$/) {
+ $text = _manual_reference($1, $2);
+ } elsif ($ref =~ /^([\w_-]+)\((\d\w*)\)$/) {
+ my ($name, $section) = ($1, $2);
+ my $url = $MANURL;
+ $url =~ s/NAME/$name/g;
+ $url =~ s/SECTION/$section/g;
+ $text = qq(the <a href="$url">$ref</a> manual page);
+ } elsif ($ref =~ m,^(ftp|https?)://,) {
+ $text = qq(<a href="$ref">$ref</a>);
+ }
+ push (@refs, $text) if $text;
+ }
+
+ # Now build an English list of the results with appropriate commas and
+ # conjunctions.
+ my $text = '';
+ if ($#refs >= 2) {
+ $text = join(', ', splice(@refs, 0, $#refs));
+ $text = "Refer to $text, and @refs for details.";
+ } elsif ($#refs >= 0) {
+ $text = 'Refer to ' . join(' and ', @refs) . ' for details.';
+ }
+ return $text;
+}
+
+# Returns the formatted tag description.
+sub description {
+ my ($self, $format, $indent) = @_;
+ $indent = '' unless defined($indent);
+ $format = 'text' unless defined($format);
+ if ($format ne 'text' and $format ne 'html') {
+ croak("unknown output format $format");
+ }
+
+ # Build the tag description.
+ my $info = $self->{info};
+ $info =~ s/\n[ \t]/\n/g;
+ my @text = split_paragraphs($info);
+ if ($self->{ref}) {
+ push(@text, '', _format_reference($self->{ref}));
+ }
+ if ($self->{severity} and $self->{certainty}) {
+ my $severity = $self->{severity};
+ my $certainty = $self->{certainty};
+ push(@text, '', "Severity: $severity, Certainty: $certainty");
+ }
+ if ($self->{experimental}) {
+ push(@text, '',
+ 'This tag is marked experimental, which means that the code that'
+ . ' generates it is not as well-tested as the rest of Lintian'
+ . ' and might still give surprising results. Feel free to'
+ . ' ignore experimental tags that do not seem to make sense,'
+ . ' though of course bug reports are always welcomed.');
+ }
+
+ # Format and return the output.
+ if ($format eq 'text') {
+ return wrap_paragraphs($indent, dtml_to_text(@text));
+ } elsif ($format eq 'html') {
+ return wrap_paragraphs('HTML', $indent, dtml_to_html(@text));
+ }
+}
+
+=back
+
+=head1 DIAGNOSTICS
+
+The following exceptions may be thrown:
+
+=over 4
+
+=item no tag specified
+
+The Lintian::Tag::Info::new constructor was called without passing a tag
+as an argument.
+
+=item unknown output format %s
+
+An unknown output format was passed as the FORMAT argument of
+description(). FORMAT must be either C<text> or C<html>.
+
+=back
+
+The following fatal internal errors may be reported:
+
+=over 4
+
+=item can't open %s: %s
+
+The specified file, which should be part of the standard Lintian data
+files, could not be opened. The file may be missing or have the wrong
+permissions.
+
+=item missing Check-Script field in %s
+
+The specified check description file has no Check-Script field in its
+header section. This probably indicates the file doesn't exist or has
+some significant formatting error.
+
+=item missing Tag field in %s
+
+The specified check description file has a tag section that has no Tag
+field.
+
+=back
+
+=head1 FILES
+
+=over 4
+
+=item LINTIAN_ROOT/checks/*.desc
+
+The tag description files, from which tag metadata is read. All files
+matching this shell glob expression will be read looking for tag data.
+
+=item LINTIAN_ROOT/data/output/manual-references
+
+Information about manual references. Each non-comment, non-empty line of
+this file contains four fields separated by C<::>. The first field is the
+name of the manual, the second field is the section or empty for data
+about the whole manual, the third field is the title, and the fourth field
+is the URL. The URL is optional.
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item LINTIAN_ROOT
+
+This variable specifies Lintian's root directory. It defaults to
+F</usr/share/lintian> if not set. The B<lintian> program normally takes
+care of setting it.
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 ts=4 et shiftround