vcs.maemo.org Git - maemian/blob - maemian

   1 #!/usr/bin/perl -w
   2
   3 #  Maemian -- Maemo package checker
   4 # Copyright (C) Jeremiah C. Foster 2009, based on:
   5
   6 #   Maemian -- Debian package checker
   7 # Copyright (C) 1998 Christian Schwarz and Richard Braakman
   8 #
   9 # This program is free software.  It is distributed under the terms of
  10 # the GNU General Public License as published by the Free Software
  11 # Foundation; either version 2 of the License, or (at your option) any
  12 # later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program.  If not, you can find it on the World Wide
  21 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  22 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  23 # MA 02110-1301, USA.
  24
  25 =head1 NAME
  26
  27 maemian - Maemo package checker
  28
  29 =head1
  30
  31 Maemian is the maemo version of maemian - a policy checker designed to
  32 assure the quality of a package uploaded into the maemo.org repositories.
  33 The goal of maemian is to improve quality by checking that the maemo
  34 packaging policy is followed. In order to do that it reads files in the
  35 uploaded deb. Currently maemian only looks at the .dsc file and tries to
  36 ascertain who uploaded it, and if they used the correct email address.
  37
  38 =cut
  39
  40 use strict;
  41 use lib qw(lib/);
  42 use Getopt::Long;
  43
  44 my $MAEMIAN_VERSION = "0.2";        # External Version number (Where is the canonical version?)
  45 my $BANNER = "Maemian v$MAEMIAN_VERSION";   # Version Banner - text form
  46 my $LAB_FORMAT = 9;                         # Lab format Version Number
  47                                             # increased whenever incompatible
  48                                             # changes are done to the lab
  49                                             # so that all packages are re-unpacked
  50
  51 # Variables used to record commandline options
  52 # Commented out variables have "defined" checks somewhere to determine if
  53 # they were set via commandline or environment variables
  54 my $pkg_mode = 'a';             # auto -- automatically search for
  55                                 # binary and source pkgs
  56 my $verbose = 0;                #flag for -v|--verbose switch
  57 my $quiet = 0;                  #flag for -q|--quiet switch
  58 my @debug;
  59 my $check_everything = 0;       #flag for -a|--all switch
  60 my $maemian_info = 0;           #flag for -i|--info switch
  61 our $display_experimentaltags = 0; #flag for -E|--display-experimental switch
  62 our $display_pedantictags = 0;  #flag for --pedantic switch
  63 my $unpack_level = undef;       #flag for -l|--unpack-level switch
  64 our $no_override = 0;           #flag for -o|--no-override switch
  65 our $show_overrides = 0;        #flag for --show-overrides switch
  66 my $color = 'never';            #flag for --color switch
  67 my $check_checksums = 0;        #flag for -m|--md5sums|--checksums switch
  68 my $allow_root = 0;             #flag for --allow-root switch
  69 my $fail_on_warnings = 0;       #flag for --fail-on-warnings switch
  70 my $keep_lab = 0;               #flag for --keep-lab switch
  71 my $packages_file = 0;          #string for the -p option
  72 our $OPT_MAEMIAN_LAB = "";      #string for the --lab option
  73 our $OPT_MAEMIAN_ARCHIVEDIR = "";#string for the --archivedir option
  74 our $OPT_MAEMIAN_DIST = "";     #string for the --dist option
  75 our $OPT_MAEMIAN_ARCH = "";     #string for the --arch option
  76 our $OPT_MAEMIAN_AREA = "";     #string for the --area option
  77 # These options can also be used via default or environment variables
  78 our $MAEMIAN_CFG = "";          #config file to use
  79 our $MAEMIAN_ROOT = "/home/jeremiah/maemian/";  #location of the maemian modules
  80 our $OPT_MAEMIAN_SECTION = "";  #old name for OPT_MAEMIAN_ARCH
  81
  82 my $experimental_output_opts = undef;
  83
  84 my @severities = qw(wishlist minor normal important serious);
  85 my @certainties = qw(wild-guess possible certain);
  86 my %display_level = ();
  87 my %display_source = ();
  88
  89 my $schedule;
  90
  91 my $action;
  92 my $checks;
  93 my $check_tags;
  94 my $dont_check;
  95 my $unpack_info;
  96 my $cwd;
  97 my $cleanup_filename;
  98 my $exit_code = 0;
  99 my $LAB;
 100
 101 my %collection_info;
 102 my %already_scheduled;
 103 my %checks;
 104 my %check_abbrev;
 105 my %unpack_infos;
 106 my %check_info;
 107
 108 # reset configuration variables
 109 our $MAEMIAN_LAB = undef;
 110 our $MAEMIAN_ARCHIVEDIR = undef;
 111 our $MAEMIAN_DIST = undef;
 112 our $MAEMIAN_UNPACK_LEVEL = undef;
 113 our $MAEMIAN_ARCH = undef;
 114 our $MAEMIAN_SECTION = undef;
 115 our $MAEMIAN_AREA = undef;
 116
 117 #turn off file buffering
 118 $| = 1;
 119
 120 # reset locale definition (necessary for tar)
 121 $ENV{'LC_ALL'} = 'C';
 122 # reset timezone definition (also for tar)
 123 $ENV{'TZ'}     = '';
 124
 125 # }}}
 126
 127 # {{{ Process Command Line
 128
 129 #######################################
 130 # Subroutines called by various options
 131 # in the options hash below.  These are
 132 # invoked to process the commandline
 133 # options
 134 #######################################
 135 # Display Command Syntax
 136 # Options: -h|--help
 137 sub syntax {
 138     print "$BANNER\n";
 139     print <<"EOT-EOT-EOT";
 140 Syntax: maemian [action] [options] [--] [packages] ...
 141 Actions:
 142     -S, --setup-lab           set up static lab
 143     -R, --remove-lab          remove static lab
 144     -c, --check               check packages (default action)
 145     -C X, --check-part X      check only certain aspects
 146     -X X, --dont-check-part X don\'t check certain aspects
 147     -T X, --tags X            only run checks needed for requested tags
 148     --tags-from-file X        like --tags, but read list from file
 149     -u, --unpack              only unpack packages in the lab
 150     -r, --remove              remove package from the lab
 151 General options:
 152     -h, --help                display short help text
 153     -v, --verbose             verbose messages
 154     -V, --version             display Maemian version and exit
 155     --print-version           print unadorned version number and exit
 156     -d, --debug               turn Maemian\'s debug messages ON
 157     -q, --quiet               suppress all informational messages
 158 Behaviour options:
 159     -i, --info                give detailed info about tags
 160     -I, --display-info        display "I:" tags (normally suppressed)
 161     -E, --display-experimental display "X:" tags (normally suppressed)
 162     --pedantic                display "P:" tags (normally suppressed)
 163     -L, --display-level       display tags with the specified level
 164     --display-source X        restrict displayed tags by source
 165     -l X, --unpack-level X    set default unpack level to X
 166     -o, --no-override         ignore overrides
 167     --show-overrides          output tags that have been overriden
 168     --color never/always/auto disable, enable, or enable color for TTY
 169     -U X, --unpack-info X     specify which info should be collected
 170     -m, --md5sums, --checksums check checksums when processing a .changes file
 171     --allow-root              suppress maemian\'s warning when run as root
 172     --fail-on-warnings        return a non-zero exit status if warnings found
 173     --keep-lab                keep lab after run, even if temporary
 174 Configuration options:
 175     --cfg CONFIGFILE          read CONFIGFILE for configuration
 176     --lab LABDIR              use LABDIR as permanent laboratory
 177     --archivedir ARCHIVEDIR   location of Debian archive to scan for packages
 178     --dist DIST               scan packages in this distribution (e.g. sid)
 179     --area AREA               scan packages in this archive area (e.g. main)
 180     --arch ARCH               scan packages with architecture ARCH
 181     --root ROOTDIR            use ROOTDIR instead of /usr/share/maemian
 182 Package selection options:
 183     -a, --all                 process all packages in distribution
 184     -b, --binary              process only binary packages
 185     -s, --source              process only source packages
 186     --udeb                    process only udeb packages
 187     -p X, --packages-file X   process all files in file (special syntax!)
 188 EOT-EOT-EOT
 189
 190     exit 0;
 191 }
 192
 193 # Display Version Banner
 194 # Options: -V|--version, --print-version
 195 sub banner {
 196   if ($_[0] eq 'print-version') {
 197     print "$MAEMIAN_VERSION\n";
 198   } else {
 199     print "$BANNER\n";
 200   }
 201   exit 0;
 202 }
 203
 204 # Record action requested
 205 # Options: -S, -R, -c, -u, -r
 206 sub record_action {
 207   if ($action) {
 208     die("too many actions specified: $_[0]");
 209   }
 210   $action = "$_[0]";
 211 }
 212
 213 # Record Parts requested for checking
 214 # Options: -C|--check-part
 215 sub record_check_part {
 216   if (defined $action and $action eq 'check' and $checks) {
 217     die("multiple -C or --check-part options not allowed");
 218   }
 219   if ($dont_check) {
 220     die("both -C or --check-part and -X or --dont-check-part options not allowed");
 221   }
 222   if ($action) {
 223     die("too many actions specified: $_[0]");
 224   }
 225   $action = 'check';
 226   $checks = "$_[1]";
 227 }
 228
 229 # Record Parts requested for checking
 230 # Options: -T|--tags
 231 sub record_check_tags {
 232     if (defined $action and $action eq 'check' and $check_tags) {
 233         die("multiple -T or --tags options not allowed");
 234     }
 235     if ($checks) {
 236         die("both -T or --tags and -C or --check-part options not allowed");
 237     }
 238     if ($dont_check) {
 239         die("both -T or --tags and -X or --dont-check-part options not allowed");
 240     }
 241     if ($action) {
 242         die("too many actions specified: $_[0]");
 243     }
 244     $action = 'check';
 245     $check_tags = "$_[1]";
 246 }
 247
 248 # Record Parts requested for checking
 249 # Options: --tags-from-file
 250 sub record_check_tags_from_file {
 251     open my $file, '<', $_[1]
 252         or fail("failed to open $_[1]: $!");
 253     my $tags =  join(',', map { chomp($_); $_ } <$file>);
 254     close $file;
 255
 256     record_check_tags($_[0], $tags);
 257 }
 258
 259
 260 # Record Parts requested not to check
 261 # Options: -X|--dont-check-part X
 262 sub record_dont_check_part {
 263     if (defined $action and $action eq 'check' and $dont_check) {
 264         die("multiple -X or --dont-check-part options not allowed");
 265     }
 266     if ($checks) {
 267         die("both -C or --check-part and -X or --dont-check-part options not allowed");
 268     }
 269     if ($action) {
 270         die("too many actions specified: $_[0]");
 271     }
 272     $action = 'check';
 273     $dont_check = "$_[1]";
 274 }
 275
 276
 277 # Process for -U|--unpack-info flag
 278 sub record_unpack_info {
 279     if ($unpack_info) {
 280         die("multiple -U or --unpack-info options not allowed");
 281     }
 282     $unpack_info = "$_[1]";
 283 }
 284
 285 # Record what type of data is specified
 286 # Options: -b|--binary, -s|--source, --udeb
 287 sub record_pkgmode {
 288     $pkg_mode = 'b' if $_[0] eq 'binary';
 289     $pkg_mode = 's' if $_[0] eq 'source';
 290     $pkg_mode = 'u' if $_[0] eq 'udeb';
 291 }
 292
 293 # Process -L|--display-level flag
 294 sub record_display_level {
 295     my $level = $_[1];
 296     if ($level =~ m/^\+(.+)/) {
 297         set_display_level($1, 1);
 298     } elsif ($level =~ m/^\-(.+)/) {
 299         set_display_level($1, 0);
 300     } elsif ($level =~ m/^\=?(.+)/) {
 301         reset_display_level();
 302         set_display_level($1, 1);
 303     } else {
 304         die "invalid argument to --display-level: $level\n";
 305     }
 306 }
 307
 308 # Process -I|--display-info flag
 309 sub display_infotags {
 310     foreach my $s (@severities) {
 311         set_display_level($s, 1);
 312     }
 313 }
 314
 315 # Process --display-source flag
 316 sub record_display_source {
 317     $display_source{$_[1]} = 1;
 318 }
 319
 320 # Clears current display level information, disabling all severities and
 321 # certainties
 322 sub reset_display_level {
 323     foreach my $s (@severities) {
 324         foreach my $c (@certainties) {
 325             $display_level{$s}{$c} = 0;
 326         }
 327     }
 328 }
 329
 330 sub set_display_level_multi {
 331     my ($op, $level, $val) = @_;
 332
 333     my @inc_severities = @severities;
 334     my @inc_certainties = @certainties;
 335     my $inc_border = ($op =~ /^[<>]=$/) ? 1 : 0;
 336     if ($op =~ /^>/) {
 337         @inc_severities = reverse @inc_severities;
 338         @inc_certainties = reverse @inc_certainties;
 339     }
 340     my $severity = join("|", @severities);
 341     my $certainty = join("|", @certainties);
 342     if ($level =~ m/^($severity)$/) {
 343         foreach my $s (cut_list($level, $inc_border, @inc_severities)) {
 344             map { $display_level{$s}{$_} = $val } @certainties;
 345         }
 346     } elsif ($level =~ m/^($certainty)$/) {
 347         foreach my $c (cut_list($level, $inc_border, @inc_certainties)) {
 348             map { $display_level{$_}{$c} = $val } @severities;
 349         }
 350     } elsif ($level =~ m/^($severity)\/($certainty)$/) {
 351         foreach my $s (cut_list($1, $inc_border, @inc_severities)) {
 352             foreach my $c (cut_list($2, $inc_border, @inc_certainties)) {
 353                 $display_level{$s}{$c} = $val;
 354             }
 355         }
 356     } else {
 357         die "invalid argument to --display-level: $level\n";
 358     }
 359
 360 }
 361
 362 sub cut_list {
 363     my ($border, $inc_border, @list) = @_;
 364
 365     my (@newlist, $found);
 366     foreach (@list) {
 367         if ($_ eq $border) {
 368             push @newlist, $_ if $inc_border;
 369             $found = 1;
 370             last;
 371         } else {
 372             push @newlist, $_;
 373         }
 374     }
 375     die "internal error: cut_list did not find border $border\n"
 376         unless $found;
 377     if (!$inc_border and !@newlist
 378         and $border eq $list[0]) {
 379         warn "warning: display level $border specified with > (or <) is empty set, assuming >= (or <=)\n";
 380         push @newlist, $list[0];
 381     }
 382
 383     return @newlist;
 384 }
 385
 386 # Parse input display level to enable (val 1) or disable (val 0) it
 387 # accordingly
 388 sub set_display_level {
 389     my ($level, $val) = @_;
 390     if ($level =~ m/^([<>]=?)(.+)/) {
 391         set_display_level_multi($1, $2, $val);
 392         return;
 393     }
 394
 395     my $severity = join("|", @severities);
 396     my $certainty = join("|", @certainties);
 397     if ($level =~ m/^($severity)$/) {
 398         map { $display_level{$1}{$_} = $val } @certainties;
 399     } elsif ($level =~ m/^($certainty)$/) {
 400         map { $display_level{$_}{$1} = $val } @severities;
 401     } elsif ($level =~ m/^($severity)\/($certainty)$/) {
 402         $display_level{$1}{$2} = $val;
 403     } else {
 404         die "invalid argument to --display-level: $level\n";
 405     }
 406 }
 407
 408 # Hash used to process commandline options
 409 my %opthash = (
 410                # ------------------ actions
 411                "setup-lab|S" => \&record_action,
 412                "remove-lab|R" => \&record_action,
 413                "check|c" => \&record_action,
 414                "check-part|C=s" => \&record_check_part,
 415                "tags|T=s" => \&record_check_tags,
 416                "tags-from-file=s" => \&record_check_tags_from_file,
 417                "dont-check-part|X=s" => \&record_dont_check_part,
 418                "unpack|u" => \&record_action,
 419                "remove|r" => \&record_action,
 420
 421                # ------------------ general options
 422                "help|h" => \&syntax,
 423                "version|V" => \&banner,
 424                "print-version" => \&banner,
 425
 426                "verbose|v" => \$verbose,
 427                "debug|d" => \@debug, # Count the -d flags
 428                "quiet|q" => \$quiet,
 429
 430                # ------------------ behaviour options
 431                "info|i" => \$maemian_info,
 432                "display-info|I" => \&display_infotags,
 433                "display-experimental|E" => \$display_experimentaltags,
 434                "pedantic" => \$display_pedantictags,
 435                "display-level|L=s" => \&record_display_level,
 436                "display-source=s" => \&record_display_source,
 437                "unpack-level|l=i" => \$unpack_level,
 438                "no-override|o" => \$no_override,
 439                "show-overrides" => \$show_overrides,
 440                "color=s" => \$color,
 441                "unpack-info|U=s" => \&record_unpack_info,
 442                "checksums|md5sums|m" => \$check_checksums,
 443                "allow-root" => \$allow_root,
 444                "fail-on-warnings" => \$fail_on_warnings,
 445                "keep-lab" => \$keep_lab,
 446                # Note: Ubuntu has (and other derivatives might gain) a
 447                # -D/--debian option to make maemian behave like in Debian, that
 448                # is, to revert distribution-specific changes
 449
 450                # ------------------ configuration options
 451                "cfg=s" => \$MAEMIAN_CFG,
 452                "lab=s" => \$OPT_MAEMIAN_LAB,
 453                "archivedir=s" => \$OPT_MAEMIAN_ARCHIVEDIR,
 454                "dist=s" => \$OPT_MAEMIAN_DIST,
 455                "area=s" => \$OPT_MAEMIAN_AREA,
 456                "section=s" => \$OPT_MAEMIAN_AREA,
 457                "arch=s" => \$OPT_MAEMIAN_ARCH,
 458                "root=s" => \$MAEMIAN_ROOT,
 459
 460                # ------------------ package selection options
 461                "all|a" => \$check_everything,
 462                "binary|b" => \&record_pkgmode,
 463                "source|s" => \&record_pkgmode,
 464                "udeb" => \&record_pkgmode,
 465                "packages-file|p=s" => \$packages_file,
 466
 467                # ------------------ experimental
 468                "exp-output:s" => \$experimental_output_opts,
 469               );
 470
 471 # init display level settings
 472 reset_display_level();
 473 set_display_level_multi('>=', 'important', 1);
 474 set_display_level_multi('>=', 'normal/possible', 1);
 475 set_display_level('minor/certain', 1);
 476
 477 # init commandline parser
 478 Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev');
 479
 480 # process commandline options
 481 GetOptions(%opthash)
 482     or die("error parsing options\n");
 483
 484 # determine current working directory--we'll need this later
 485 chop($cwd = `pwd`);
 486
 487 # determine MAEMIAN_ROOT if it was not set with --root.
 488 $MAEMIAN_ROOT = $MAEMIAN_ROOT || $ENV{'MAEMIAN_ROOT'};
 489 if (defined $MAEMIAN_ROOT) {
 490     unless ($MAEMIAN_ROOT =~ m,^/,) {
 491         $MAEMIAN_ROOT = "$cwd/$MAEMIAN_ROOT";
 492     }
 493 } else {
 494     $MAEMIAN_ROOT = '/usr/share/maemian';
 495 }
 496
 497 # keep-lab implies unpack-level=2 unless explicetly
 498 # given otherwise
 499 if ($keep_lab and not defined $unpack_level) {
 500     $unpack_level = 2;
 501 }
 502
 503 # option --all and packages specified at the same time?
 504 if (($check_everything or $packages_file) and $#ARGV+1 > 0) {
 505     print STDERR "warning: options -a or -p can't be mixed with package parameters!\n";
 506     print STDERR "(will ignore -a or -p option)\n";
 507     undef $check_everything;
 508     undef $packages_file;
 509 }
 510
 511 # check permitted values for --color
 512 if ($color and $color !~ /^(never|always|auto|html)$/) {
 513     die "invalid argument to --color: $color\n";
 514 }
 515
 516 # check specified action
 517 $action = 'check' unless $action;
 518
 519 # check for arguments
 520 if ($action =~ /^(check|unpack|remove)$/ and $#ARGV == -1 and not $check_everything and not $packages_file) {
 521     syntax();
 522 }
 523
 524 # }}}
 525
 526 # {{{ Setup Configuration
 527 #
 528 # root permissions?
 529 # check if effective UID is 0
 530 if ($> == 0 and not $allow_root) {
 531     print STDERR "warning: maemian's authors do not recommend running it with root privileges!\n";
 532 }
 533
 534 # search for configuration file if it was not set with --cfg
 535 # do not search the default locations if it was set.
 536 if ($MAEMIAN_CFG) {
 537 } elsif (exists $ENV{'MAEMIAN_CFG'} &&
 538          -f ($MAEMIAN_CFG = $ENV{'MAEMIAN_CFG'})) {
 539 } elsif (-f ($MAEMIAN_CFG = $MAEMIAN_ROOT . '/maemianrc')) {
 540 } elsif (exists $ENV{'HOME'} &&
 541          -f ($MAEMIAN_CFG = $ENV{'HOME'} . '/.maemianrc')) {
 542 } elsif (-f ($MAEMIAN_CFG = '/etc/maemianrc')) {
 543 } else {
 544     undef $MAEMIAN_CFG;
 545 }
 546
 547 use constant VARS => qw(LAB ARCHIVEDIR DIST UNPACK_LEVEL SECTION AREA ARCH);
 548 # read configuration file
 549 if ($MAEMIAN_CFG) {
 550     open(CFG, '<', $MAEMIAN_CFG)
 551         or die("cannot open configuration file $MAEMIAN_CFG for reading: $!");
 552     while (<CFG>) {
 553         chop;
 554         s/\#.*$//go;
 555         s/\"//go;
 556         next if m/^\s*$/o;
 557
 558         # substitute some special variables
 559         s,\$HOME/,$ENV{'HOME'}/,go;
 560         s,\~/,$ENV{'HOME'}/,go;
 561
 562         my $found = 0;
 563         foreach my $var (VARS) {
 564             no strict 'refs';
 565             $var = "MAEMIAN_$var";
 566             if (m/^\s*$var\s*=\s*(.*\S)\s*$/i) {
 567                 $$var = $1;
 568                 $found = 1;
 569                 last;
 570             }
 571         }
 572         unless ($found) {
 573             die "syntax error in configuration file: $_\n";
 574         }
 575     }
 576     close(CFG);
 577 }
 578
 579 # environment variables overwrite settings in conf file:
 580 foreach (VARS) {
 581     no strict 'refs';
 582     my $var = "MAEMIAN_$_";
 583     my $opt_var = "OPT_$var";
 584     $$var = $ENV{$var} if $ENV{$var};
 585     $$var = $$opt_var if $$opt_var;
 586 }
 587
 588 # MAEMIAN_ARCH must have a value.
 589 unless (defined $MAEMIAN_ARCH) {
 590     if ($MAEMIAN_DIST) {
 591         chop($MAEMIAN_ARCH=`dpkg --print-architecture`);
 592     } else {
 593         $MAEMIAN_ARCH = 'any';
 594     }
 595 }
 596
 597 # MAEMIAN_SECTION is deprecated in favour of MAEMIAN_AREA
 598 if (defined $MAEMIAN_SECTION) {
 599     print STDERR "warning: MAEMIAN_SECTION has been deprecated in favour of MAEMIAN_AREA.\n";
 600     if (defined $MAEMIAN_AREA) {
 601         print STDERR "Using MAEMIAN_AREA as both were defined.\n";
 602     } else {
 603         print STDERR "Both are currently accepted, but MAEMIAN_SECTION may be removed\n";
 604         print STDERR "in a future Maemian release.\n";
 605         $MAEMIAN_AREA = $MAEMIAN_SECTION;
 606     }
 607 }
 608
 609 # determine requested unpack level
 610 if (defined($unpack_level)) {
 611     # specified through command line
 612 } elsif (defined($MAEMIAN_UNPACK_LEVEL)) {
 613     # specified via configuration file or env variable
 614     $unpack_level = $MAEMIAN_UNPACK_LEVEL;
 615 } else {
 616     # determine by action
 617     if (($action eq 'unpack') or ($action eq 'check')) {
 618         $unpack_level = 1;
 619     } else {
 620         $unpack_level = 0;
 621     }
 622 }
 623 unless (($unpack_level == 0) or ($unpack_level == 1) or ($unpack_level == 2)) {
 624     die("bad unpack level $unpack_level specified");
 625 }
 626
 627 $MAEMIAN_UNPACK_LEVEL = $unpack_level;
 628
 629 # export current settings for our helper scripts
 630 foreach (('ROOT', 'CFG', VARS)) {
 631     no strict 'refs';
 632     my $var = "MAEMIAN_$_";
 633     if ($$var) {
 634         $ENV{$var} = $$var;
 635     } else {
 636         $ENV{$var} = "";
 637         $$var = "";
 638     }
 639 }
 640
 641 my $debug = $#debug + 1;
 642 $verbose = 1 if $debug;
 643 $ENV{'MAEMIAN_DEBUG'} = $debug;
 644
 645 #  Loading maeian's own libraries (now that MAEMIAN_ROOT is known)
 646 unshift @INC, "$MAEMIAN_ROOT/lib";
 647
 648 require Lab;
 649
 650 require Util;
 651 require Read_pkglists;
 652
 653 import Util;
 654
 655 require Tags;
 656 import Tags;
 657
 658 require Maemian::Data;
 659 require Maemian::Schedule;
 660 require Maemian::Output;
 661 import Maemian::Output qw(:messages);
 662 require Maemian::Command;
 663 import Maemian::Command qw(spawn reap);
 664 require Maemian::Check;
 665 import Maemian::Check qw(check_maintainer);
 666
 667 no warnings 'once';
 668 if (defined $experimental_output_opts) {
 669     my %opts = map { split(/=/) } split( /,/, $experimental_output_opts );
 670     foreach (keys %opts) {
 671         if ($_ eq 'format') {
 672             if ($opts{$_} eq 'colons') {
 673                 require Maemian::Output::ColonSeparated;
 674                 $Maemian::Output::GLOBAL = new Maemian::Output::ColonSeparated;
 675             } elsif ($opts{$_} eq 'letterqualifier') {
 676                 require Maemian::Output::LetterQualifier;
 677                 $Maemian::Output::GLOBAL = new Maemian::Output::LetterQualifier;
 678             } elsif ($opts{$_} eq 'xml') {
 679                 require Maemian::Output::XML;
 680                 $Maemian::Output::GLOBAL = new Maemian::Output::XML;
 681             }
 682         }
 683         no strict 'refs';
 684         ${"Tags::$_"} = $opts{$_};
 685     }
 686 }
 687
 688 $Maemian::Output::GLOBAL->verbose($verbose);
 689 $Maemian::Output::GLOBAL->debug($debug);
 690 $Maemian::Output::GLOBAL->quiet($quiet);
 691 $Maemian::Output::GLOBAL->color($color);
 692 $Maemian::Output::GLOBAL->showdescription($maemian_info);
 693
 694 # Print Debug banner, now that we're finished determining
 695 # the values and have Maemian::Output available
 696 debug_msg(1,
 697           $BANNER,
 698           "Maemian root directory: $MAEMIAN_ROOT",
 699           "Configuration file: $MAEMIAN_CFG",
 700           "Laboratory: $MAEMIAN_LAB",
 701           "Archive directory: $MAEMIAN_ARCHIVEDIR",
 702           "Distribution: $MAEMIAN_DIST",
 703           "Default unpack level: $MAEMIAN_UNPACK_LEVEL",
 704           "Architecture: $MAEMIAN_ARCH",
 705           delimiter(),
 706     );
 707
 708 my @l_secs = read_dpkg_control("$MAEMIAN_ROOT/checks/maemian.desc");
 709 shift(@l_secs);
 710 map { $_->{'script'} = 'maemian'; Tags::add_tag($_) } @l_secs;
 711
 712 $Tags::show_experimental = $display_experimentaltags;
 713 $Tags::show_pedantic = $display_pedantictags;
 714 $Tags::show_overrides = $show_overrides;
 715 %Tags::display_level = %display_level;
 716 %Tags::display_source = %display_source;
 717 %Tags::only_issue_tags = map { $_ => 1 } (split(/,/, $check_tags))
 718
 719   if defined $check_tags;
 720 use warnings;
 721 use vars qw(%source_info %binary_info %udeb_info); # from the above
 722
 723 # Set up clean-up handlers.
 724 undef $cleanup_filename;
 725 $SIG{'INT'} = \&interrupted;
 726 $SIG{'QUIT'} = \&interrupted;
 727
 728 # }}}
 729
 730 # {{{ Create/Maintain Lab and add any specified Debian Archives (*.debs)
 731
 732 $LAB = new Lab( $MAEMIAN_LAB, $MAEMIAN_DIST );
 733
 734 #######################################
 735 # Process -S option
 736 if ($action eq 'setup-lab') {
 737     if ($#ARGV+1 > 0) { # Cannot define Lab on the command line.
 738         warning("ignoring additional command line arguments");
 739     }
 740
 741     $LAB->setup_static()
 742         or fail("There was an error while setting up the static lab.");
 743
 744     exit 0;
 745
 746 #######################################
 747 # Process -R option
 748 } elsif ($action eq 'remove-lab') {
 749     if ($#ARGV+1 > 0) {
 750         warning("ignoring additional command line arguments");
 751     }
 752
 753     $LAB->delete_static()
 754         or fail("There was an error while removing the static lab.");
 755
 756     exit 0;
 757
 758 #######################################
 759 #  Check for non deb specific actions
 760 } elsif (not (($action eq 'unpack') or ($action eq 'check')
 761               or ($action eq 'remove'))) {
 762     fail("bad action $action specified");
 763 }
 764
 765 # sanity check:
 766 fail("maemian lab has not been set up correctly (perhaps you forgot to run maemian --setup-lab?)")
 767     unless $LAB->is_lab();
 768
 769 #XXX: There has to be a cleaner way to do this
 770 $MAEMIAN_LAB = $LAB->{dir};
 771
 772 # }}}
 773
 774 # {{{ Compile list of files to process
 775
 776 $schedule = new Maemian::Schedule(verbose => $verbose);
 777 # process package/file arguments
 778 while (my $arg = shift) {
 779     # file?
 780     if (-f $arg) {
 781         # $arg contains absolute dir spec?
 782         unless ($arg =~ m,^/,) {
 783             $arg = "$cwd/$arg";
 784         }
 785
 786         # .deb file?
 787         if ($arg =~ /\.deb$/) {
 788             $schedule->add_deb('b', $arg)
 789                 or warning("$arg is a zero-byte file, skipping");
 790         }
 791         # .udeb file?
 792         elsif ($arg =~ /\.udeb$/) {
 793             $schedule->add_deb('u', $arg)
 794                 or warning("$arg is a zero-byte file, skipping");
 795         }
 796         # .dsc file?
 797         elsif ($arg =~ /\.dsc$/) {
 798             $schedule->add_dsc($arg)
 799                 or warning("$arg is a zero-byte file, skipping");
 800         }
 801         # .changes file?
 802         elsif ($arg =~ /\.changes$/) {
 803             # get directory and filename part of $arg
 804             my ($arg_dir, $arg_name) = $arg =~ m,(.*)/([^/]+)$,;
 805
 806             v_msg("Processing changes file $arg_name ...");
 807
 808             my ($data) = read_dpkg_control($arg);
 809             if (not defined $data) {
 810                 warning("$arg is a zero-byte file, skipping");
 811                 next;
 812             }
 813             Tags::set_pkg( $arg, $arg_name, "", "", 'binary' );
 814
 815             # If we don't have a Format key, something went seriously wrong.
 816             # Tag the file and skip remaining processing.
 817             if (!$data->{'format'}) {
 818                 tag('malformed-changes-file');
 819                 next;
 820             }
 821
 822             # Description is mandated by dak, but only makes sense if binary
 823             # packages are included.  Don't tag pure source uploads.
 824             if (!$data->{'description'} && $data->{'architecture'} ne 'source') {
 825                 tag("no-description-in-changes-file");
 826             }
 827
 828             # check distribution field
 829             if (defined $data->{distribution}) {
 830                 my $ubuntu_dists = Maemian::Data->new ('changelog-file/ubuntu-dists');
 831                 my $ubuntu_regex = join('|', $ubuntu_dists->all);
 832                 my @distributions = split /\s+/o, $data->{distribution};
 833                 for my $distribution (@distributions) {
 834                     if ($distribution eq 'UNRELEASED') {
 835                         # ignore
 836                     } elsif ($data->{version} =~ /ubuntu|$ubuntu_regex/
 837                          or $distribution =~ /$ubuntu_regex/) {
 838                         if ($distribution !~ /^($ubuntu_regex)(-(proposed|updates|backports|security))?$/ ) {
 839                             tag("bad-ubuntu-distribution-in-changes-file",
 840                                 $distribution);
 841                         }
 842                     } elsif (! (($distribution eq 'oldstable')
 843                                  or ($distribution eq 'stable')
 844                                  or ($distribution eq 'testing')
 845                                  or ($distribution eq 'unstable')
 846                                  or ($distribution eq 'experimental')
 847                                  or ($distribution =~ /^\w+-backports$/)
 848                                  or ($distribution =~ /^\w+-proposed-updates$/)
 849                                  or ($distribution =~ /^\w+-security$/))
 850                             ) {
 851                         # bad distribution entry
 852                         tag("bad-distribution-in-changes-file",
 853                             $distribution);
 854                     }
 855                 }
 856
 857                 if ($#distributions > 0) {
 858                     # Currently disabled until dak stops accepting the syntax
 859                     # tag("multiple-distributions-in-changes-file",
 860                     #    $data->{'distribution'});
 861                 }
 862             }
 863
 864             # Urgency is only recommended by Policy.
 865             if (!$data->{'urgency'}) {
 866                 tag("no-urgency-in-changes-file");
 867             } else {
 868                 my $urgency = lc $data->{'urgency'};
 869                 $urgency =~ s/ .*//;
 870                 unless ($urgency =~ /^(low|medium|high|critical|emergency)$/i) {
 871                     tag("bad-urgency-in-changes-file", $data->{'urgency'});
 872                 }
 873             }
 874
 875             # Changed-By is optional in Policy, but if set, must be
 876             # syntactically correct.  It's also used by dak.
 877             if ($data->{'changed-by'}) {
 878                 check_maintainer($data->{'changed-by'}, 'changed-by');
 879             }
 880
 881             # process all listed `files:'
 882             my %files;
 883
 884             my $file_list = $data->{files} || '';
 885             for ( split /\n/, $file_list ) {
 886                 chomp;
 887                 s/^\s+//o;
 888                 next if $_ eq '';
 889
 890                 my ($md5sum,$size,$section,$priority,$file) = split(/\s+/o, $_);
 891                 $files{$file}{md5} = $md5sum;
 892                 $files{$file}{size} = $size;
 893
 894                 # check section
 895                 if (($section eq 'non-free') or ($section eq 'contrib')) {
 896                     tag( "bad-section-in-changes-file", $file, $section );
 897                 }
 898
 899             }
 900
 901             foreach my $alg (qw(sha1 sha256)) {
 902                 my $list = $data->{"checksums-$alg"} || '';
 903                 for ( split /\n/, $list ) {
 904                     chomp;
 905                     s/^\s+//o;
 906                     next if $_ eq '';
 907
 908                     my ($checksum,$size,$file) = split(/\s+/o, $_);
 909                     $files{$file}{$alg} = $checksum;
 910                     if ($files{$file}{size} != $size) {
 911                         tag( "file-size-mismatch-in-changes-file", $file,
 912                              "$files{$file}{size} != $size" );
 913                     }
 914                 }
 915             }
 916
 917
 918             foreach my $file (keys %files) {
 919                 my $filename = $arg_dir . '/' . $file;
 920
 921                 # check size
 922                 if (not -f $filename) {
 923                     warning("$file does not exist, exiting");
 924                     exit 2;
 925                 }
 926                 my $size = -s _;
 927                 if ($size ne $files{$file}{size}) {
 928                     tag( "file-size-mismatch-in-changes-file", $file,
 929                          "$files{$file}{size} != $size");
 930                 }
 931
 932                 # check checksums
 933                 if ($check_checksums or $file =~ /\.dsc$/) {
 934                     foreach my $alg (qw(md5 sha1 sha256)) {
 935                         next unless exists $files{$file}{$alg};
 936
 937                         my $real_checksum = get_file_checksum($alg, $filename);
 938
 939                         if ($real_checksum ne $files{$file}{$alg}) {
 940                             tag( "checksum-mismatch-in-changes-file", $alg, $file );
 941                         }
 942                     }
 943                 }
 944
 945                 # process file?
 946                 if ($file =~ /\.dsc$/) {
 947                     $schedule->add_dsc($filename);
 948                 } elsif ($file =~ /\.deb$/) {
 949                     $schedule->add_deb('b', $filename);
 950                 } elsif ($file =~ /\.udeb$/) {
 951                     $schedule->add_deb('u', $filename);
 952                 }
 953             }
 954
 955             unless ($exit_code) {
 956                 my $stats = Tags::get_stats( $arg );
 957                 if ($stats->{types}{E}) {
 958                     $exit_code = 1;
 959                 } elsif ($fail_on_warnings && $stats->{types}{W}) {
 960                     $exit_code = 1;
 961                 }
 962             }
 963
 964         } else {
 965             fail("bad package file name $arg (neither .deb, .udeb or .dsc file)");
 966         }
 967     } else {
 968         # parameter is a package name--so look it up
 969         # search the distribution first, then the lab
 970         # special case: search only in lab if action is `remove'
 971
 972         my $search;
 973         if ($action eq 'remove') {
 974             # search only in lab--see below
 975             $search = 'lab';
 976         } else {
 977             # search in dist, then in lab
 978             $search = 'dist or lab';
 979
 980             my $found = 0;
 981
 982             # read package info
 983             read_src_list("$MAEMIAN_LAB/info/source-packages", 0);
 984             read_bin_list("$MAEMIAN_LAB/info/binary-packages", 0);
 985             read_udeb_list("$MAEMIAN_LAB/info/udeb-packages", 0);
 986
 987             if (($pkg_mode eq 'b') or ($pkg_mode eq 'a')) {
 988                 if ($binary_info{$arg}) {
 989                     $schedule->add_file('b', "$MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}",
 990                                         %{$binary_info{$arg}});
 991                     $found = 1;
 992                 }
 993             }
 994             if (($pkg_mode eq 'u') or ($pkg_mode eq 'a')) {
 995                 if ($udeb_info{$arg}) {
 996                     $schedule->add_file('u', "$MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}",
 997                                         %{$udeb_info{$arg}});
 998                     $found = 1;
 999                 }
1000             }
1001             if (($pkg_mode eq 's') or ($pkg_mode eq 'a')) {
1002                 if ($source_info{$arg}) {
1003                     $schedule->add_file('s', "$MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}",
1004                                         %{$source_info{$arg}});
1005                     $found = 1;
1006                 }
1007             }
1008
1009             next if $found;
1010         }
1011
1012         # nothing found so far, so search the lab
1013
1014         my $b = "$MAEMIAN_LAB/binary/$arg";
1015         my $s = "$MAEMIAN_LAB/source/$arg";
1016         my $u = "$MAEMIAN_LAB/udeb/$arg";
1017
1018         if ($pkg_mode eq 'b') {
1019             unless (-d $b) {
1020                 warn "error: cannot find binary package $arg in $search (skipping)\n";
1021                 $exit_code = 2;
1022                 next;
1023             }
1024         } elsif ($pkg_mode eq 's') {
1025             unless (-d $s) {
1026                 warning("cannot find source package $arg in $search (skipping)");
1027                 $exit_code = 2;
1028                 next;
1029             }
1030         } elsif ($pkg_mode eq 'u') {
1031             unless (-d $u) {
1032                 warning("cannot find udeb package $arg in $search (skipping)");
1033                 $exit_code = 2;
1034                 next;
1035             }
1036         } else {
1037             # $pkg_mode eq 'a'
1038             unless (-d $b or -d $s or -d $u) {
1039                 warning("cannot find binary, udeb or source package $arg in $search (skipping)");
1040                 $exit_code = 2;
1041                 next;
1042             }
1043         }
1044
1045         if (($pkg_mode eq 'b') or (($pkg_mode eq 'a') and (-d $b))) {
1046             $schedule->add_file('b', get_bin_info_from_lab($b));
1047         }
1048         if (($pkg_mode eq 's') or (($pkg_mode eq 'a') and (-d $s))) {
1049             $schedule->add_file('s', get_src_info_from_lab($s));
1050         }
1051         if (($pkg_mode eq 'u') or (($pkg_mode eq 'a') and (-d $u))) {
1052             $schedule->add_file('u', get_bin_info_from_lab($u));
1053         }
1054     }
1055 }
1056
1057 if (not $check_everything and not $packages_file and not $schedule->count) {
1058     v_msg("No packages selected.");
1059     exit $exit_code;
1060 }
1061
1062 #  Check to make sure there are packages to check.
1063 sub set_value {
1064     my ($f,$target,$field,$source,$required) = @_;
1065     use YAML;
1066 #    print map { Dump($_) } @_;
1067     if ($required and not $source->{$field}) {
1068       print Dump($f)."\n";
1069       fail("description file $f does not define required tag $field");
1070     }
1071     $target->{$field} = $source->{$field};
1072     delete $source->{$field};
1073 }
1074
1075 opendir(COLLDIR, "$MAEMIAN_ROOT/collection")
1076     or fail("cannot read directory $MAEMIAN_ROOT/collection");
1077
1078 for my $f (readdir COLLDIR) {
1079     next if $f =~ /^\./;
1080     next unless $f =~ /\.desc$/;
1081
1082     debug_msg(2, "Reading collector description file $f ...");
1083     my @secs = read_dpkg_control("$MAEMIAN_ROOT/collection/$f");
1084     my $script;
1085     ($#secs+1 == 1)
1086         or fail("syntax error in description file $f: too many sections");
1087
1088     ($script = $secs[0]->{'collector-script'})
1089         or fail("error in description file $f: `Collector-Script:' not defined");
1090
1091     delete $secs[0]->{'collector-script'};
1092     $collection_info{$script}->{'script'} = $script;
1093     my $p = $collection_info{$script};
1094
1095     set_value($f, $p,'type',$secs[0],1);
1096     # convert Type:
1097     my ($b,$s,$u) = ( "", "", "" );;
1098     for (split(/\s*,\s*/o,$p->{'type'})) {
1099         if ($_ eq 'binary') {
1100             $b = 'b';
1101         } elsif ($_ eq 'source') {
1102             $s = 's';
1103         } elsif ($_ eq 'udeb') {
1104             $u = 'u';
1105         } else {
1106             fail("unknown type $_ specified in description file $f");
1107         }
1108     }
1109     $p->{'type'} = "$s$b$u";
1110
1111     set_value($f,$p,'unpack-level',$secs[0],1);
1112     set_value($f,$p,'order',$secs[0],1);
1113     set_value($f,$p,'version',$secs[0],1);
1114
1115     if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
1116         for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
1117             $p->{$_} = 1;
1118         }
1119         delete $secs[0]->{'needs-info'};
1120     }
1121
1122     # ignore Info: and other fields for now
1123     delete $secs[0]->{'info'};
1124     delete $secs[0]->{'author'};
1125
1126     for (keys %{$secs[0]}) {
1127         warning("unused tag $_ in description file $f");
1128     }
1129
1130     debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));
1131 }
1132
1133 closedir(COLLDIR);
1134 # }}}
1135
1136 # {{{ Now we're ready to load info about checks & tags
1137
1138 # load information about checker scripts
1139 opendir(CHECKDIR, "$MAEMIAN_ROOT/checks")
1140     or fail("cannot read directory $MAEMIAN_ROOT/checks");
1141
1142 for my $f (readdir CHECKDIR) {
1143     next if $f =~ /^\./;
1144     next unless $f =~ /\.desc$/;
1145     debug_msg(2, "Reading checker description file $f ...");
1146
1147     my @secs = read_dpkg_control("$MAEMIAN_ROOT/checks/$f");
1148     my $script;
1149     ($script = $secs[0]->{'check-script'})
1150         or fail("error in description file $f: `Check-Script:' not defined");
1151
1152     # ignore check `maemian' (this check is a special case and contains the
1153     # tag info for the maemian frontend--this script here)
1154     next if $script eq 'maemian';
1155
1156     delete $secs[0]->{'check-script'};
1157     $check_info{$script}->{'script'} = $script;
1158     my $p = $check_info{$script};
1159
1160     set_value($f,$p,'type',$secs[0],1);
1161     # convert Type:
1162     my ($b,$s,$u) = ( "", "", "" );
1163     for (split(/\s*,\s*/o,$p->{'type'})) {
1164         if ($_ eq 'binary') {
1165             $b = 'b';
1166         } elsif ($_ eq 'source') {
1167             $s = 's';
1168         } elsif ($_ eq 'udeb') {
1169             $u = 'u';
1170         } else {
1171             fail("unknown type $_ specified in description file $f");
1172         }
1173     }
1174     $p->{'type'} = "$s$b$u";
1175
1176     set_value($f,$p,'unpack-level',$secs[0],1);
1177     set_value($f,$p,'abbrev',$secs[0],1);
1178
1179     if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
1180         for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
1181             $p->{$_} = 1;
1182         }
1183         delete $secs[0]->{'needs-info'};
1184     }
1185
1186     # ignore Info: and other fields for now...
1187     delete $secs[0]->{'info'};
1188     delete $secs[0]->{'standards-version'};
1189     delete $secs[0]->{'author'};
1190
1191     for (keys %{$secs[0]}) {
1192         warning("unused tag $_ in description file $f");
1193     }
1194
1195     debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));
1196
1197     shift(@secs);
1198     $p->{'requested-tags'} = 0;
1199     foreach my $tag (@secs) {
1200         $tag->{'script'} = $script;
1201         Tags::add_tag($tag);
1202         $p->{'requested-tags'}++ if Tags::display_tag($tag);
1203     }
1204 }
1205
1206 closedir(CHECKDIR);
1207
1208 # }}}
1209
1210 # {{{ Again some lone code the author just dumped where his cursor just happened to be
1211 if ($unpack_info) {
1212     # determine which info has been requested
1213     for my $i (split(/,/,$unpack_info)) {
1214         unless ($collection_info{$i}) {
1215             fail("unknown info specified: $i");
1216         }
1217         $unpack_infos{$i} = 1;
1218     }
1219 }
1220
1221 # create check_abbrev hash
1222 for my $c (keys %check_info) {
1223     $check_abbrev{$check_info{$c}->{'abbrev'}} = $c;
1224 }
1225
1226 # }}}
1227
1228 # {{{ determine which checks have been requested
1229 if ($action eq 'check') {
1230     if ($check_tags) {
1231         foreach my $t (split(/,/, $check_tags)) {
1232             my $info = Tags::get_tag_info($t);
1233
1234             fail("unknown tag specified: $t") unless defined($info);
1235             my $script = $info->{'script'};
1236             next if $script eq 'maemian';
1237             if ($check_info{$script}) {
1238                 $checks{$script} = 1;
1239             } else {
1240                 # should never happen
1241                 fail("no info for script $script");
1242             }
1243         }
1244     } else {
1245         my %dont_check = map { $_ => 1 } (split m/,/, ($dont_check || ""));
1246         $checks or ($checks = join(',',keys %check_info));
1247         for my $c (split(/,/,$checks)) {
1248             if ($check_info{$c}) {
1249                 if ($dont_check{$c}
1250                     || ($check_info{$c}->{'abbrev'}
1251                         && $dont_check{$check_info{$c}->{'abbrev'}})) {
1252                     #user requested not to run this check
1253                 } elsif ($check_info{$c}->{'requested-tags'} == 0) {
1254                     #no need to run this check, no tags will be issued
1255                 } else {
1256                     $checks{$c} = 1;
1257                 }
1258             } elsif (exists $check_abbrev{$c}) {
1259                 #abbrevs only used when -C is given, so we don't need %dont_check
1260                 $checks{$check_abbrev{$c}} = 1;
1261             } else {
1262                 fail("unknown check specified: $c");
1263             }
1264         }
1265     }
1266
1267     # determine which info is needed by the checks
1268     for my $c (keys %checks) {
1269         for my $i (keys %collection_info) {
1270             # required by $c ?
1271             if ($check_info{$c}->{$i}) {
1272                 $unpack_infos{$i} = 1;
1273             }
1274         }
1275     }
1276 }
1277
1278 # }}}
1279
1280 # {{{ determine which info is needed by the collection scripts
1281 for my $c (keys %unpack_infos) {
1282     for my $i (keys %collection_info) {
1283         # required by $c ?
1284         if ($collection_info{$c}->{$i}) {
1285             $unpack_infos{$i} = 1;
1286         }
1287     }
1288 }
1289 # }}}
1290
1291 # {{{ process all packages in the archive?
1292 if ($check_everything) {
1293     # make sure package info is available
1294     read_src_list("$MAEMIAN_LAB/info/source-packages", 0);
1295     read_bin_list("$MAEMIAN_LAB/info/binary-packages", 0);
1296     read_udeb_list("$MAEMIAN_LAB/info/udeb-packages", 0);
1297
1298     debug_msg(2, "pkg_mode = $pkg_mode");
1299
1300     if (($pkg_mode eq 'a') or ($pkg_mode eq 's')) {
1301         for my $arg (sort keys %source_info) {
1302             debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}");
1303             $schedule->add_file('s', "$MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}",
1304                                 %{$source_info{$arg}});
1305         }
1306     }
1307     if (($pkg_mode eq 'a') or ($pkg_mode eq 'b')) {
1308         for my $arg (sort keys %binary_info) {
1309             debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}");
1310             $schedule->add_file('b', "$MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}",
1311                                 %{$binary_info{$arg}});
1312         }
1313     }
1314     if (($pkg_mode eq 'a') or ($pkg_mode eq 'u')) {
1315         for my $arg (sort keys %udeb_info) {
1316             debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}");
1317             $schedule->add_file('u', "$MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}",
1318                                 %{$udeb_info{$arg}});
1319         }
1320     }
1321
1322     # package list still empty?
1323     unless ($schedule->count) {
1324         warning("no packages found in distribution directory");
1325     }
1326 } elsif ($packages_file) {      # process all packages listed in packages file?
1327     $schedule->add_pkg_list($packages_file);
1328 }
1329 # }}}
1330
1331 # {{{ Some silent exit
1332 unless ($schedule->count) {
1333     v_msg("No packages selected.");
1334     exit 0;
1335 }
1336 # }}}
1337
1338 # {{{ Okay, now really processing the packages in one huge loop
1339 $unpack_infos{ "override-file" } = 1 unless $no_override;
1340 v_msg(sprintf("Processing %d packages...", $schedule->count));
1341 debug_msg(1,
1342           "Selected action: $action",
1343           "Requested unpack level: $unpack_level",
1344           sprintf("Requested data to collect: %s", join(',',keys %unpack_infos)),
1345           sprintf("Selected checks: %s", join(',',keys %checks)),
1346     );
1347
1348 require Checker;
1349 require Maemian::Collect;
1350
1351 my %overrides;
1352 my @pending_jobs;
1353 PACKAGE:
1354 foreach my $pkg_info ($schedule->get_all) {
1355     my ($type, $pkg, $ver, $arch, $file) =
1356         @$pkg_info{qw(type package version architecture file)};
1357     my $long_type = ($type eq 'b' ? 'binary' :
1358                      ($type eq 's' ? 'source' : 'udeb' ));
1359
1360     Tags::set_pkg( $file, $pkg, $ver, $arch, $long_type );
1361
1362     # Kill pending jobs, if any
1363     Maemian::Command::kill(@pending_jobs);
1364     undef @pending_jobs;
1365
1366     # determine base directory
1367     my $base = "$MAEMIAN_LAB/$long_type/$pkg";
1368     unless ($base =~ m,^/,) {
1369         $base = "$cwd/$base";
1370     }
1371     debug_msg(1, "Base directory in lab: $base");
1372
1373     my $act_unpack_level = 0;
1374
1375     # unpacked package up-to-date?
1376     if (-d $base) {
1377         my $remove_basedir = 0;
1378
1379         # there's a base dir, so we assume that at least
1380         # one level of unpacking has been done
1381         $act_unpack_level = 1;
1382
1383         # maemian status file exists?
1384         unless (-f "$base/.maemian-status") {
1385             v_msg("No maemian status file found (removing old directory in lab)");
1386             $remove_basedir = 1;
1387             goto REMOVE_BASEDIR;
1388         }
1389
1390         # read unpack status -- catch any possible errors
1391         my $data;
1392         eval { ($data) = read_dpkg_control("$base/.maemian-status"); };
1393         if ($@) {               # error!
1394             v_msg($@);
1395             $remove_basedir = 1;
1396             goto REMOVE_BASEDIR;
1397         }
1398
1399         # compatible maemian version?
1400         if (not exists $data->{'lab-format'} or ($data->{'lab-format'} < $LAB_FORMAT)) {
1401             v_msg("Lab directory was created by incompatible maemian version");
1402             $remove_basedir = 1;
1403             goto REMOVE_BASEDIR;
1404         }
1405
1406         # version up to date?
1407         if (not exists $data->{'version'} or ($data->{'version'} ne $ver)) {
1408             debug_msg(1, "Removing package in lab (newer version exists) ...");
1409             $remove_basedir = 1;
1410             goto REMOVE_BASEDIR;
1411         }
1412
1413         # unpack level defined?
1414         unless (exists $data->{'unpack-level'}) {
1415             warning("cannot determine unpack-level of package");
1416             $remove_basedir = 1;
1417             goto REMOVE_BASEDIR;
1418         } else {
1419             $act_unpack_level = $data->{'unpack-level'};
1420         }
1421
1422         # file modified?
1423         my $timestamp;
1424         my @stat;
1425         unless (@stat = stat $file) {
1426             warning("cannot stat file $file: $!");
1427         } else {
1428             $timestamp = $stat[9];
1429         }
1430         if ((not defined $timestamp) or (not exists $data->{'timestamp'}) or ($data->{'timestamp'} != $timestamp)) {
1431             debug_msg(1, "Removing package in lab (package has been changed) ...");
1432             $remove_basedir = 1;
1433             goto REMOVE_BASEDIR;
1434         }
1435
1436     REMOVE_BASEDIR:
1437         if ($remove_basedir) {
1438             v_msg("Removing $pkg");
1439             unless (remove_pkg($base)) {
1440                 warning("skipping $action of $long_type package $pkg");
1441                 $exit_code = 2;
1442                 next PACKAGE;
1443             }
1444             $act_unpack_level = 0;
1445         }
1446     }
1447
1448     # unpack to requested unpack level
1449     $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,
1450                                    $unpack_level);
1451     if ($act_unpack_level == -1) {
1452         warning("could not unpack package to desired level",
1453                 "skipping $action of $long_type package $pkg");
1454         $exit_code = 2;
1455         next PACKAGE;
1456     }
1457
1458     if (($action eq 'unpack') or ($action eq 'check')) { # collect info
1459         my $current_order = -1;
1460         for my $coll (sort by_collection_order keys %unpack_infos) {
1461             my $ci = $collection_info{$coll};
1462             my %run_opts = ('description' => $coll);
1463
1464             # current type?
1465             next unless ($ci->{'type'} =~ m/$type/);
1466
1467             # If a file named .SCRIPT-VERSION already exists, we've already
1468             # collected this information and we can skip it.  Otherwise,
1469             # remove any .SCRIPT-* files (which are old version information).
1470             next if (-f "$base/.${coll}-$ci->{'version'}");
1471             opendir(BASE, $base)
1472                 or fail("cannot read directory $base: $!");
1473             for my $file (readdir BASE) {
1474                 if ($file =~ /^\.\Q$coll-/) {
1475                     unlink("$base/$file");
1476                 }
1477             }
1478             closedir(BASE);
1479
1480             # unpack to desired unpack level (if necessary)
1481             $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
1482             if ($act_unpack_level == -1) {
1483                 warning("could not unpack package to desired level",
1484                         "skipping $action of $long_type package $pkg");
1485                 $exit_code = 2;
1486                 next PACKAGE;
1487             }
1488
1489             # chdir to base directory
1490             unless (chdir($base)) {
1491                 warning("could not chdir into directory $base: $!",
1492                         "skipping $action of $long_type package $pkg");
1493                 $exit_code = 2;
1494                 next PACKAGE;
1495             }
1496
1497             $current_order = $ci->{'order'} if ($current_order == -1);
1498             if ($current_order != $ci->{'order'}) {
1499                 debug_msg(1, "Waiting for jobs from order $current_order ...");
1500                 unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
1501                     warning("skipping $action of $long_type package $pkg");
1502                     $exit_code = 2;
1503                     next PACKAGE;
1504                 }
1505                 undef @pending_jobs;
1506                 $current_order = $ci->{'order'};
1507             }
1508
1509             # collect info
1510             remove_status_file($base);
1511             debug_msg(1, "Collecting info: $coll ...");
1512             my $script = "$MAEMIAN_ROOT/collection/$ci->{'script'}";
1513             unless (spawn(\%run_opts, [ $script, $pkg, $long_type, '&' ])) {
1514                 warning("collect info $coll about package $pkg failed",
1515                         "skipping $action of $long_type package $pkg");
1516                 $exit_code = 2;
1517                 next PACKAGE;
1518             }
1519             push @pending_jobs, \%run_opts;
1520         }
1521
1522         # wait until all the jobs finish and skip this package if any of them
1523         # failed.
1524         debug_msg(1, "Waiting for jobs from order $current_order ...");
1525         unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
1526             warning("skipping $action of $long_type package $pkg");
1527             $exit_code = 2;
1528             next PACKAGE;
1529         }
1530         undef @pending_jobs;
1531     }
1532
1533     if ($action eq 'check') {   # read override file
1534
1535         unless ($no_override) {
1536             Tags::add_overrides("$base/override", $pkg, $long_type)
1537                 if (-f "$base/override")
1538         }
1539
1540         # perform checks
1541         my $info = Maemian::Collect->new($pkg, $long_type);
1542         for my $check (keys %checks) {
1543             my $ci = $check_info{$check};
1544
1545             # current type?
1546             next unless ($ci->{'type'} =~ m/$type/);
1547
1548             # unpack to desired unpack level (if necessary)
1549             $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
1550             if ($act_unpack_level == -1) {
1551                 warning("could not unpack package to desired level",
1552                         "skipping $action of $long_type package $pkg");
1553                 $exit_code = 2;
1554                 next PACKAGE;
1555             }
1556
1557             # chdir to base directory
1558             unless (chdir($base)) {
1559                 warning("could not chdir into directory $base: $!",
1560                         "skipping $action of $long_type package $pkg");
1561                 $exit_code = 2;
1562                 next PACKAGE;
1563             }
1564
1565             my $returnvalue = Checker::runcheck($pkg, $long_type, $info, $check);
1566             # Set exit_code correctly if there was not yet an exit code
1567             $exit_code = $returnvalue unless $exit_code;
1568
1569             if ($returnvalue == 2) {
1570                 warning("skipping $action of $long_type package $pkg");
1571                 next PACKAGE;
1572             }
1573
1574         }
1575         unless ($exit_code) {
1576             my $stats = Tags::get_stats( $file );
1577             if ($stats->{types}{E}) {
1578                 $exit_code = 1;
1579             } elsif ($fail_on_warnings && $stats->{types}{W}) {
1580                 $exit_code = 1;
1581             }
1582         }
1583
1584         # report unused overrides
1585         if (not $no_override) {
1586             my $overrides = Tags::get_overrides( $file );
1587
1588             for my $tag (sort keys %$overrides) {
1589                 my $taginfo = Tags::get_tag_info{$tag};
1590                 if (defined $taginfo) {
1591                     # Did we run the check script containing the tag?
1592                     next unless $checks{$taginfo->{'script'}};
1593
1594                     # If only checking specific tags, is this one of them?
1595                     next unless (scalar keys %Tags::only_issue_tags == 0)
1596                         or exists $Tags::only_issue_tags{$tag};
1597                 }
1598
1599                 for my $extra (sort keys %{$overrides->{$tag}}) {
1600                     next if $overrides->{$tag}{$extra};
1601
1602                     tag( "unused-override", $tag, $extra );
1603                 }
1604             }
1605         }
1606
1607         # Report override statistics.
1608         if (not $no_override and not $show_overrides) {
1609             my $stats = Tags::get_stats($file);
1610             my $short = $file;
1611             $short =~ s%.*/%%;
1612             my $errors = $stats->{overrides}{types}{E} || 0;
1613             my $warnings = $stats->{overrides}{types}{W} || 0;
1614             my $info = $stats->{overrides}{types}{I} || 0;
1615             $overrides{errors} += $errors;
1616             $overrides{warnings} += $warnings;
1617             $overrides{info} += $info;
1618         }
1619     }
1620
1621     # chdir to maemian root directory (to unlock $base so it can be removed below)
1622     unless (chdir($MAEMIAN_ROOT)) {
1623         warning("could not chdir into directory $MAEMIAN_ROOT: $!",
1624                 "skipping $action of $long_type package $pkg");
1625         $exit_code = 2;
1626         next PACKAGE;
1627     }
1628
1629     # clean up
1630     if ($act_unpack_level > $unpack_level) {
1631         $act_unpack_level = clean_pkg($type,$base,$file,$act_unpack_level,$unpack_level);
1632         if ($act_unpack_level == -1) {
1633             warning("could not clean up laboratory for package $pkg: $!",
1634                     "skipping clean up");
1635             $exit_code = 2;
1636             next PACKAGE;
1637         }
1638     }
1639
1640     # create Maemian status file
1641     if (($act_unpack_level > 0) and (not -f "$base/.maemian-status")) {
1642         my @stat;
1643         unless (@stat = stat $file) {
1644             warning("cannot stat file $file: $!",
1645                     "skipping creation of status file");
1646             $exit_code = 2;
1647             next PACKAGE;
1648         }
1649         my $timestamp = $stat[9];
1650
1651         unless (open(STATUS, '>', "$base/.maemian-status")) {
1652             warning("could not create status file $base/.maemian-status for package $pkg: $!");
1653             $exit_code = 2;
1654             next PACKAGE;
1655         }
1656
1657         print STATUS "Maemian-Version: $MAEMIAN_VERSION\n";
1658         print STATUS "Lab-Format: $LAB_FORMAT\n";
1659         print STATUS "Package: $pkg\n";
1660         print STATUS "Version: $ver\n";
1661         print STATUS "Type: $type\n";
1662         print STATUS "Unpack-Level: $act_unpack_level\n";
1663         print STATUS "Timestamp: $timestamp\n";
1664         close(STATUS);
1665     }
1666 }
1667 Tags::reset_pkg();
1668 if ($action eq 'check' and not $no_override and not $show_overrides) {
1669     my $errors = $overrides{errors} || 0;
1670     my $warnings = $overrides{warnings} || 0;
1671     my $info = $overrides{info} || 0;
1672     my $total = $errors + $warnings + $info;
1673     if ($total > 0) {
1674         my $total = ($total == 1)
1675             ? "$total tag overridden"
1676             : "$total tags overridden";
1677         my @output;
1678         if ($errors) {
1679             push (@output, ($errors == 1) ? "$errors error" : "$errors errors");
1680         }
1681         if ($warnings) {
1682             push (@output, ($warnings == 1) ? "$warnings warning" : "$warnings warnings");
1683         }
1684         if ($info) {
1685             push (@output, "$info info");
1686         }
1687         msg("$total (". join (', ', @output). ")");
1688     }
1689 }
1690
1691 # }}}
1692
1693 exit $exit_code;
1694
1695 # {{{ Some subroutines
1696
1697 sub unpack_pkg {
1698     my ($type,$base,$file,$cur_level,$new_level) = @_;
1699
1700     debug_msg(1, sprintf("Current unpack level is %d",$cur_level));
1701
1702     return $cur_level if $cur_level == $new_level;
1703
1704     # remove .maemian-status file
1705     remove_status_file($base);
1706
1707     if ( ($cur_level == 0) and (-d $base) ) {
1708        # We were lied to, there's something already there - clean it up first
1709        remove_pkg($base) or return -1;
1710     }
1711
1712     if ( ($new_level >= 1) and
1713          (not defined ($cur_level) or ($cur_level < 1)) ) {
1714         # create new directory
1715         debug_msg(1, "Unpacking package to level 1 ...");
1716         if (($type eq 'b') || ($type eq 'u')) {
1717             spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-binpkg-l1", $base, $file])
1718                 or return -1;
1719         } else {
1720             spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-srcpkg-l1", $base, $file])
1721                 or return -1;
1722         }
1723         $cur_level = 1;
1724     }
1725
1726     if ( ($new_level >= 2) and
1727          (not defined ($cur_level) or ($cur_level < 2)) ) {
1728         # unpack package contents
1729         debug_msg(1, "Unpacking package to level 2 ...");
1730         if (($type eq 'b') || ($type eq 'u')) {
1731             spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-binpkg-l2", $base])
1732                 or return -1;
1733         } else {
1734             debug_msg(1, "$MAEMIAN_ROOT/unpack/unpack-srcpkg-l2 $base");
1735             spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-srcpkg-l2", $base])
1736                 or return -1;
1737         }
1738         $cur_level = 2;
1739     }
1740
1741     return $cur_level;
1742 }
1743
1744 # Given a list of jobs corresponding to collect scripts, reap each of the
1745 # jobs.  For each successful job, record that it was successful by creating
1746 # the corresponding version marker file in the lab.  For each unsuccessful
1747 # job, warn that it was unsuccessful.
1748 #
1749 # Takes the current package, base directory, and the list of pending jobs.
1750 # Return true if all jobs were successful, false otherwise.
1751 sub reap_collect_jobs {
1752     my ($pkg, $base, @pending_jobs) = @_;
1753     my $status = reap(@pending_jobs);
1754     for my $job (@pending_jobs) {
1755         my $coll = $job->{'description'};
1756         if ($job->{success}) {
1757             my $ci = $collection_info{$coll};
1758             open(VERSION, '>', "$base/.${coll}-$ci->{'version'}")
1759                 or fail("cannot create $base/.${coll}-$ci->{'version'}: $!");
1760             print VERSION "Maemian-Version: $MAEMIAN_VERSION\n"
1761                 . "Timestamp: " . time . "\n";
1762             close(VERSION);
1763         } else {
1764             warning("collect info $coll about package $pkg failed");
1765         }
1766     }
1767     return $status;
1768 }
1769
1770 # TODO: is this the best way to clean dirs in perl?
1771 # no, look at File::Path module
1772 sub clean_pkg {
1773     my ($type,$base,$file,$cur_level,$new_level) = @_;
1774
1775     return $cur_level if $cur_level == $new_level;
1776
1777     if ($new_level < 1) {
1778         # remove base directory
1779         remove_pkg($base) or return -1;
1780         return 0;
1781     }
1782
1783     if ( ($new_level < 2) and defined ($cur_level) and ($cur_level >= 2) ) {
1784         # remove .maemian-status file
1785         remove_status_file($base);
1786
1787         # remove unpacked/ directory
1788         debug_msg(1, "Decreasing unpack level to 1 (removing files) ...");
1789         if ( -l "$base/unpacked" ) {
1790             delete_dir("$base/".readlink("$base/unpacked"))
1791                 or return -1;
1792             delete_dir("$base/unpacked") or return -1;
1793         } else {
1794             delete_dir("$base/unpacked") or return -1;
1795         }
1796
1797         $cur_level = 1;
1798     }
1799
1800     return $cur_level;
1801 }
1802
1803 # this function removes a package's base directory in the lab completely
1804 sub remove_pkg {
1805     my ($base) = @_;
1806
1807     debug_msg(1, "Removing package in lab ...");
1808     unless (delete_dir($base)) {
1809         warning("cannot remove directory $base: $!");
1810         return 0;
1811     }
1812
1813     return 1;
1814 }
1815
1816 sub remove_status_file {
1817     my ($base) = @_;
1818
1819     # status file exists?
1820     if (not -e "$base/.maemian-status") {
1821         return 1;
1822     }
1823
1824     if (not unlink("$base/.maemian-status")) {
1825         warning("cannot remove status file $base/.maemian-status: $!");
1826         return 0;
1827     }
1828
1829     return 1;
1830 }
1831
1832 # get package name, version, and file name from the lab
1833 sub get_bin_info_from_lab {
1834     my ($base_dir) = @_;
1835     my ($pkg,$ver,$arch,$file);
1836
1837     ($pkg = read_file("$base_dir/fields/package"))
1838         or fail("cannot read file $base_dir/fields/package: $!");
1839
1840     ($ver = read_file("$base_dir/fields/version"))
1841         or fail("cannot read file $base_dir/fields/version: $!");
1842
1843     ($arch = read_file("$base_dir/fields/architecture"))
1844         or fail("cannot read file $base_dir/fields/architecture: $!");
1845
1846     ($file = readlink("$base_dir/deb"))
1847         or fail("cannot read link $base_dir/deb: $!");
1848
1849     return ($file, package => $pkg, version => $ver, architecture => $arch);
1850 }
1851
1852 # get package name, version, and file name from the lab
1853 sub get_src_info_from_lab {
1854     my ($base_dir) = @_;
1855     my ($pkg,$ver,$file);
1856
1857     ($pkg = read_file("$base_dir/fields/source"))
1858         or fail("cannot read file $base_dir/fields/source: $!");
1859
1860     ($ver = read_file("$base_dir/fields/version"))
1861         or fail("cannot read file $base_dir/fields/version: $!");
1862
1863     ($file = readlink("$base_dir/dsc"))
1864         or fail("cannot read link $base_dir/dsc: $!");
1865
1866     return ($file, source => $pkg, version => $ver);
1867 }
1868
1869 # read first line of a file
1870 sub read_file {
1871     my $first_line;
1872
1873     open(T, '<', $_[0]) or return;
1874     chop($first_line = <T>);
1875     close(T) or return;
1876
1877     return $first_line;
1878 }
1879
1880 # sort collection list by `order'
1881 sub by_collection_order {
1882     $collection_info{$a}->{'order'} <=> $collection_info{$b}->{'order'};
1883 }
1884
1885 sub END {
1886     # Prevent Lab::delete from affecting the exit code.
1887     local $?;
1888
1889     $SIG{'INT'} = 'DEFAULT';
1890     $SIG{'QUIT'} = 'DEFAULT';
1891
1892     $LAB->delete() if $LAB and not $keep_lab;
1893 }
1894
1895 sub interrupted {
1896     $SIG{$_[0]} = 'DEFAULT';
1897     die "N: Interrupted.\n";
1898 }
1899
1900 1;
1901 __END__