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