-#!/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
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;
-# --- Command line options
-my $inputfile; # --- A file passed to maemian
-GetOptions ("inputfile|i=s" => \$inputfile);
+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;
+
+ 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");
+ }
+ if ($checks) {
+ 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';
+ $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";
+}
+
+# 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 (<CFG>) {
+ 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;
+ }
+}
-if ($inputfile && -x $inputfile) {
- print "$inputfile\n";
+# 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 "Have you specified an input file?\n $!\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 = <T>);
+ 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__
projects / maemian / blobdiff