--- /dev/null
+# Copyright © 2008 Frank Lichtenheld <frank@lichtenheld.de>
+#
+# 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 http://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 Maemian::Command;
+use strict;
+use warnings;
+
+BEGIN {
+ # Disabling IPC::Run::Debug saves tons of useless calls.
+ $ENV{'IPCRUNDEBUG'} = 'none';
+}
+
+use base qw(Exporter);
+our @EXPORT = ();
+our @EXPORT_OK = qw(spawn reap kill);
+
+use IPC::Run qw(run harness kill_kill);
+
+=head1 NAME
+
+Lintian::Command - Utilities to execute other commands from lintian code
+
+=head1 SYNOPSIS
+
+ use Lintian::Command qw(spawn);
+
+ # simplest possible call
+ my $success = spawn({}, ['command']);
+
+ # catch output
+ my $opts = {};
+ $success = spawn($opts, ['command']);
+ if ($success) {
+ print "STDOUT: $opts->{out}\n";
+ print "STDERR: $opts->{err}\n";
+ }
+
+ # from file to file
+ $opts = { in => 'infile.txt', out => 'outfile.txt' };
+ $success = spawn($opts, ['command']);
+
+ # piping
+ $success = spawn({}, ['command'], "|", ['othercommand']);
+
+=head1 DESCRIPTION
+
+Lintian::Command is a thin wrapper around IPC::Run, that catches exception
+and implements a useful default behaviour for input and output redirection.
+
+Lintian::Command provides a function spawn() which is a wrapper
+around IPC::Run::run() resp. IPC::Run::start() (depending on whether a
+pipe is requested). To wait for finished child processes, it also
+provides the reap() function as a wrapper around IPC::Run::finish().
+
+=head2 C<spawn($opts, @cmds)>
+
+The @cmds array is given to IPC::Run::run() (or ::start()) unaltered, but
+should only be used for commands and piping symbols (i.e. all of the elements
+should be either an array reference, a code reference, '|', or '&'). I/O
+redirection is handled via the $opts hash reference. If you need more fine
+grained control than that, you should just use IPC::Run directly.
+
+$opts is a hash reference which can be used to set options and to retrieve
+the status and output of the command executed.
+
+The following hash keys can be set to alter the behaviour of spawn():
+
+=over 4
+
+=item in
+
+STDIN for the first forked child. Defaults to C<\undef>.
+
+=item pipe_in
+
+Use a pipe for STDIN and start the process in the background.
+You will need to close the pipe after use and call $opts->{harness}->finish
+in order for the started process to end properly.
+
+=item out
+
+STDOUT of the last forked child. Will be set to a newly created
+scalar reference by default which can be used to retrieve the output
+after the call.
+
+=item pipe_out
+
+Use a pipe for STDOUT and start the process in the background.
+You will need to call $opts->{harness}->finish in order for the started
+process to end properly.
+
+=item err
+
+STDERR of all forked childs. Defaults to STDERR of the parent.
+
+=item pipe_err
+
+Use a pipe for STDERR and start the process in the background.
+You will need to call $opts->{harness}->finish in order for the started
+process to end properly.
+
+=item fail
+
+Configures the behaviour in case of errors. The default is 'exception',
+which will cause spawn() to die in case of exceptions thrown by IPC::Run.
+If set to 'error' instead, it will also die if the command exits
+with a non-zero error code. If exceptions should be handled by the caller,
+setting it to 'never' will cause it to store the exception in the
+C<exception> key instead.
+
+=back
+
+The following additional keys will be set during the execution of spawn():
+
+=over 4
+
+=item harness
+
+Will contain the IPC::Run object used for the call which can be used to
+query the exit values of the forked programs (E.g. with results() and
+full_results()) and to wait for processes started in the background.
+
+=item exception
+
+If an exception is raised during the execution of the commands,
+and if C<fail> is set to 'never', the exception will be caught and
+stored under this key.
+
+=item success
+
+Will contain the return value of spawn().
+
+=back
+
+=cut
+
+sub spawn {
+ my ($opts, @cmds) = @_;
+
+ if (ref($opts) ne 'HASH') {
+ $opts = {};
+ }
+ $opts->{fail} ||= 'exception';
+
+ my ($out, $background);
+ my (@out, @in, @err);
+ if ($opts->{pipe_in}) {
+ @in = ('<pipe', $opts->{pipe_in});
+ $background = 1;
+ } else {
+ $opts->{in} ||= \undef;
+ @in = ('<', $opts->{in});
+ }
+ if ($opts->{pipe_out}) {
+ @out = ('>pipe', $opts->{pipe_out});
+ $background = 1;
+ } else {
+ $opts->{out} ||= \$out;
+ @out = ('>', $opts->{out});
+ }
+ if ($opts->{pipe_err}) {
+ @err = ('2>pipe', $opts->{pipe_err});
+ $background = 1;
+ } else {
+ $opts->{err} ||= \*STDERR;
+ @err = ('2>', $opts->{err});
+ }
+
+# use Data::Dumper;
+# print STDERR Dumper($opts, \@cmds);
+ eval {
+ if (@cmds == 1) {
+ my $cmd = pop @cmds;
+ my $last = pop @$cmd;
+ # Support shell-style "command &"
+ if ($last eq '&') {
+ $background = 1;
+ } else {
+ push @$cmd, $last;
+ }
+ $opts->{harness} = harness($cmd, @in, @out, @err);
+ } else {
+ my ($first, $last) = (shift @cmds, pop @cmds);
+ # Support shell-style "command &"
+ if ($last eq '&') {
+ $background = 1;
+ } else {
+ push @cmds, $last;
+ }
+ $opts->{harness} = harness($first, @in, @cmds, @out, @err);
+ }
+ if ($background) {
+ $opts->{success} = $opts->{harness}->start;
+ } else {
+ $opts->{success} = $opts->{harness}->run;
+ }
+ };
+ if ($@) {
+ require Util;
+ Util::fail($@) if $opts->{fail} ne 'never';
+ $opts->{success} = 0;
+ $opts->{exception} = $@;
+ } elsif ($opts->{fail} eq 'error'
+ and !$opts->{success}) {
+ require Util;
+ if ($opts->{description}) {
+ Util::fail("$opts->{description} failed with error code ".
+ $opts->{harness}->result);
+ } elsif (@cmds == 1) {
+ Util::fail("$cmds[0][0] failed with error code ".
+ $opts->{harness}->result);
+ } else {
+ Util::fail("command failed with error code ".
+ $opts->{harness}->result);
+ }
+ }
+# print STDERR Dumper($opts, \@cmds);
+ return $opts->{success};
+}
+
+=head2 C<reap($opts[, $opts[,...]])>
+
+If you used one of the C<pipe_*> options to spawn() or used the shell-style "&"
+operator to send the process to the background, you will need to wait for your
+child processes to finish. For this you can use the reap() function,
+which you can call with the $opts hash reference you gave to spawn() and which
+will do the right thing. Multiple $opts can be passed.
+
+Note however that this function will not close any of the pipes for you, so
+you probably want to do that first before calling this function.
+
+The following keys of the $opts hash have roughly the same function as
+for spawn():
+
+=over 4
+
+=item harness
+
+=item fail
+
+=item success
+
+=item exception
+
+=back
+
+All other keys are probably just ignored.
+
+=cut
+
+sub reap {
+ my $status = 1;
+ while (my $opts = shift @_) {
+ next unless defined($opts->{harness});
+
+ eval {
+ $opts->{success} = $opts->{harness}->finish;
+ };
+ if ($@) {
+ require Util;
+ Util::fail($@) if $opts->{fail} ne 'never';
+ $opts->{success} = 0;
+ $opts->{exception} = $@;
+ } elsif ($opts->{fail} eq 'error'
+ and !$opts->{success}) {
+ require Util;
+ if ($opts->{description}) {
+ Util::fail("$opts->{description} failed with error code ".
+ $opts->{harness}->result);
+ } else {
+ Util::fail("command failed with error code ".
+ $opts->{harness}->result);
+ }
+ }
+ $status &&= $opts->{success};
+ }
+ return $status;
+}
+
+=head2 C<kill($opts[, $opts[, ...]])>
+
+This is a simple wrapper around the kill_kill function. It doesn't allow
+any customisation, but takes an $opts hash ref and SIGKILLs the process
+two seconds after SIGTERM is sent. If multiple hash refs are passed it
+executes kill_kill on each of them. The return status is the ORed value of
+all the executions of kill_kill.
+
+=cut
+
+sub kill {
+ my $status = 1;
+ while (my $opts = shift @_) {
+ $status &&= kill_kill($opts->{'harness'}, grace => 2);
+ }
+ return $status;
+}
+
+1;
+__END__
+
+=head1 EXPORTS
+
+Lintian::Command exports nothing by default, but you can export the
+spawn() and reap() functions.
+
+=head1 AUTHOR
+
+Originally written by Frank Lichtenheld <djpig@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1), IPC::Run
+
+=cut
--- /dev/null
+# -*- 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
--- /dev/null
+# Hey emacs! This is a -*- Perl -*- script!
+# Text_utils -- Perl utility functions for lintian
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# 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 http://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 Text_utils;
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(split_paragraphs wrap_paragraphs dtml_to_html dtml_to_text);
+
+use strict;
+
+# requires wrap() function
+use Text::Wrap;
+# requires fail() function
+use Util;
+
+# html_wrap -- word-wrap a paragaph. The wrap() function from Text::Wrap
+# is not suitable, because it chops words that are longer than the line
+# length.
+sub html_wrap {
+ my ($lead, @text) = @_;
+ my @words = split(' ', join(' ', @text));
+ # subtract 1 to compensate for the lack of a space before the first word.
+ my $ll = length($lead) - 1;
+ my $cnt = 0;
+ my $r = "";
+
+ while ($cnt <= $#words) {
+ if ($ll + 1 + length($words[$cnt]) > 76) {
+ if ($cnt == 0) {
+ # We're at the start of a line, and word still does not
+ # fit. Don't wrap it.
+ $r .= $lead . shift(@words) . "\n";
+ } else {
+ # start new line
+ $r .= $lead . join(' ', splice(@words, 0, $cnt)) . "\n";
+ $ll = length($lead) - 1;
+ $cnt = 0;
+ }
+ } else {
+ $ll += 1 + length($words[$cnt]);
+ $cnt++;
+ }
+ }
+
+ if ($#words >= 0) {
+ # finish last line
+ $r .= $lead . join(' ', @words) . "\n";
+ }
+
+ return $r;
+}
+
+# split_paragraphs -- splits a bunch of text lines into paragraphs.
+# This function returns a list of paragraphs.
+# Paragraphs are separated by empty lines. Each empty line is a
+# paragraph. Furthermore, indented lines are considered a paragraph.
+sub split_paragraphs {
+ return "" unless (@_);
+
+ my $t = join("\n",@_);
+
+ my ($l,@o);
+ while ($t) {
+ $t =~ s/^\.\n/\n/o;
+ # starts with space or empty line?
+ if (($t =~ s/^([ \t][^\n]*)\n?//o) or ($t =~ s/^()\n//o)) {
+ #FLUSH;
+ if ($l) {
+ $l =~ s/\s+/ /go;
+ $l =~ s/^\s+//o;
+ $l =~ s/\s+$//o;
+ push(@o,$l);
+ undef $l;
+ }
+ #
+ push(@o,$1);
+ }
+ # normal line?
+ elsif ($t =~ s/^([^\n]*)\n?//o) {
+ $l .= "$1 ";
+ }
+ # what else can happen?
+ else {
+ fail("internal error in wrap");
+ }
+ }
+ #FLUSH;
+ if ($l) {
+ $l =~ s/\s+/ /go;
+ $l =~ s/^\s+//o;
+ $l =~ s/\s+$//o;
+ push(@o,$l);
+ undef $l;
+ }
+ #
+
+ return @o;
+}
+
+sub dtml_to_html {
+ my @o;
+
+ my $pre=0;
+ for $_ (@_) {
+ s,\&maint\;,<a href=\"mailto:lintian-maint\@debian.org\">Lintian maintainer</a>,o; # "
+ s,\&debdev\;,<a href=\"mailto:debian-devel\@lists.debian.org\">debian-devel</a>,o; # "
+
+ # empty line?
+ if (/^\s*$/o) {
+ if ($pre) {
+ push(@o,"\n");
+ }
+ }
+ # preformatted line?
+ elsif (/^\s/o) {
+ if (not $pre) {
+ push(@o,"<pre>");
+ $pre=1;
+ }
+ push(@o,"$_");
+ }
+ # normal line
+ else {
+ if ($pre) {
+ push(@o,"</pre>");
+ $pre=0;
+ }
+ push(@o,"<p>$_\n");
+ }
+ }
+ if ($pre) {
+ push(@o,"</pre>");
+ $pre=0;
+ }
+
+ return @o;
+}
+
+sub dtml_to_text {
+ for $_ (@_) {
+ # substitute Lintian &tags;
+ s,&maint;,lintian-maint\@debian.org,go;
+ s,&debdev;,debian-devel\@lists.debian.org,go;
+
+ # substitute HTML <tags>
+ s,<i>,<,go;
+ s,</i>,>,go;
+ s,<[^>]+>,,go;
+
+ # substitute HTML &tags;
+ s,<,<,go;
+ s,>,>,go;
+ s,&,\&,go;
+
+ # preformatted?
+ if (not /^\s/o) {
+ # no.
+
+ s,\s\s+, ,go;
+ s,^ ,,o;
+ s, $,,o;
+ }
+ }
+
+ return @_;
+}
+
+# wrap_paragraphs -- wrap paragraphs in dpkg/dselect style.
+# indented lines are not wrapped but displayed "as is"
+sub wrap_paragraphs {
+ my $lead = shift;
+ my $html = 0;
+
+ if ($lead eq 'HTML') {
+ $html = 1;
+ $lead = shift;
+ }
+
+ my $o;
+ for my $t (split_paragraphs(@_)) {
+ # empty or indented line?
+ if ($t =~ /^$/ or $t =~ /^\s/) {
+ $o .= "$lead$t\n";
+ } else {
+ if ($html) {
+ $o .= html_wrap($lead, "$t\n");
+ } else {
+ $o .= wrap($lead, $lead, "$t\n");
+ }
+ }
+ }
+ return $o;
+}
+
+1;
--- /dev/null
+# Hey emacs! This is a -*- Perl -*- script!
+# Util -- Perl utility functions for lintian
+
+# Copyright (C) 1998 Christian Schwarz
+#
+# 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 http://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 Util;
+use strict;
+
+use Exporter;
+
+# Force export as soon as possible, since some of the modules we load also
+# depend on us and the sequencing can cause things not to be exported
+# otherwise.
+our (@ISA, @EXPORT);
+BEGIN {
+ @ISA = qw(Exporter);
+ @EXPORT = qw(parse_dpkg_control
+ read_dpkg_control
+ get_deb_info
+ get_dsc_info
+ slurp_entire_file
+ get_file_checksum
+ file_is_encoded_in_non_utf8
+ fail
+ system_env
+ delete_dir
+ copy_dir
+ gunzip_file
+ touch_file
+ perm2oct);
+}
+
+use FileHandle;
+use Maemian::Command qw(spawn);
+use Maemian::Output qw(string);
+use Digest::MD5;
+
+# general function to read dpkg control files
+# this function can parse output of `dpkg-deb -f', .dsc,
+# and .changes files (and probably all similar formats)
+# arguments:
+# $filehandle
+# $debconf_flag (true if the file is a debconf template file)
+# output:
+# list of hashes
+# (a hash contains one sections,
+# keys in hash are lower case letters of control fields)
+sub parse_dpkg_control {
+ my ($CONTROL, $debconf_flag) = @_;
+
+ my @data;
+ my $cur_section = 0;
+ my $open_section = 0;
+ my $last_tag;
+
+ local $_;
+ while (<$CONTROL>) {
+ chomp;
+
+ # FIXME: comment lines are only allowed in debian/control and should
+ # be an error for other control files.
+ next if /^\#/;
+
+ # empty line?
+ if ((!$debconf_flag && m/^\s*$/) or ($debconf_flag && m/^$/)) {
+ if ($open_section) { # end of current section
+ $cur_section++;
+ $open_section = 0;
+ }
+ }
+ # pgp sig?
+ elsif (m/^-----BEGIN PGP SIGNATURE/) { # skip until end of signature
+ while (<$CONTROL>) {
+ last if m/^-----END PGP SIGNATURE/o;
+ }
+ }
+ # other pgp control?
+ elsif (m/^-----BEGIN PGP/) { # skip until the next blank line
+ while (<$CONTROL>) {
+ last if /^\s*$/o;
+ }
+ }
+ # new empty field?
+ elsif (m/^(\S+):\s*$/o) {
+ $open_section = 1;
+
+ my ($tag) = (lc $1);
+ $data[$cur_section]->{$tag} = '';
+
+ $last_tag = $tag;
+ }
+ # new field?
+ elsif (m/^(\S+):\s*(.*)$/o) {
+ $open_section = 1;
+
+ # Policy: Horizontal whitespace (spaces and tabs) may occur
+ # immediately before or after the value and is ignored there.
+ my ($tag,$value) = (lc $1,$2);
+ $value =~ s/\s+$//;
+ $data[$cur_section]->{$tag} = $value;
+
+ $last_tag = $tag;
+ }
+ # continued field?
+ elsif (m/^([ \t].*)$/o) {
+ $open_section or fail("syntax error in section $cur_section after the tag $last_tag: $_");
+
+ # Policy: Many fields' values may span several lines; in this case
+ # each continuation line must start with a space or a tab. Any
+ # trailing spaces or tabs at the end of individual lines of a
+ # field value are ignored.
+ my $value = $1;
+ $value =~ s/\s+$//;
+ $data[$cur_section]->{$last_tag} .= "\n" . $value;
+ }
+ }
+
+ return @data;
+}
+
+sub read_dpkg_control {
+ my ($file, $debconf_flag) = @_;
+
+ if (not _ensure_file_is_sane($file)) {
+ return undef;
+ }
+
+ open(my $CONTROL, '<', $file)
+ or fail("cannot open control file $file for reading: $!");
+ my @data = parse_dpkg_control($CONTROL, $debconf_flag);
+ close($CONTROL)
+ or fail("pipe for control file $file exited with status: $?");
+ return @data;
+}
+
+sub get_deb_info {
+ my ($file) = @_;
+
+ if (not _ensure_file_is_sane($file)) {
+ return undef;
+ }
+
+ # `dpkg-deb -f $file' is very slow. Instead, we use ar and tar.
+ my $opts = { pipe_out => FileHandle->new };
+ spawn($opts,
+ ['ar', 'p', $file, 'control.tar.gz'],
+ '|', ['tar', '--wildcards', '-xzO', '-f', '-', '*control'])
+ or fail("cannot fork to unpack $file: $opts->{exception}\n");
+ my @data = parse_dpkg_control($opts->{pipe_out});
+ $opts->{harness}->finish();
+ return $data[0];
+}
+
+sub get_dsc_info {
+ my ($file) = @_;
+
+ if (not _ensure_file_is_sane($file)) {
+ return undef;
+ }
+
+ my @data = read_dpkg_control($file);
+ return $data[0];
+}
+
+sub _ensure_file_is_sane {
+ my ($file) = @_;
+
+ # if file exists and is not 0 bytes
+ if (-f $file and -s $file) {
+ return 1;
+ }
+ return 0;
+}
+
+sub slurp_entire_file {
+ my $file = shift;
+ open(C, '<', $file)
+ or fail("cannot open file $file for reading: $!");
+ local $/;
+ local $_ = <C>;
+ close(C);
+ return $_;
+}
+
+sub get_file_checksum {
+ my ($alg, $file) = @_;
+ open (FILE, '<', $file) or fail("Couldn't open $file");
+ my $digest;
+ if ($alg eq 'md5') {
+ $digest = Digest::MD5->new;
+ } elsif ($alg =~ /sha(\d+)/) {
+ require Digest::SHA;
+ $digest = Digest::SHA->new($1);
+ }
+ $digest->addfile(*FILE);
+ close FILE or fail("Couldn't close $file");
+ return $digest->hexdigest;
+}
+
+sub file_is_encoded_in_non_utf8 {
+ my ($file, $type, $pkg) = @_;
+ my $non_utf8 = 0;
+
+ open (ICONV, '-|', "env LANG=C iconv -f utf8 -t utf8 $file 2>&1")
+ or fail("failure while checking encoding of $file for $type package $pkg");
+ my $line = 1;
+ while (<ICONV>) {
+ if (m/iconv: illegal input sequence at position \d+$/) {
+ $non_utf8 = 1;
+ last;
+ }
+ $line++
+ }
+ close ICONV;
+
+ return $line if $non_utf8;
+ return 0;
+}
+
+# Just like system, except cleanses the environment first to avoid any strange
+# side effects due to the user's environment.
+sub system_env {
+ my @whitelist = qw(PATH INTLTOOL_EXTRACT);
+ my %newenv = map { exists $ENV{$_} ? ($_ => $ENV{$_}) : () } @whitelist;
+ my $pid = fork;
+ if (not defined $pid) {
+ return -1;
+ } elsif ($pid == 0) {
+ %ENV = %newenv;
+ exec @_ or die("exec of $_[0] failed: $!\n");
+ } else {
+ waitpid $pid, 0;
+ return $?;
+ }
+}
+
+# Translate permission strings like `-rwxrwxrwx' into an octal number.
+sub perm2oct {
+ my ($t) = @_;
+
+ my $o = 0;
+
+ $t =~ m/^.(.)(.)(.)(.)(.)(.)(.)(.)(.)/o;
+
+ $o += 00400 if $1 eq 'r'; # owner read
+ $o += 00200 if $2 eq 'w'; # owner write
+ $o += 00100 if $3 eq 'x'; # owner execute
+ $o += 04000 if $3 eq 'S'; # setuid
+ $o += 04100 if $3 eq 's'; # setuid + owner execute
+ $o += 00040 if $4 eq 'r'; # group read
+ $o += 00020 if $5 eq 'w'; # group write
+ $o += 00010 if $6 eq 'x'; # group execute
+ $o += 02000 if $6 eq 'S'; # setgid
+ $o += 02010 if $6 eq 's'; # setgid + group execute
+ $o += 00004 if $7 eq 'r'; # other read
+ $o += 00002 if $8 eq 'w'; # other write
+ $o += 00001 if $9 eq 'x'; # other execute
+ $o += 01000 if $9 eq 'T'; # stickybit
+ $o += 01001 if $9 eq 't'; # stickybit + other execute
+
+ return $o;
+}
+
+sub delete_dir {
+ return spawn(undef, ['rm', '-rf', '--', @_]);
+}
+
+sub copy_dir {
+ return spawn(undef, ['cp', '-a', '--', @_]);
+}
+
+sub gunzip_file {
+ my ($in, $out) = @_;
+ spawn({out => $out, fail => 'error'},
+ ['gzip', '-dc', $in]);
+}
+
+# create an empty file
+# --okay, okay, this is not exactly what `touch' does :-)
+sub touch_file {
+ open(T, '>', $_[0]) or return 0;
+ close(T) or return 0;
+
+ return 1;
+}
+
+sub fail {
+ my $str;
+ if (@_) {
+ $str = string('internal error', @_);
+ } elsif ($!) {
+ $str = string('internal error', "$!");
+ } else {
+ $str = string('internal error');
+ }
+ $! = 2; # set return code outside eval()
+ die $str;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: t
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 ts=8
use warnings;
use Getopt::Long;
use Carp;
-# Cannot yet pull in all of Lintian
-# unshift @INC, "/home/jeremiah/maemian/lib";
-# require Maemian::Output;
-# my $lintout = new Maemian::Output;
+
+unshift @INC, "/home/jeremiah/maemian/lib";
+require Maemian::Output;
+my $lintout = new Maemian::Output;
# --- Command line options
my $inputfile; # --- A file passed to maemian
<meta name="license" content="Copyright (c) 2009 JEREMIAH FOSTER" />
<body>
<h4>Hello and welcome to Maemian, the policy checker for Maemo.</h4>
-<p>You can browse the repo here <a href="https://git.maemo.org/projects/maemian/gitweb?p=maemian">git repo</a>
+<p>You can browse the repo here <a href="https://git.maemo.org/projects/maemian/gitweb?p=maemian">git repo</a><br>If you want to check out
+the code and hack on it, you can clone the repository this way:<br>
+<code>git clone https://git.maemo.org/projects/maemian</code>
<p>Maemian is designed to be a tool to check policy in maemo packages like lintian does for debian packages. The
overall aim is to increase quality in maemo applications. There is a <a href="http://wiki.maemo.org/Extras_repository_process_definition">
wiki page which defines</a> some of the current issues and ideas reagarding quality assuarance in maemo.
projects / maemian / commitdiff