vcs.maemo.org Git - maemian/blob - nokia-lintian/frontend/lintian

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