X-Git-Url: http://vcs.maemo.org/git/?a=blobdiff_plain;f=maemian;h=7c00ab230a9d50dcf744006529fcaee3cb1783a6;hb=HEAD;hp=5d54506e73004861517c41bf40a77adfe83f35f5;hpb=a4bdb88d40baeb8bbb9b279d35384ba7ba7c4ea6;p=maemian diff --git a/maemian b/maemian index 5d54506..7c00ab2 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 @@ -25,59 +26,1864 @@ maemian - Maemo package checker -=head1 EXAMPLE +=head1 -maemian -i file.dsc +Maemian is the maemo version of lintian - 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. =cut -use strict; -use warnings; +use strict; # Warnings turned on via -w +use lib qw(lib/); 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; - -# --- 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); - 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>; + +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_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 +my $MAEMIAN_ARCH = "any"; + +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_SECTION = undef; +our $MAEMIAN_AREA = undef; + +#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 addres ($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 { - print "N: $maintainer\n"; + if ($checks) { + die("both -C or --check-part and -X or --dont-check-part options not allowed"); } - if (grep /BEGIN PGP SIGNED MESSAGE/, @lines) { - print "N: $filename is signed\n"; + if ($action) { + die("too many actions specified: $_[0]"); } - # print "\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]"; +} + +# 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, + "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 { + $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"; } -if ($inputfile) { - file_tests($inputfile); +# 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_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 { - croak "No input file found: $!\n"; + # 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; +} + +# Check to make sure there are packages to check. +sub set_value { + my ($f,$target,$field,$source,$required) = @_; + use YAML; +# print map { Dump($_) } @_; + if ($required and not $source->{$field}) { + print Dump($f)."\n"; + fail("description file $f does not define required tag $field"); + } + $target->{$field} = $source->{$field}; + delete $source->{$field}; +} + +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 $first_line; + + open(T, '<', $_[0]) or return; + chop($first_line = ); + close(T) or return; + + return $first_line; +} + +# sort collection list by `order' +sub by_collection_order { + $collection_info{$a}->{'order'} <=> $collection_info{$b}->{'order'}; +} + +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"; +} + +1; +__END__