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