From 4d090cc4d727a709c4af6da3081c91de1217b697 Mon Sep 17 00:00:00 2001 From: Jeremiah Foster Date: Thu, 28 May 2009 15:05:59 +0300 Subject: [PATCH] Added libraries needed for lintian-style output. --- lib/Maemian/Command.pm | 329 +++++++++++++++++++++++++++++++++++++++++++ lib/Maemian/Tag/Info.pm | 355 +++++++++++++++++++++++++++++++++++++++++++++++ lib/Text_utils.pm | 214 ++++++++++++++++++++++++++++ lib/Util.pm | 322 ++++++++++++++++++++++++++++++++++++++++++ maemian | 8 +- www/index.html | 4 +- 6 files changed, 1227 insertions(+), 5 deletions(-) create mode 100644 lib/Maemian/Command.pm create mode 100644 lib/Maemian/Tag/Info.pm create mode 100644 lib/Text_utils.pm create mode 100644 lib/Util.pm diff --git a/lib/Maemian/Command.pm b/lib/Maemian/Command.pm new file mode 100644 index 0000000..053fb70 --- /dev/null +++ b/lib/Maemian/Command.pm @@ -0,0 +1,329 @@ +# Copyright © 2008 Frank Lichtenheld +# +# 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 + +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 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 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_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 + +If you used one of the C 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 + +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 for Lintian. + +=head1 SEE ALSO + +lintian(1), IPC::Run + +=cut diff --git a/lib/Maemian/Tag/Info.pm b/lib/Maemian/Tag/Info.pm new file mode 100644 index 0000000..fc173a6 --- /dev/null +++ b/lib/Maemian/Tag/Info.pm @@ -0,0 +1,355 @@ +# -*- 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 . + +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 or C and defaults to C if no format is +specified. If C, 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, 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 () { + 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($title) : $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[ ($title)]; + } + + return $text; +} + +# Format the contents of the Ref attribute of a tag. Handles manual +# references in the form
, manpage references in the +# form (
), 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 $ref manual page); + } elsif ($ref =~ m,^(ftp|https?)://,) { + $text = qq($ref); + } + 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 or C. + +=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 if not set. The B program normally takes +care of setting it. + +=back + +=head1 AUTHOR + +Originally written by Russ Allbery 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 diff --git a/lib/Text_utils.pm b/lib/Text_utils.pm new file mode 100644 index 0000000..96e745a --- /dev/null +++ b/lib/Text_utils.pm @@ -0,0 +1,214 @@ +# 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\;,Lintian maintainer,o; # " + s,\&debdev\;,debian-devel,o; # " + + # empty line? + if (/^\s*$/o) { + if ($pre) { + push(@o,"\n"); + } + } + # preformatted line? + elsif (/^\s/o) { + if (not $pre) { + push(@o,"
");
+		$pre=1;
+	    }
+	    push(@o,"$_");
+	}
+	# normal line
+	else {
+	    if ($pre) {
+		push(@o,"
"); + $pre=0; + } + push(@o,"

$_\n"); + } + } + if ($pre) { + push(@o,""); + $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 + s,,<,go; + s,,>,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; diff --git a/lib/Util.pm b/lib/Util.pm new file mode 100644 index 0000000..1b7cb26 --- /dev/null +++ b/lib/Util.pm @@ -0,0 +1,322 @@ +# 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 $_ = ; + 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 () { + 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 diff --git a/maemian b/maemian index 754d45c..376c890 100755 --- a/maemian +++ b/maemian @@ -44,10 +44,10 @@ use strict; 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 diff --git a/www/index.html b/www/index.html index dd1513f..d3f8e6e 100644 --- a/www/index.html +++ b/www/index.html @@ -7,7 +7,9 @@

Hello and welcome to Maemian, the policy checker for Maemo.

-

You can browse the repo here git repo +

You can browse the repo here git repo
If you want to check out +the code and hack on it, you can clone the repository this way:
+git clone https://git.maemo.org/projects/maemian

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 wiki page which defines some of the current issues and ideas reagarding quality assuarance in maemo. -- 1.7.9.5