From c2101103f215ca8b06b9a261ebe38c26d128954a Mon Sep 17 00:00:00 2001 From: Jeremiah Foster Date: Tue, 2 Jun 2009 17:43:05 +0300 Subject: [PATCH] First commit to the experimental branch. --- maemian | 1927 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- www/manual.html | 4 +- 2 files changed, 1875 insertions(+), 56 deletions(-) diff --git a/maemian b/maemian index c622f4f..b3e7ac0 100755 --- a/maemian +++ b/maemian @@ -1,10 +1,11 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w +# Maemian -- Maemo package checker # Copyright (C) Jeremiah C. Foster 2009, based on: -# Lintian -- Debian package checker +# Maemian -- Debian package checker # Copyright (C) 1998 Christian Schwarz and Richard Braakman - +# # This program is free software. It is distributed 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 @@ -27,74 +28,1890 @@ maemian - Maemo package checker =head1 -Maemian is the maemo version of lintian - a policy checker designed to +Maemian is the maemo version of maemian - a policy checker designed to assure the quality of a package uploaded into the maemo.org repositories. The goal of maemian is to improve quality by checking that the maemo packaging policy is followed. In order to do that it reads files in the uploaded deb. Currently maemian only looks at the .dsc file and tries to ascertain who uploaded it, and if they used the correct email address. -=head1 EXAMPLE - -maemian -i file.dsc - =cut use strict; -use warnings; -use Getopt::Long; -use Carp; use lib qw(lib/); -use Maemian::Output; - -# --- Output settings. -my $out = new Maemian::Output; -# --- If this is set to true, then you only get msgs -$out->quiet(0); -$out->msg("Notice on"); -# --- If this is set to true, then you will get verbose messages. -$out->verbose(1); -$out->v_msg("Verbose on"); - -$out->color("auto"); -# --- Command line options -my $inputfile; # --- A file passed to maemian -GetOptions ("inputfile|i=s" => \$inputfile); - -sub file_tests { - use File::Basename; - my $path = shift; - if (-r $path) { - my ($filename, $dirs) = fileparse($path); - # --- maemo is a trademarked term - if ($filename =~ /maemo/) { - print "W: Any use of the word \"maemo\" is subject to trademark.\n"; - } - # --- Open file into an array - open my $file, '<', $path or die "Cannot open file: $!\n"; - my @lines = <$file>; +use Getopt::Long; + +my $MAEMIAN_VERSION = "0.2"; # External Version number (Where is the canonical version?) +my $BANNER = "Maemian v$MAEMIAN_VERSION"; # Version Banner - text form +my $LAB_FORMAT = 9; # Lab format Version Number + # increased whenever incompatible + # changes are done to the lab + # so that all packages are re-unpacked + +# Variables used to record commandline options +# Commented out variables have "defined" checks somewhere to determine if +# they were set via commandline or environment variables +my $pkg_mode = 'a'; # auto -- automatically search for + # binary and source pkgs +my $verbose = 0; #flag for -v|--verbose switch +my $quiet = 0; #flag for -q|--quiet switch +my @debug; +my $check_everything = 0; #flag for -a|--all switch +my $maemian_info = 0; #flag for -i|--info switch +our $display_experimentaltags = 0; #flag for -E|--display-experimental switch +our $display_pedantictags = 0; #flag for --pedantic switch +my $unpack_level = undef; #flag for -l|--unpack-level switch +our $no_override = 0; #flag for -o|--no-override switch +our $show_overrides = 0; #flag for --show-overrides switch +my $color = 'never'; #flag for --color switch +my $check_checksums = 0; #flag for -m|--md5sums|--checksums switch +my $allow_root = 0; #flag for --allow-root switch +my $fail_on_warnings = 0; #flag for --fail-on-warnings switch +my $keep_lab = 0; #flag for --keep-lab switch +my $packages_file = 0; #string for the -p option +our $OPT_MAEMIAN_LAB = ""; #string for the --lab option +our $OPT_MAEMIAN_ARCHIVEDIR = "";#string for the --archivedir option +our $OPT_MAEMIAN_DIST = ""; #string for the --dist option +our $OPT_MAEMIAN_ARCH = ""; #string for the --arch option +our $OPT_MAEMIAN_AREA = ""; #string for the --area option +# These options can also be used via default or environment variables +our $MAEMIAN_CFG = ""; #config file to use +our $MAEMIAN_ROOT = "/home/jeremiah/maemian/"; #location of the maemian modules +our $OPT_MAEMIAN_SECTION = ""; #old name for OPT_MAEMIAN_ARCH + +my $experimental_output_opts = undef; + +my @severities = qw(wishlist minor normal important serious); +my @certainties = qw(wild-guess possible certain); +my %display_level = (); +my %display_source = (); + +my $schedule; + +my $action; +my $checks; +my $check_tags; +my $dont_check; +my $unpack_info; +my $cwd; +my $cleanup_filename; +my $exit_code = 0; +my $LAB; + +my %collection_info; +my %already_scheduled; +my %checks; +my %check_abbrev; +my %unpack_infos; +my %check_info; + +# reset configuration variables +our $MAEMIAN_LAB = undef; +our $MAEMIAN_ARCHIVEDIR = undef; +our $MAEMIAN_DIST = undef; +our $MAEMIAN_UNPACK_LEVEL = undef; +our $MAEMIAN_ARCH = undef; +our $MAEMIAN_SECTION = undef; +our $MAEMIAN_AREA = undef; +# }}} + +# {{{ Setup Code + +#turn off file buffering +$| = 1; + +# reset locale definition (necessary for tar) +$ENV{'LC_ALL'} = 'C'; +# reset timezone definition (also for tar) +$ENV{'TZ'} = ''; + +# }}} + +# {{{ Process Command Line + +####################################### +# Subroutines called by various options +# in the options hash below. These are +# invoked to process the commandline +# options +####################################### +# Display Command Syntax +# Options: -h|--help +sub syntax { + print "$BANNER\n"; + print <<"EOT-EOT-EOT"; +Syntax: maemian [action] [options] [--] [packages] ... +Actions: + -S, --setup-lab set up static lab + -R, --remove-lab remove static lab + -c, --check check packages (default action) + -C X, --check-part X check only certain aspects + -X X, --dont-check-part X don\'t check certain aspects + -T X, --tags X only run checks needed for requested tags + --tags-from-file X like --tags, but read list from file + -u, --unpack only unpack packages in the lab + -r, --remove remove package from the lab +General options: + -h, --help display short help text + -v, --verbose verbose messages + -V, --version display Maemian version and exit + --print-version print unadorned version number and exit + -d, --debug turn Maemian\'s debug messages ON + -q, --quiet suppress all informational messages +Behaviour options: + -i, --info give detailed info about tags + -I, --display-info display "I:" tags (normally suppressed) + -E, --display-experimental display "X:" tags (normally suppressed) + --pedantic display "P:" tags (normally suppressed) + -L, --display-level display tags with the specified level + --display-source X restrict displayed tags by source + -l X, --unpack-level X set default unpack level to X + -o, --no-override ignore overrides + --show-overrides output tags that have been overriden + --color never/always/auto disable, enable, or enable color for TTY + -U X, --unpack-info X specify which info should be collected + -m, --md5sums, --checksums check checksums when processing a .changes file + --allow-root suppress maemian\'s warning when run as root + --fail-on-warnings return a non-zero exit status if warnings found + --keep-lab keep lab after run, even if temporary +Configuration options: + --cfg CONFIGFILE read CONFIGFILE for configuration + --lab LABDIR use LABDIR as permanent laboratory + --archivedir ARCHIVEDIR location of Debian archive to scan for packages + --dist DIST scan packages in this distribution (e.g. sid) + --area AREA scan packages in this archive area (e.g. main) + --arch ARCH scan packages with architecture ARCH + --root ROOTDIR use ROOTDIR instead of /usr/share/maemian +Package selection options: + -a, --all process all packages in distribution + -b, --binary process only binary packages + -s, --source process only source packages + --udeb process only udeb packages + -p X, --packages-file X process all files in file (special syntax!) +EOT-EOT-EOT + + exit 0; +} + +# Display Version Banner +# Options: -V|--version, --print-version +sub banner { + if ($_[0] eq 'print-version') { + print "$MAEMIAN_VERSION\n"; + } else { + print "$BANNER\n"; + } + exit 0; +} + +# Record action requested +# Options: -S, -R, -c, -u, -r +sub record_action { + if ($action) { + die("too many actions specified: $_[0]"); + } + $action = "$_[0]"; +} + +# Record Parts requested for checking +# Options: -C|--check-part +sub record_check_part { + if (defined $action and $action eq 'check' and $checks) { + die("multiple -C or --check-part options not allowed"); + } + if ($dont_check) { + die("both -C or --check-part and -X or --dont-check-part options not allowed"); + } + if ($action) { + die("too many actions specified: $_[0]"); + } + $action = 'check'; + $checks = "$_[1]"; +} + +# Record Parts requested for checking +# Options: -T|--tags +sub record_check_tags { + if (defined $action and $action eq 'check' and $check_tags) { + die("multiple -T or --tags options not allowed"); + } + if ($checks) { + die("both -T or --tags and -C or --check-part options not allowed"); + } + if ($dont_check) { + die("both -T or --tags and -X or --dont-check-part options not allowed"); + } + if ($action) { + die("too many actions specified: $_[0]"); + } + $action = 'check'; + $check_tags = "$_[1]"; +} + +# Record Parts requested for checking +# Options: --tags-from-file +sub record_check_tags_from_file { + open my $file, '<', $_[1] + or fail("failed to open $_[1]: $!"); + my $tags = join(',', map { chomp($_); $_ } <$file>); close $file; - my ($field, $maintainer) = map { split /: / } grep /Maintainer/, @lines; - chomp($maintainer); - if ($maintainer =~ /(ubuntu|debian)/i) { - print "W: Maintainer email address ($maintainer) might be the same as upstream.\n"; + record_check_tags($_[0], $tags); +} + + +# Record Parts requested not to check +# Options: -X|--dont-check-part X +sub record_dont_check_part { + if (defined $action and $action eq 'check' and $dont_check) { + die("multiple -X or --dont-check-part options not allowed"); } - else { - $out->msg("$maintainer"); + if ($checks) { + die("both -C or --check-part and -X or --dont-check-part options not allowed"); } - if (grep /BEGIN PGP SIGNED MESSAGE/, @lines) { - $out->v_msg("$filename is signed"); + if ($action) { + die("too many actions specified: $_[0]"); } - $out->debug_msg(3, "\n$dirs\n$filename\n"); - } - else { - croak "File not readable: $!\n"; - } + $action = 'check'; + $dont_check = "$_[1]"; +} + + +# Process for -U|--unpack-info flag +sub record_unpack_info { + if ($unpack_info) { + die("multiple -U or --unpack-info options not allowed"); + } + $unpack_info = "$_[1]"; } -if ($inputfile) { - file_tests($inputfile); +# Record what type of data is specified +# Options: -b|--binary, -s|--source, --udeb +sub record_pkgmode { + $pkg_mode = 'b' if $_[0] eq 'binary'; + $pkg_mode = 's' if $_[0] eq 'source'; + $pkg_mode = 'u' if $_[0] eq 'udeb'; +} + +# Process -L|--display-level flag +sub record_display_level { + my $level = $_[1]; + if ($level =~ m/^\+(.+)/) { + set_display_level($1, 1); + } elsif ($level =~ m/^\-(.+)/) { + set_display_level($1, 0); + } elsif ($level =~ m/^\=?(.+)/) { + reset_display_level(); + set_display_level($1, 1); + } else { + die "invalid argument to --display-level: $level\n"; + } +} + +# Process -I|--display-info flag +sub display_infotags { + foreach my $s (@severities) { + set_display_level($s, 1); + } +} + +# Process --display-source flag +sub record_display_source { + $display_source{$_[1]} = 1; +} + +# Clears current display level information, disabling all severities and +# certainties +sub reset_display_level { + foreach my $s (@severities) { + foreach my $c (@certainties) { + $display_level{$s}{$c} = 0; + } + } +} + +sub set_display_level_multi { + my ($op, $level, $val) = @_; + + my @inc_severities = @severities; + my @inc_certainties = @certainties; + my $inc_border = ($op =~ /^[<>]=$/) ? 1 : 0; + if ($op =~ /^>/) { + @inc_severities = reverse @inc_severities; + @inc_certainties = reverse @inc_certainties; + } + my $severity = join("|", @severities); + my $certainty = join("|", @certainties); + if ($level =~ m/^($severity)$/) { + foreach my $s (cut_list($level, $inc_border, @inc_severities)) { + map { $display_level{$s}{$_} = $val } @certainties; + } + } elsif ($level =~ m/^($certainty)$/) { + foreach my $c (cut_list($level, $inc_border, @inc_certainties)) { + map { $display_level{$_}{$c} = $val } @severities; + } + } elsif ($level =~ m/^($severity)\/($certainty)$/) { + foreach my $s (cut_list($1, $inc_border, @inc_severities)) { + foreach my $c (cut_list($2, $inc_border, @inc_certainties)) { + $display_level{$s}{$c} = $val; + } + } + } else { + die "invalid argument to --display-level: $level\n"; + } + +} + +sub cut_list { + my ($border, $inc_border, @list) = @_; + + my (@newlist, $found); + foreach (@list) { + if ($_ eq $border) { + push @newlist, $_ if $inc_border; + $found = 1; + last; + } else { + push @newlist, $_; + } + } + die "internal error: cut_list did not find border $border\n" + unless $found; + if (!$inc_border and !@newlist + and $border eq $list[0]) { + warn "warning: display level $border specified with > (or <) is empty set, assuming >= (or <=)\n"; + push @newlist, $list[0]; + } + + return @newlist; +} + +# Parse input display level to enable (val 1) or disable (val 0) it +# accordingly +sub set_display_level { + my ($level, $val) = @_; + if ($level =~ m/^([<>]=?)(.+)/) { + set_display_level_multi($1, $2, $val); + return; + } + + my $severity = join("|", @severities); + my $certainty = join("|", @certainties); + if ($level =~ m/^($severity)$/) { + map { $display_level{$1}{$_} = $val } @certainties; + } elsif ($level =~ m/^($certainty)$/) { + map { $display_level{$_}{$1} = $val } @severities; + } elsif ($level =~ m/^($severity)\/($certainty)$/) { + $display_level{$1}{$2} = $val; + } else { + die "invalid argument to --display-level: $level\n"; + } +} + +# Hash used to process commandline options +my %opthash = ( + # ------------------ actions + "setup-lab|S" => \&record_action, + "remove-lab|R" => \&record_action, + "check|c" => \&record_action, + "check-part|C=s" => \&record_check_part, + "tags|T=s" => \&record_check_tags, + "tags-from-file=s" => \&record_check_tags_from_file, + "dont-check-part|X=s" => \&record_dont_check_part, + "unpack|u" => \&record_action, + "remove|r" => \&record_action, + + # ------------------ general options + "help|h" => \&syntax, + "version|V" => \&banner, + "print-version" => \&banner, + + "verbose|v" => \$verbose, + "debug|d" => \@debug, # Count the -d flags + "quiet|q" => \$quiet, + + # ------------------ behaviour options + "info|i" => \$maemian_info, + "display-info|I" => \&display_infotags, + "display-experimental|E" => \$display_experimentaltags, + "pedantic" => \$display_pedantictags, + "display-level|L=s" => \&record_display_level, + "display-source=s" => \&record_display_source, + "unpack-level|l=i" => \$unpack_level, + "no-override|o" => \$no_override, + "show-overrides" => \$show_overrides, + "color=s" => \$color, + "unpack-info|U=s" => \&record_unpack_info, + "checksums|md5sums|m" => \$check_checksums, + "allow-root" => \$allow_root, + "fail-on-warnings" => \$fail_on_warnings, + "keep-lab" => \$keep_lab, + # Note: Ubuntu has (and other derivatives might gain) a + # -D/--debian option to make maemian behave like in Debian, that + # is, to revert distribution-specific changes + + # ------------------ configuration options + "cfg=s" => \$MAEMIAN_CFG, + "lab=s" => \$OPT_MAEMIAN_LAB, + "archivedir=s" => \$OPT_MAEMIAN_ARCHIVEDIR, + "dist=s" => \$OPT_MAEMIAN_DIST, + "area=s" => \$OPT_MAEMIAN_AREA, + "section=s" => \$OPT_MAEMIAN_AREA, + "arch=s" => \$OPT_MAEMIAN_ARCH, + "root=s" => \$MAEMIAN_ROOT, + + # ------------------ package selection options + "all|a" => \$check_everything, + "binary|b" => \&record_pkgmode, + "source|s" => \&record_pkgmode, + "udeb" => \&record_pkgmode, + "packages-file|p=s" => \$packages_file, + + # ------------------ experimental + "exp-output:s" => \$experimental_output_opts, + ); + +# init display level settings +reset_display_level(); +set_display_level_multi('>=', 'important', 1); +set_display_level_multi('>=', 'normal/possible', 1); +set_display_level('minor/certain', 1); + +# init commandline parser +Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev'); + +# process commandline options +GetOptions(%opthash) + or die("error parsing options\n"); + +# determine current working directory--we'll need this later +chop($cwd = `pwd`); + +# determine MAEMIAN_ROOT if it was not set with --root. +$MAEMIAN_ROOT = $MAEMIAN_ROOT || $ENV{'MAEMIAN_ROOT'}; +if (defined $MAEMIAN_ROOT) { + unless ($MAEMIAN_ROOT =~ m,^/,) { + $MAEMIAN_ROOT = "$cwd/$MAEMIAN_ROOT"; + } } else { - croak "No input file found: $!\n"; + $MAEMIAN_ROOT = '/usr/share/maemian'; +} + +# keep-lab implies unpack-level=2 unless explicetly +# given otherwise +if ($keep_lab and not defined $unpack_level) { + $unpack_level = 2; +} + +# option --all and packages specified at the same time? +if (($check_everything or $packages_file) and $#ARGV+1 > 0) { + print STDERR "warning: options -a or -p can't be mixed with package parameters!\n"; + print STDERR "(will ignore -a or -p option)\n"; + undef $check_everything; + undef $packages_file; +} + +# check permitted values for --color +if ($color and $color !~ /^(never|always|auto|html)$/) { + die "invalid argument to --color: $color\n"; +} + +# check specified action +$action = 'check' unless $action; + +# check for arguments +if ($action =~ /^(check|unpack|remove)$/ and $#ARGV == -1 and not $check_everything and not $packages_file) { + syntax(); +} + +# }}} + +# {{{ Setup Configuration +# +# root permissions? +# check if effective UID is 0 +if ($> == 0 and not $allow_root) { + print STDERR "warning: maemian's authors do not recommend running it with root privileges!\n"; +} + +# search for configuration file if it was not set with --cfg +# do not search the default locations if it was set. +if ($MAEMIAN_CFG) { +} elsif (exists $ENV{'MAEMIAN_CFG'} && + -f ($MAEMIAN_CFG = $ENV{'MAEMIAN_CFG'})) { +} elsif (-f ($MAEMIAN_CFG = $MAEMIAN_ROOT . '/maemianrc')) { +} elsif (exists $ENV{'HOME'} && + -f ($MAEMIAN_CFG = $ENV{'HOME'} . '/.maemianrc')) { +} elsif (-f ($MAEMIAN_CFG = '/etc/maemianrc')) { +} else { + undef $MAEMIAN_CFG; +} + +use constant VARS => qw(LAB ARCHIVEDIR DIST UNPACK_LEVEL SECTION AREA ARCH); +# read configuration file +if ($MAEMIAN_CFG) { + open(CFG, '<', $MAEMIAN_CFG) + or die("cannot open configuration file $MAEMIAN_CFG for reading: $!"); + while () { + chop; + s/\#.*$//go; + s/\"//go; + next if m/^\s*$/o; + + # substitute some special variables + s,\$HOME/,$ENV{'HOME'}/,go; + s,\~/,$ENV{'HOME'}/,go; + + my $found = 0; + foreach my $var (VARS) { + no strict 'refs'; + $var = "MAEMIAN_$var"; + if (m/^\s*$var\s*=\s*(.*\S)\s*$/i) { + $$var = $1; + $found = 1; + last; + } + } + unless ($found) { + die "syntax error in configuration file: $_\n"; + } + } + close(CFG); +} + +# environment variables overwrite settings in conf file: +foreach (VARS) { + no strict 'refs'; + my $var = "MAEMIAN_$_"; + my $opt_var = "OPT_$var"; + $$var = $ENV{$var} if $ENV{$var}; + $$var = $$opt_var if $$opt_var; +} + +# MAEMIAN_ARCH must have a value. +unless (defined $MAEMIAN_ARCH) { + if ($MAEMIAN_DIST) { + chop($MAEMIAN_ARCH=`dpkg --print-architecture`); + } else { + $MAEMIAN_ARCH = 'any'; + } +} + +# MAEMIAN_SECTION is deprecated in favour of MAEMIAN_AREA +if (defined $MAEMIAN_SECTION) { + print STDERR "warning: MAEMIAN_SECTION has been deprecated in favour of MAEMIAN_AREA.\n"; + if (defined $MAEMIAN_AREA) { + print STDERR "Using MAEMIAN_AREA as both were defined.\n"; + } else { + print STDERR "Both are currently accepted, but MAEMIAN_SECTION may be removed\n"; + print STDERR "in a future Maemian release.\n"; + $MAEMIAN_AREA = $MAEMIAN_SECTION; + } +} + +# determine requested unpack level +if (defined($unpack_level)) { + # specified through command line +} elsif (defined($MAEMIAN_UNPACK_LEVEL)) { + # specified via configuration file or env variable + $unpack_level = $MAEMIAN_UNPACK_LEVEL; +} else { + # determine by action + if (($action eq 'unpack') or ($action eq 'check')) { + $unpack_level = 1; + } else { + $unpack_level = 0; + } +} +unless (($unpack_level == 0) or ($unpack_level == 1) or ($unpack_level == 2)) { + die("bad unpack level $unpack_level specified"); +} + +$MAEMIAN_UNPACK_LEVEL = $unpack_level; + +# export current settings for our helper scripts +foreach (('ROOT', 'CFG', VARS)) { + no strict 'refs'; + my $var = "MAEMIAN_$_"; + if ($$var) { + $ENV{$var} = $$var; + } else { + $ENV{$var} = ""; + $$var = ""; + } +} + +my $debug = $#debug + 1; +$verbose = 1 if $debug; +$ENV{'MAEMIAN_DEBUG'} = $debug; + +# Loading maeian's own libraries (now that MAEMIAN_ROOT is known) +unshift @INC, "$MAEMIAN_ROOT/lib"; + +require Lab; + +require Util; +require Read_pkglists; + +import Util; + +require Tags; +import Tags; + +require Maemian::Data; +require Maemian::Schedule; +require Maemian::Output; +import Maemian::Output qw(:messages); +require Maemian::Command; +import Maemian::Command qw(spawn reap); +require Maemian::Check; +import Maemian::Check qw(check_maintainer); + +no warnings 'once'; +if (defined $experimental_output_opts) { + my %opts = map { split(/=/) } split( /,/, $experimental_output_opts ); + foreach (keys %opts) { + if ($_ eq 'format') { + if ($opts{$_} eq 'colons') { + require Maemian::Output::ColonSeparated; + $Maemian::Output::GLOBAL = new Maemian::Output::ColonSeparated; + } elsif ($opts{$_} eq 'letterqualifier') { + require Maemian::Output::LetterQualifier; + $Maemian::Output::GLOBAL = new Maemian::Output::LetterQualifier; + } elsif ($opts{$_} eq 'xml') { + require Maemian::Output::XML; + $Maemian::Output::GLOBAL = new Maemian::Output::XML; + } + } + no strict 'refs'; + ${"Tags::$_"} = $opts{$_}; + } +} + +$Maemian::Output::GLOBAL->verbose($verbose); +$Maemian::Output::GLOBAL->debug($debug); +$Maemian::Output::GLOBAL->quiet($quiet); +$Maemian::Output::GLOBAL->color($color); +$Maemian::Output::GLOBAL->showdescription($maemian_info); + +# Print Debug banner, now that we're finished determining +# the values and have Maemian::Output available +debug_msg(1, + $BANNER, + "Maemian root directory: $MAEMIAN_ROOT", + "Configuration file: $MAEMIAN_CFG", + "Laboratory: $MAEMIAN_LAB", + "Archive directory: $MAEMIAN_ARCHIVEDIR", + "Distribution: $MAEMIAN_DIST", + "Default unpack level: $MAEMIAN_UNPACK_LEVEL", + "Architecture: $MAEMIAN_ARCH", + delimiter(), + ); + +my @l_secs = read_dpkg_control("$MAEMIAN_ROOT/checks/maemian.desc"); +shift(@l_secs); +map { $_->{'script'} = 'maemian'; Tags::add_tag($_) } @l_secs; + +$Tags::show_experimental = $display_experimentaltags; +$Tags::show_pedantic = $display_pedantictags; +$Tags::show_overrides = $show_overrides; +%Tags::display_level = %display_level; +%Tags::display_source = %display_source; +%Tags::only_issue_tags = map { $_ => 1 } (split(/,/, $check_tags)) + + if defined $check_tags; +use warnings; +use vars qw(%source_info %binary_info %udeb_info); # from the above + +# Set up clean-up handlers. +undef $cleanup_filename; +$SIG{'INT'} = \&interrupted; +$SIG{'QUIT'} = \&interrupted; + +# }}} + +# {{{ Create/Maintain Lab and add any specified Debian Archives (*.debs) + +$LAB = new Lab( $MAEMIAN_LAB, $MAEMIAN_DIST ); + +####################################### +# Process -S option +if ($action eq 'setup-lab') { + if ($#ARGV+1 > 0) { # Cannot define Lab on the command line. + warning("ignoring additional command line arguments"); + } + + $LAB->setup_static() + or fail("There was an error while setting up the static lab."); + + exit 0; + +####################################### +# Process -R option +} elsif ($action eq 'remove-lab') { + if ($#ARGV+1 > 0) { + warning("ignoring additional command line arguments"); + } + + $LAB->delete_static() + or fail("There was an error while removing the static lab."); + + exit 0; + +####################################### +# Check for non deb specific actions +} elsif (not (($action eq 'unpack') or ($action eq 'check') + or ($action eq 'remove'))) { + fail("bad action $action specified"); +} + +# sanity check: +fail("maemian lab has not been set up correctly (perhaps you forgot to run maemian --setup-lab?)") + unless $LAB->is_lab(); + +#XXX: There has to be a cleaner way to do this +$MAEMIAN_LAB = $LAB->{dir}; + +# }}} + +# {{{ Compile list of files to process + +$schedule = new Maemian::Schedule(verbose => $verbose); +# process package/file arguments +while (my $arg = shift) { + # file? + if (-f $arg) { + # $arg contains absolute dir spec? + unless ($arg =~ m,^/,) { + $arg = "$cwd/$arg"; + } + + # .deb file? + if ($arg =~ /\.deb$/) { + $schedule->add_deb('b', $arg) + or warning("$arg is a zero-byte file, skipping"); + } + # .udeb file? + elsif ($arg =~ /\.udeb$/) { + $schedule->add_deb('u', $arg) + or warning("$arg is a zero-byte file, skipping"); + } + # .dsc file? + elsif ($arg =~ /\.dsc$/) { + $schedule->add_dsc($arg) + or warning("$arg is a zero-byte file, skipping"); + } + # .changes file? + elsif ($arg =~ /\.changes$/) { + # get directory and filename part of $arg + my ($arg_dir, $arg_name) = $arg =~ m,(.*)/([^/]+)$,; + + v_msg("Processing changes file $arg_name ..."); + + my ($data) = read_dpkg_control($arg); + if (not defined $data) { + warning("$arg is a zero-byte file, skipping"); + next; + } + Tags::set_pkg( $arg, $arg_name, "", "", 'binary' ); + + # If we don't have a Format key, something went seriously wrong. + # Tag the file and skip remaining processing. + if (!$data->{'format'}) { + tag('malformed-changes-file'); + next; + } + + # Description is mandated by dak, but only makes sense if binary + # packages are included. Don't tag pure source uploads. + if (!$data->{'description'} && $data->{'architecture'} ne 'source') { + tag("no-description-in-changes-file"); + } + + # check distribution field + if (defined $data->{distribution}) { + my $ubuntu_dists = Maemian::Data->new ('changelog-file/ubuntu-dists'); + my $ubuntu_regex = join('|', $ubuntu_dists->all); + my @distributions = split /\s+/o, $data->{distribution}; + for my $distribution (@distributions) { + if ($distribution eq 'UNRELEASED') { + # ignore + } elsif ($data->{version} =~ /ubuntu|$ubuntu_regex/ + or $distribution =~ /$ubuntu_regex/) { + if ($distribution !~ /^($ubuntu_regex)(-(proposed|updates|backports|security))?$/ ) { + tag("bad-ubuntu-distribution-in-changes-file", + $distribution); + } + } elsif (! (($distribution eq 'oldstable') + or ($distribution eq 'stable') + or ($distribution eq 'testing') + or ($distribution eq 'unstable') + or ($distribution eq 'experimental') + or ($distribution =~ /^\w+-backports$/) + or ($distribution =~ /^\w+-proposed-updates$/) + or ($distribution =~ /^\w+-security$/)) + ) { + # bad distribution entry + tag("bad-distribution-in-changes-file", + $distribution); + } + } + + if ($#distributions > 0) { + # Currently disabled until dak stops accepting the syntax + # tag("multiple-distributions-in-changes-file", + # $data->{'distribution'}); + } + } + + # Urgency is only recommended by Policy. + if (!$data->{'urgency'}) { + tag("no-urgency-in-changes-file"); + } else { + my $urgency = lc $data->{'urgency'}; + $urgency =~ s/ .*//; + unless ($urgency =~ /^(low|medium|high|critical|emergency)$/i) { + tag("bad-urgency-in-changes-file", $data->{'urgency'}); + } + } + + # Changed-By is optional in Policy, but if set, must be + # syntactically correct. It's also used by dak. + if ($data->{'changed-by'}) { + check_maintainer($data->{'changed-by'}, 'changed-by'); + } + + # process all listed `files:' + my %files; + + my $file_list = $data->{files} || ''; + for ( split /\n/, $file_list ) { + chomp; + s/^\s+//o; + next if $_ eq ''; + + my ($md5sum,$size,$section,$priority,$file) = split(/\s+/o, $_); + $files{$file}{md5} = $md5sum; + $files{$file}{size} = $size; + + # check section + if (($section eq 'non-free') or ($section eq 'contrib')) { + tag( "bad-section-in-changes-file", $file, $section ); + } + + } + + foreach my $alg (qw(sha1 sha256)) { + my $list = $data->{"checksums-$alg"} || ''; + for ( split /\n/, $list ) { + chomp; + s/^\s+//o; + next if $_ eq ''; + + my ($checksum,$size,$file) = split(/\s+/o, $_); + $files{$file}{$alg} = $checksum; + if ($files{$file}{size} != $size) { + tag( "file-size-mismatch-in-changes-file", $file, + "$files{$file}{size} != $size" ); + } + } + } + + + foreach my $file (keys %files) { + my $filename = $arg_dir . '/' . $file; + + # check size + if (not -f $filename) { + warning("$file does not exist, exiting"); + exit 2; + } + my $size = -s _; + if ($size ne $files{$file}{size}) { + tag( "file-size-mismatch-in-changes-file", $file, + "$files{$file}{size} != $size"); + } + + # check checksums + if ($check_checksums or $file =~ /\.dsc$/) { + foreach my $alg (qw(md5 sha1 sha256)) { + next unless exists $files{$file}{$alg}; + + my $real_checksum = get_file_checksum($alg, $filename); + + if ($real_checksum ne $files{$file}{$alg}) { + tag( "checksum-mismatch-in-changes-file", $alg, $file ); + } + } + } + + # process file? + if ($file =~ /\.dsc$/) { + $schedule->add_dsc($filename); + } elsif ($file =~ /\.deb$/) { + $schedule->add_deb('b', $filename); + } elsif ($file =~ /\.udeb$/) { + $schedule->add_deb('u', $filename); + } + } + + unless ($exit_code) { + my $stats = Tags::get_stats( $arg ); + if ($stats->{types}{E}) { + $exit_code = 1; + } elsif ($fail_on_warnings && $stats->{types}{W}) { + $exit_code = 1; + } + } + + } else { + fail("bad package file name $arg (neither .deb, .udeb or .dsc file)"); + } + } else { + # parameter is a package name--so look it up + # search the distribution first, then the lab + # special case: search only in lab if action is `remove' + + my $search; + if ($action eq 'remove') { + # search only in lab--see below + $search = 'lab'; + } else { + # search in dist, then in lab + $search = 'dist or lab'; + + my $found = 0; + + # read package info + read_src_list("$MAEMIAN_LAB/info/source-packages", 0); + read_bin_list("$MAEMIAN_LAB/info/binary-packages", 0); + read_udeb_list("$MAEMIAN_LAB/info/udeb-packages", 0); + + if (($pkg_mode eq 'b') or ($pkg_mode eq 'a')) { + if ($binary_info{$arg}) { + $schedule->add_file('b', "$MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}", + %{$binary_info{$arg}}); + $found = 1; + } + } + if (($pkg_mode eq 'u') or ($pkg_mode eq 'a')) { + if ($udeb_info{$arg}) { + $schedule->add_file('u', "$MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}", + %{$udeb_info{$arg}}); + $found = 1; + } + } + if (($pkg_mode eq 's') or ($pkg_mode eq 'a')) { + if ($source_info{$arg}) { + $schedule->add_file('s', "$MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}", + %{$source_info{$arg}}); + $found = 1; + } + } + + next if $found; + } + + # nothing found so far, so search the lab + + my $b = "$MAEMIAN_LAB/binary/$arg"; + my $s = "$MAEMIAN_LAB/source/$arg"; + my $u = "$MAEMIAN_LAB/udeb/$arg"; + + if ($pkg_mode eq 'b') { + unless (-d $b) { + warn "error: cannot find binary package $arg in $search (skipping)\n"; + $exit_code = 2; + next; + } + } elsif ($pkg_mode eq 's') { + unless (-d $s) { + warning("cannot find source package $arg in $search (skipping)"); + $exit_code = 2; + next; + } + } elsif ($pkg_mode eq 'u') { + unless (-d $u) { + warning("cannot find udeb package $arg in $search (skipping)"); + $exit_code = 2; + next; + } + } else { + # $pkg_mode eq 'a' + unless (-d $b or -d $s or -d $u) { + warning("cannot find binary, udeb or source package $arg in $search (skipping)"); + $exit_code = 2; + next; + } + } + + if (($pkg_mode eq 'b') or (($pkg_mode eq 'a') and (-d $b))) { + $schedule->add_file('b', get_bin_info_from_lab($b)); + } + if (($pkg_mode eq 's') or (($pkg_mode eq 'a') and (-d $s))) { + $schedule->add_file('s', get_src_info_from_lab($s)); + } + if (($pkg_mode eq 'u') or (($pkg_mode eq 'a') and (-d $u))) { + $schedule->add_file('u', get_bin_info_from_lab($u)); + } + } +} + +if (not $check_everything and not $packages_file and not $schedule->count) { + v_msg("No packages selected."); + exit $exit_code; +} +# }}} + +# {{{ A lone subroutine +#---------------------------------------------------------------------------- +# Check to make sure there are packages to check. +sub set_value { + my ($f,$target,$field,$source,$required) = @_; + if ($required and not $source->{$field}) { + fail("description file $f does not define required tag $field"); + } + $target->{$field} = $source->{$field}; + delete $source->{$field}; +} +# }}} + +# {{{ Load information about collector scripts +opendir(COLLDIR, "$MAEMIAN_ROOT/collection") + or fail("cannot read directory $MAEMIAN_ROOT/collection"); + +for my $f (readdir COLLDIR) { + next if $f =~ /^\./; + next unless $f =~ /\.desc$/; + + debug_msg(2, "Reading collector description file $f ..."); + my @secs = read_dpkg_control("$MAEMIAN_ROOT/collection/$f"); + my $script; + ($#secs+1 == 1) + or fail("syntax error in description file $f: too many sections"); + + ($script = $secs[0]->{'collector-script'}) + or fail("error in description file $f: `Collector-Script:' not defined"); + + delete $secs[0]->{'collector-script'}; + $collection_info{$script}->{'script'} = $script; + my $p = $collection_info{$script}; + + set_value($f, $p,'type',$secs[0],1); + # convert Type: + my ($b,$s,$u) = ( "", "", "" );; + for (split(/\s*,\s*/o,$p->{'type'})) { + if ($_ eq 'binary') { + $b = 'b'; + } elsif ($_ eq 'source') { + $s = 's'; + } elsif ($_ eq 'udeb') { + $u = 'u'; + } else { + fail("unknown type $_ specified in description file $f"); + } + } + $p->{'type'} = "$s$b$u"; + + set_value($f,$p,'unpack-level',$secs[0],1); + set_value($f,$p,'order',$secs[0],1); + set_value($f,$p,'version',$secs[0],1); + + if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) { + for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) { + $p->{$_} = 1; + } + delete $secs[0]->{'needs-info'}; + } + + # ignore Info: and other fields for now + delete $secs[0]->{'info'}; + delete $secs[0]->{'author'}; + + for (keys %{$secs[0]}) { + warning("unused tag $_ in description file $f"); + } + + debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p )); +} + +closedir(COLLDIR); +# }}} + +# {{{ Now we're ready to load info about checks & tags + +# load information about checker scripts +opendir(CHECKDIR, "$MAEMIAN_ROOT/checks") + or fail("cannot read directory $MAEMIAN_ROOT/checks"); + +for my $f (readdir CHECKDIR) { + next if $f =~ /^\./; + next unless $f =~ /\.desc$/; + debug_msg(2, "Reading checker description file $f ..."); + + my @secs = read_dpkg_control("$MAEMIAN_ROOT/checks/$f"); + my $script; + ($script = $secs[0]->{'check-script'}) + or fail("error in description file $f: `Check-Script:' not defined"); + + # ignore check `maemian' (this check is a special case and contains the + # tag info for the maemian frontend--this script here) + next if $script eq 'maemian'; + + delete $secs[0]->{'check-script'}; + $check_info{$script}->{'script'} = $script; + my $p = $check_info{$script}; + + set_value($f,$p,'type',$secs[0],1); + # convert Type: + my ($b,$s,$u) = ( "", "", "" ); + for (split(/\s*,\s*/o,$p->{'type'})) { + if ($_ eq 'binary') { + $b = 'b'; + } elsif ($_ eq 'source') { + $s = 's'; + } elsif ($_ eq 'udeb') { + $u = 'u'; + } else { + fail("unknown type $_ specified in description file $f"); + } + } + $p->{'type'} = "$s$b$u"; + + set_value($f,$p,'unpack-level',$secs[0],1); + set_value($f,$p,'abbrev',$secs[0],1); + + if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) { + for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) { + $p->{$_} = 1; + } + delete $secs[0]->{'needs-info'}; + } + + # ignore Info: and other fields for now... + delete $secs[0]->{'info'}; + delete $secs[0]->{'standards-version'}; + delete $secs[0]->{'author'}; + + for (keys %{$secs[0]}) { + warning("unused tag $_ in description file $f"); + } + + debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p )); + + shift(@secs); + $p->{'requested-tags'} = 0; + foreach my $tag (@secs) { + $tag->{'script'} = $script; + Tags::add_tag($tag); + $p->{'requested-tags'}++ if Tags::display_tag($tag); + } +} + +closedir(CHECKDIR); + +# }}} + +# {{{ Again some lone code the author just dumped where his cursor just happened to be +if ($unpack_info) { + # determine which info has been requested + for my $i (split(/,/,$unpack_info)) { + unless ($collection_info{$i}) { + fail("unknown info specified: $i"); + } + $unpack_infos{$i} = 1; + } } + +# create check_abbrev hash +for my $c (keys %check_info) { + $check_abbrev{$check_info{$c}->{'abbrev'}} = $c; +} + +# }}} + +# {{{ determine which checks have been requested +if ($action eq 'check') { + if ($check_tags) { + foreach my $t (split(/,/, $check_tags)) { + my $info = Tags::get_tag_info($t); + + fail("unknown tag specified: $t") unless defined($info); + my $script = $info->{'script'}; + next if $script eq 'maemian'; + if ($check_info{$script}) { + $checks{$script} = 1; + } else { + # should never happen + fail("no info for script $script"); + } + } + } else { + my %dont_check = map { $_ => 1 } (split m/,/, ($dont_check || "")); + $checks or ($checks = join(',',keys %check_info)); + for my $c (split(/,/,$checks)) { + if ($check_info{$c}) { + if ($dont_check{$c} + || ($check_info{$c}->{'abbrev'} + && $dont_check{$check_info{$c}->{'abbrev'}})) { + #user requested not to run this check + } elsif ($check_info{$c}->{'requested-tags'} == 0) { + #no need to run this check, no tags will be issued + } else { + $checks{$c} = 1; + } + } elsif (exists $check_abbrev{$c}) { + #abbrevs only used when -C is given, so we don't need %dont_check + $checks{$check_abbrev{$c}} = 1; + } else { + fail("unknown check specified: $c"); + } + } + } + + # determine which info is needed by the checks + for my $c (keys %checks) { + for my $i (keys %collection_info) { + # required by $c ? + if ($check_info{$c}->{$i}) { + $unpack_infos{$i} = 1; + } + } + } +} + +# }}} + +# {{{ determine which info is needed by the collection scripts +for my $c (keys %unpack_infos) { + for my $i (keys %collection_info) { + # required by $c ? + if ($collection_info{$c}->{$i}) { + $unpack_infos{$i} = 1; + } + } +} +# }}} + +# {{{ process all packages in the archive? +if ($check_everything) { + # make sure package info is available + read_src_list("$MAEMIAN_LAB/info/source-packages", 0); + read_bin_list("$MAEMIAN_LAB/info/binary-packages", 0); + read_udeb_list("$MAEMIAN_LAB/info/udeb-packages", 0); + + debug_msg(2, "pkg_mode = $pkg_mode"); + + if (($pkg_mode eq 'a') or ($pkg_mode eq 's')) { + for my $arg (sort keys %source_info) { + debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}"); + $schedule->add_file('s', "$MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}", + %{$source_info{$arg}}); + } + } + if (($pkg_mode eq 'a') or ($pkg_mode eq 'b')) { + for my $arg (sort keys %binary_info) { + debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}"); + $schedule->add_file('b', "$MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}", + %{$binary_info{$arg}}); + } + } + if (($pkg_mode eq 'a') or ($pkg_mode eq 'u')) { + for my $arg (sort keys %udeb_info) { + debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}"); + $schedule->add_file('u', "$MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}", + %{$udeb_info{$arg}}); + } + } + + # package list still empty? + unless ($schedule->count) { + warning("no packages found in distribution directory"); + } +} elsif ($packages_file) { # process all packages listed in packages file? + $schedule->add_pkg_list($packages_file); +} +# }}} + +# {{{ Some silent exit +unless ($schedule->count) { + v_msg("No packages selected."); + exit 0; +} +# }}} + +# {{{ Okay, now really processing the packages in one huge loop +$unpack_infos{ "override-file" } = 1 unless $no_override; +v_msg(sprintf("Processing %d packages...", $schedule->count)); +debug_msg(1, + "Selected action: $action", + "Requested unpack level: $unpack_level", + sprintf("Requested data to collect: %s", join(',',keys %unpack_infos)), + sprintf("Selected checks: %s", join(',',keys %checks)), + ); + +require Checker; +require Maemian::Collect; + +my %overrides; +my @pending_jobs; +PACKAGE: +foreach my $pkg_info ($schedule->get_all) { + my ($type, $pkg, $ver, $arch, $file) = + @$pkg_info{qw(type package version architecture file)}; + my $long_type = ($type eq 'b' ? 'binary' : + ($type eq 's' ? 'source' : 'udeb' )); + + Tags::set_pkg( $file, $pkg, $ver, $arch, $long_type ); + + # Kill pending jobs, if any + Maemian::Command::kill(@pending_jobs); + undef @pending_jobs; + + # determine base directory + my $base = "$MAEMIAN_LAB/$long_type/$pkg"; + unless ($base =~ m,^/,) { + $base = "$cwd/$base"; + } + debug_msg(1, "Base directory in lab: $base"); + + my $act_unpack_level = 0; + + # unpacked package up-to-date? + if (-d $base) { + my $remove_basedir = 0; + + # there's a base dir, so we assume that at least + # one level of unpacking has been done + $act_unpack_level = 1; + + # maemian status file exists? + unless (-f "$base/.maemian-status") { + v_msg("No maemian status file found (removing old directory in lab)"); + $remove_basedir = 1; + goto REMOVE_BASEDIR; + } + + # read unpack status -- catch any possible errors + my $data; + eval { ($data) = read_dpkg_control("$base/.maemian-status"); }; + if ($@) { # error! + v_msg($@); + $remove_basedir = 1; + goto REMOVE_BASEDIR; + } + + # compatible maemian version? + if (not exists $data->{'lab-format'} or ($data->{'lab-format'} < $LAB_FORMAT)) { + v_msg("Lab directory was created by incompatible maemian version"); + $remove_basedir = 1; + goto REMOVE_BASEDIR; + } + + # version up to date? + if (not exists $data->{'version'} or ($data->{'version'} ne $ver)) { + debug_msg(1, "Removing package in lab (newer version exists) ..."); + $remove_basedir = 1; + goto REMOVE_BASEDIR; + } + + # unpack level defined? + unless (exists $data->{'unpack-level'}) { + warning("cannot determine unpack-level of package"); + $remove_basedir = 1; + goto REMOVE_BASEDIR; + } else { + $act_unpack_level = $data->{'unpack-level'}; + } + + # file modified? + my $timestamp; + my @stat; + unless (@stat = stat $file) { + warning("cannot stat file $file: $!"); + } else { + $timestamp = $stat[9]; + } + if ((not defined $timestamp) or (not exists $data->{'timestamp'}) or ($data->{'timestamp'} != $timestamp)) { + debug_msg(1, "Removing package in lab (package has been changed) ..."); + $remove_basedir = 1; + goto REMOVE_BASEDIR; + } + + REMOVE_BASEDIR: + if ($remove_basedir) { + v_msg("Removing $pkg"); + unless (remove_pkg($base)) { + warning("skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + $act_unpack_level = 0; + } + } + + # unpack to requested unpack level + $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level, + $unpack_level); + if ($act_unpack_level == -1) { + warning("could not unpack package to desired level", + "skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + + if (($action eq 'unpack') or ($action eq 'check')) { # collect info + my $current_order = -1; + for my $coll (sort by_collection_order keys %unpack_infos) { + my $ci = $collection_info{$coll}; + my %run_opts = ('description' => $coll); + + # current type? + next unless ($ci->{'type'} =~ m/$type/); + + # If a file named .SCRIPT-VERSION already exists, we've already + # collected this information and we can skip it. Otherwise, + # remove any .SCRIPT-* files (which are old version information). + next if (-f "$base/.${coll}-$ci->{'version'}"); + opendir(BASE, $base) + or fail("cannot read directory $base: $!"); + for my $file (readdir BASE) { + if ($file =~ /^\.\Q$coll-/) { + unlink("$base/$file"); + } + } + closedir(BASE); + + # unpack to desired unpack level (if necessary) + $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'}); + if ($act_unpack_level == -1) { + warning("could not unpack package to desired level", + "skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + + # chdir to base directory + unless (chdir($base)) { + warning("could not chdir into directory $base: $!", + "skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + + $current_order = $ci->{'order'} if ($current_order == -1); + if ($current_order != $ci->{'order'}) { + debug_msg(1, "Waiting for jobs from order $current_order ..."); + unless (reap_collect_jobs($pkg, $base, @pending_jobs)) { + warning("skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + undef @pending_jobs; + $current_order = $ci->{'order'}; + } + + # collect info + remove_status_file($base); + debug_msg(1, "Collecting info: $coll ..."); + my $script = "$MAEMIAN_ROOT/collection/$ci->{'script'}"; + unless (spawn(\%run_opts, [ $script, $pkg, $long_type, '&' ])) { + warning("collect info $coll about package $pkg failed", + "skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + push @pending_jobs, \%run_opts; + } + + # wait until all the jobs finish and skip this package if any of them + # failed. + debug_msg(1, "Waiting for jobs from order $current_order ..."); + unless (reap_collect_jobs($pkg, $base, @pending_jobs)) { + warning("skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + undef @pending_jobs; + } + + if ($action eq 'check') { # read override file + + unless ($no_override) { + Tags::add_overrides("$base/override", $pkg, $long_type) + if (-f "$base/override") + } + + # perform checks + my $info = Maemian::Collect->new($pkg, $long_type); + for my $check (keys %checks) { + my $ci = $check_info{$check}; + + # current type? + next unless ($ci->{'type'} =~ m/$type/); + + # unpack to desired unpack level (if necessary) + $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'}); + if ($act_unpack_level == -1) { + warning("could not unpack package to desired level", + "skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + + # chdir to base directory + unless (chdir($base)) { + warning("could not chdir into directory $base: $!", + "skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + + my $returnvalue = Checker::runcheck($pkg, $long_type, $info, $check); + # Set exit_code correctly if there was not yet an exit code + $exit_code = $returnvalue unless $exit_code; + + if ($returnvalue == 2) { + warning("skipping $action of $long_type package $pkg"); + next PACKAGE; + } + + } + unless ($exit_code) { + my $stats = Tags::get_stats( $file ); + if ($stats->{types}{E}) { + $exit_code = 1; + } elsif ($fail_on_warnings && $stats->{types}{W}) { + $exit_code = 1; + } + } + + # report unused overrides + if (not $no_override) { + my $overrides = Tags::get_overrides( $file ); + + for my $tag (sort keys %$overrides) { + my $taginfo = Tags::get_tag_info{$tag}; + if (defined $taginfo) { + # Did we run the check script containing the tag? + next unless $checks{$taginfo->{'script'}}; + + # If only checking specific tags, is this one of them? + next unless (scalar keys %Tags::only_issue_tags == 0) + or exists $Tags::only_issue_tags{$tag}; + } + + for my $extra (sort keys %{$overrides->{$tag}}) { + next if $overrides->{$tag}{$extra}; + + tag( "unused-override", $tag, $extra ); + } + } + } + + # Report override statistics. + if (not $no_override and not $show_overrides) { + my $stats = Tags::get_stats($file); + my $short = $file; + $short =~ s%.*/%%; + my $errors = $stats->{overrides}{types}{E} || 0; + my $warnings = $stats->{overrides}{types}{W} || 0; + my $info = $stats->{overrides}{types}{I} || 0; + $overrides{errors} += $errors; + $overrides{warnings} += $warnings; + $overrides{info} += $info; + } + } + + # chdir to maemian root directory (to unlock $base so it can be removed below) + unless (chdir($MAEMIAN_ROOT)) { + warning("could not chdir into directory $MAEMIAN_ROOT: $!", + "skipping $action of $long_type package $pkg"); + $exit_code = 2; + next PACKAGE; + } + + # clean up + if ($act_unpack_level > $unpack_level) { + $act_unpack_level = clean_pkg($type,$base,$file,$act_unpack_level,$unpack_level); + if ($act_unpack_level == -1) { + warning("could not clean up laboratory for package $pkg: $!", + "skipping clean up"); + $exit_code = 2; + next PACKAGE; + } + } + + # create Maemian status file + if (($act_unpack_level > 0) and (not -f "$base/.maemian-status")) { + my @stat; + unless (@stat = stat $file) { + warning("cannot stat file $file: $!", + "skipping creation of status file"); + $exit_code = 2; + next PACKAGE; + } + my $timestamp = $stat[9]; + + unless (open(STATUS, '>', "$base/.maemian-status")) { + warning("could not create status file $base/.maemian-status for package $pkg: $!"); + $exit_code = 2; + next PACKAGE; + } + + print STATUS "Maemian-Version: $MAEMIAN_VERSION\n"; + print STATUS "Lab-Format: $LAB_FORMAT\n"; + print STATUS "Package: $pkg\n"; + print STATUS "Version: $ver\n"; + print STATUS "Type: $type\n"; + print STATUS "Unpack-Level: $act_unpack_level\n"; + print STATUS "Timestamp: $timestamp\n"; + close(STATUS); + } +} +Tags::reset_pkg(); +if ($action eq 'check' and not $no_override and not $show_overrides) { + my $errors = $overrides{errors} || 0; + my $warnings = $overrides{warnings} || 0; + my $info = $overrides{info} || 0; + my $total = $errors + $warnings + $info; + if ($total > 0) { + my $total = ($total == 1) + ? "$total tag overridden" + : "$total tags overridden"; + my @output; + if ($errors) { + push (@output, ($errors == 1) ? "$errors error" : "$errors errors"); + } + if ($warnings) { + push (@output, ($warnings == 1) ? "$warnings warning" : "$warnings warnings"); + } + if ($info) { + push (@output, "$info info"); + } + msg("$total (". join (', ', @output). ")"); + } +} + +# }}} + +exit $exit_code; + +# {{{ Some subroutines + +sub unpack_pkg { + my ($type,$base,$file,$cur_level,$new_level) = @_; + + debug_msg(1, sprintf("Current unpack level is %d",$cur_level)); + + return $cur_level if $cur_level == $new_level; + + # remove .maemian-status file + remove_status_file($base); + + if ( ($cur_level == 0) and (-d $base) ) { + # We were lied to, there's something already there - clean it up first + remove_pkg($base) or return -1; + } + + if ( ($new_level >= 1) and + (not defined ($cur_level) or ($cur_level < 1)) ) { + # create new directory + debug_msg(1, "Unpacking package to level 1 ..."); + if (($type eq 'b') || ($type eq 'u')) { + spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-binpkg-l1", $base, $file]) + or return -1; + } else { + spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-srcpkg-l1", $base, $file]) + or return -1; + } + $cur_level = 1; + } + + if ( ($new_level >= 2) and + (not defined ($cur_level) or ($cur_level < 2)) ) { + # unpack package contents + debug_msg(1, "Unpacking package to level 2 ..."); + if (($type eq 'b') || ($type eq 'u')) { + spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-binpkg-l2", $base]) + or return -1; + } else { + debug_msg(1, "$MAEMIAN_ROOT/unpack/unpack-srcpkg-l2 $base"); + spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-srcpkg-l2", $base]) + or return -1; + } + $cur_level = 2; + } + + return $cur_level; +} + +# Given a list of jobs corresponding to collect scripts, reap each of the +# jobs. For each successful job, record that it was successful by creating +# the corresponding version marker file in the lab. For each unsuccessful +# job, warn that it was unsuccessful. +# +# Takes the current package, base directory, and the list of pending jobs. +# Return true if all jobs were successful, false otherwise. +sub reap_collect_jobs { + my ($pkg, $base, @pending_jobs) = @_; + my $status = reap(@pending_jobs); + for my $job (@pending_jobs) { + my $coll = $job->{'description'}; + if ($job->{success}) { + my $ci = $collection_info{$coll}; + open(VERSION, '>', "$base/.${coll}-$ci->{'version'}") + or fail("cannot create $base/.${coll}-$ci->{'version'}: $!"); + print VERSION "Maemian-Version: $MAEMIAN_VERSION\n" + . "Timestamp: " . time . "\n"; + close(VERSION); + } else { + warning("collect info $coll about package $pkg failed"); + } + } + return $status; +} + +# TODO: is this the best way to clean dirs in perl? +# no, look at File::Path module +sub clean_pkg { + my ($type,$base,$file,$cur_level,$new_level) = @_; + + return $cur_level if $cur_level == $new_level; + + if ($new_level < 1) { + # remove base directory + remove_pkg($base) or return -1; + return 0; + } + + if ( ($new_level < 2) and defined ($cur_level) and ($cur_level >= 2) ) { + # remove .maemian-status file + remove_status_file($base); + + # remove unpacked/ directory + debug_msg(1, "Decreasing unpack level to 1 (removing files) ..."); + if ( -l "$base/unpacked" ) { + delete_dir("$base/".readlink("$base/unpacked")) + or return -1; + delete_dir("$base/unpacked") or return -1; + } else { + delete_dir("$base/unpacked") or return -1; + } + + $cur_level = 1; + } + + return $cur_level; +} + +# this function removes a package's base directory in the lab completely +sub remove_pkg { + my ($base) = @_; + + debug_msg(1, "Removing package in lab ..."); + unless (delete_dir($base)) { + warning("cannot remove directory $base: $!"); + return 0; + } + + return 1; +} + +sub remove_status_file { + my ($base) = @_; + + # status file exists? + if (not -e "$base/.maemian-status") { + return 1; + } + + if (not unlink("$base/.maemian-status")) { + warning("cannot remove status file $base/.maemian-status: $!"); + return 0; + } + + return 1; +} + +# ------------------------------- + +# get package name, version, and file name from the lab +sub get_bin_info_from_lab { + my ($base_dir) = @_; + my ($pkg,$ver,$arch,$file); + + ($pkg = read_file("$base_dir/fields/package")) + or fail("cannot read file $base_dir/fields/package: $!"); + + ($ver = read_file("$base_dir/fields/version")) + or fail("cannot read file $base_dir/fields/version: $!"); + + ($arch = read_file("$base_dir/fields/architecture")) + or fail("cannot read file $base_dir/fields/architecture: $!"); + + ($file = readlink("$base_dir/deb")) + or fail("cannot read link $base_dir/deb: $!"); + + return ($file, package => $pkg, version => $ver, architecture => $arch); +} + +# get package name, version, and file name from the lab +sub get_src_info_from_lab { + my ($base_dir) = @_; + my ($pkg,$ver,$file); + + ($pkg = read_file("$base_dir/fields/source")) + or fail("cannot read file $base_dir/fields/source: $!"); + + ($ver = read_file("$base_dir/fields/version")) + or fail("cannot read file $base_dir/fields/version: $!"); + + ($file = readlink("$base_dir/dsc")) + or fail("cannot read link $base_dir/dsc: $!"); + + return ($file, source => $pkg, version => $ver); +} + +# ------------------------------- + +# read first line of a file +sub read_file { + my $t; + + open(T, '<', $_[0]) or return; + chop($t = ); + close(T) or return; + + return $t; +} + +# sort collection list by `order' +sub by_collection_order { + $collection_info{$a}->{'order'} <=> $collection_info{$b}->{'order'}; +} +# }}} + +# {{{ Exit handler. + +sub END { + # Prevent Lab::delete from affecting the exit code. + local $?; + + $SIG{'INT'} = 'DEFAULT'; + $SIG{'QUIT'} = 'DEFAULT'; + + $LAB->delete() if $LAB and not $keep_lab; +} + +sub interrupted { + $SIG{$_[0]} = 'DEFAULT'; + die "N: Interrupted.\n"; +} +# }}} + +# Local Variables: +# indent-tabs-mode: t +# cperl-indent-level: 4 +# End: +# vim: sw=4 ts=8 noet fdm=marker diff --git a/www/manual.html b/www/manual.html index 64b1187..fd26c1c 100644 --- a/www/manual.html +++ b/www/manual.html @@ -16,9 +16,11 @@ that you will not find information that is necessarily relative to maemian there

Maemian command line options

These are the options that have been imported from lintian and tested with maemian so far:
    +
  • --lab (takes a string): the location of your lab
  • -S or --setup-lab: used for setting up a lab for unpacking packages
  • -R or --remove-lab: used for removing lab
    • -
  • --lab (takes a string): the location of your lab
    • +
  • -V or --version: print version
    • +
  • -v or --verbose: verbose
-- 1.7.9.5