3 # Maemian -- Maemo package checker
4 # Copyright (C) Jeremiah C. Foster 2009, based on:
6 # Maemian -- Debian package checker
7 # Copyright (C) 1998 Christian Schwarz and Richard Braakman
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
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.
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,
27 maemian - Maemo package checker
31 Maemian is the maemo version of maemian - a policy checker designed to
32 assure the quality of a package uploaded into the maemo.org repositories.
33 The goal of maemian is to improve quality by checking that the maemo
34 packaging policy is followed. In order to do that it reads files in the
35 uploaded deb. Currently maemian only looks at the .dsc file and tries to
36 ascertain who uploaded it, and if they used the correct email address.
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
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
59 my $check_everything = 0; #flag for -a|--all switch
60 my $maemian_info = 0; #flag for -i|--info switch
61 our $display_experimentaltags = 0; #flag for -E|--display-experimental switch
62 our $display_pedantictags = 0; #flag for --pedantic switch
63 my $unpack_level = undef; #flag for -l|--unpack-level switch
64 our $no_override = 0; #flag for -o|--no-override switch
65 our $show_overrides = 0; #flag for --show-overrides switch
66 my $color = 'never'; #flag for --color switch
67 my $check_checksums = 0; #flag for -m|--md5sums|--checksums switch
68 my $allow_root = 0; #flag for --allow-root switch
69 my $fail_on_warnings = 0; #flag for --fail-on-warnings switch
70 my $keep_lab = 0; #flag for --keep-lab switch
71 my $packages_file = 0; #string for the -p option
72 our $OPT_MAEMIAN_LAB = ""; #string for the --lab option
73 our $OPT_MAEMIAN_ARCHIVEDIR = "";#string for the --archivedir option
74 our $OPT_MAEMIAN_DIST = ""; #string for the --dist option
75 our $OPT_MAEMIAN_ARCH = ""; #string for the --arch option
76 our $OPT_MAEMIAN_AREA = ""; #string for the --area option
77 # These options can also be used via default or environment variables
78 our $MAEMIAN_CFG = ""; #config file to use
79 our $MAEMIAN_ROOT = "/home/jeremiah/maemian/"; #location of the maemian modules
80 our $OPT_MAEMIAN_SECTION = ""; #old name for OPT_MAEMIAN_ARCH
82 my $experimental_output_opts = undef;
84 my @severities = qw(wishlist minor normal important serious);
85 my @certainties = qw(wild-guess possible certain);
86 my %display_level = ();
87 my %display_source = ();
102 my %already_scheduled;
108 # reset configuration variables
109 our $MAEMIAN_LAB = undef;
110 our $MAEMIAN_ARCHIVEDIR = undef;
111 our $MAEMIAN_DIST = undef;
112 our $MAEMIAN_UNPACK_LEVEL = undef;
113 our $MAEMIAN_ARCH = undef;
114 our $MAEMIAN_SECTION = undef;
115 our $MAEMIAN_AREA = undef;
120 #turn off file buffering
123 # reset locale definition (necessary for tar)
124 $ENV{'LC_ALL'} = 'C';
125 # reset timezone definition (also for tar)
130 # {{{ Process Command Line
132 #######################################
133 # Subroutines called by various options
134 # in the options hash below. These are
135 # invoked to process the commandline
137 #######################################
138 # Display Command Syntax
142 print <<"EOT-EOT-EOT";
143 Syntax: maemian [action] [options] [--] [packages] ...
145 -S, --setup-lab set up static lab
146 -R, --remove-lab remove static lab
147 -c, --check check packages (default action)
148 -C X, --check-part X check only certain aspects
149 -X X, --dont-check-part X don\'t check certain aspects
150 -T X, --tags X only run checks needed for requested tags
151 --tags-from-file X like --tags, but read list from file
152 -u, --unpack only unpack packages in the lab
153 -r, --remove remove package from the lab
155 -h, --help display short help text
156 -v, --verbose verbose messages
157 -V, --version display Maemian version and exit
158 --print-version print unadorned version number and exit
159 -d, --debug turn Maemian\'s debug messages ON
160 -q, --quiet suppress all informational messages
162 -i, --info give detailed info about tags
163 -I, --display-info display "I:" tags (normally suppressed)
164 -E, --display-experimental display "X:" tags (normally suppressed)
165 --pedantic display "P:" tags (normally suppressed)
166 -L, --display-level display tags with the specified level
167 --display-source X restrict displayed tags by source
168 -l X, --unpack-level X set default unpack level to X
169 -o, --no-override ignore overrides
170 --show-overrides output tags that have been overriden
171 --color never/always/auto disable, enable, or enable color for TTY
172 -U X, --unpack-info X specify which info should be collected
173 -m, --md5sums, --checksums check checksums when processing a .changes file
174 --allow-root suppress maemian\'s warning when run as root
175 --fail-on-warnings return a non-zero exit status if warnings found
176 --keep-lab keep lab after run, even if temporary
177 Configuration options:
178 --cfg CONFIGFILE read CONFIGFILE for configuration
179 --lab LABDIR use LABDIR as permanent laboratory
180 --archivedir ARCHIVEDIR location of Debian archive to scan for packages
181 --dist DIST scan packages in this distribution (e.g. sid)
182 --area AREA scan packages in this archive area (e.g. main)
183 --arch ARCH scan packages with architecture ARCH
184 --root ROOTDIR use ROOTDIR instead of /usr/share/maemian
185 Package selection options:
186 -a, --all process all packages in distribution
187 -b, --binary process only binary packages
188 -s, --source process only source packages
189 --udeb process only udeb packages
190 -p X, --packages-file X process all files in file (special syntax!)
196 # Display Version Banner
197 # Options: -V|--version, --print-version
199 if ($_[0] eq 'print-version') {
200 print "$MAEMIAN_VERSION\n";
207 # Record action requested
208 # Options: -S, -R, -c, -u, -r
211 die("too many actions specified: $_[0]");
216 # Record Parts requested for checking
217 # Options: -C|--check-part
218 sub record_check_part {
219 if (defined $action and $action eq 'check' and $checks) {
220 die("multiple -C or --check-part options not allowed");
223 die("both -C or --check-part and -X or --dont-check-part options not allowed");
226 die("too many actions specified: $_[0]");
232 # Record Parts requested for checking
234 sub record_check_tags {
235 if (defined $action and $action eq 'check' and $check_tags) {
236 die("multiple -T or --tags options not allowed");
239 die("both -T or --tags and -C or --check-part options not allowed");
242 die("both -T or --tags and -X or --dont-check-part options not allowed");
245 die("too many actions specified: $_[0]");
248 $check_tags = "$_[1]";
251 # Record Parts requested for checking
252 # Options: --tags-from-file
253 sub record_check_tags_from_file {
254 open my $file, '<', $_[1]
255 or fail("failed to open $_[1]: $!");
256 my $tags = join(',', map { chomp($_); $_ } <$file>);
259 record_check_tags($_[0], $tags);
263 # Record Parts requested not to check
264 # Options: -X|--dont-check-part X
265 sub record_dont_check_part {
266 if (defined $action and $action eq 'check' and $dont_check) {
267 die("multiple -X or --dont-check-part options not allowed");
270 die("both -C or --check-part and -X or --dont-check-part options not allowed");
273 die("too many actions specified: $_[0]");
276 $dont_check = "$_[1]";
280 # Process for -U|--unpack-info flag
281 sub record_unpack_info {
283 die("multiple -U or --unpack-info options not allowed");
285 $unpack_info = "$_[1]";
288 # Record what type of data is specified
289 # Options: -b|--binary, -s|--source, --udeb
291 $pkg_mode = 'b' if $_[0] eq 'binary';
292 $pkg_mode = 's' if $_[0] eq 'source';
293 $pkg_mode = 'u' if $_[0] eq 'udeb';
296 # Process -L|--display-level flag
297 sub record_display_level {
299 if ($level =~ m/^\+(.+)/) {
300 set_display_level($1, 1);
301 } elsif ($level =~ m/^\-(.+)/) {
302 set_display_level($1, 0);
303 } elsif ($level =~ m/^\=?(.+)/) {
304 reset_display_level();
305 set_display_level($1, 1);
307 die "invalid argument to --display-level: $level\n";
311 # Process -I|--display-info flag
312 sub display_infotags {
313 foreach my $s (@severities) {
314 set_display_level($s, 1);
318 # Process --display-source flag
319 sub record_display_source {
320 $display_source{$_[1]} = 1;
323 # Clears current display level information, disabling all severities and
325 sub reset_display_level {
326 foreach my $s (@severities) {
327 foreach my $c (@certainties) {
328 $display_level{$s}{$c} = 0;
333 sub set_display_level_multi {
334 my ($op, $level, $val) = @_;
336 my @inc_severities = @severities;
337 my @inc_certainties = @certainties;
338 my $inc_border = ($op =~ /^[<>]=$/) ? 1 : 0;
340 @inc_severities = reverse @inc_severities;
341 @inc_certainties = reverse @inc_certainties;
343 my $severity = join("|", @severities);
344 my $certainty = join("|", @certainties);
345 if ($level =~ m/^($severity)$/) {
346 foreach my $s (cut_list($level, $inc_border, @inc_severities)) {
347 map { $display_level{$s}{$_} = $val } @certainties;
349 } elsif ($level =~ m/^($certainty)$/) {
350 foreach my $c (cut_list($level, $inc_border, @inc_certainties)) {
351 map { $display_level{$_}{$c} = $val } @severities;
353 } elsif ($level =~ m/^($severity)\/($certainty)$/) {
354 foreach my $s (cut_list($1, $inc_border, @inc_severities)) {
355 foreach my $c (cut_list($2, $inc_border, @inc_certainties)) {
356 $display_level{$s}{$c} = $val;
360 die "invalid argument to --display-level: $level\n";
366 my ($border, $inc_border, @list) = @_;
368 my (@newlist, $found);
371 push @newlist, $_ if $inc_border;
378 die "internal error: cut_list did not find border $border\n"
380 if (!$inc_border and !@newlist
381 and $border eq $list[0]) {
382 warn "warning: display level $border specified with > (or <) is empty set, assuming >= (or <=)\n";
383 push @newlist, $list[0];
389 # Parse input display level to enable (val 1) or disable (val 0) it
391 sub set_display_level {
392 my ($level, $val) = @_;
393 if ($level =~ m/^([<>]=?)(.+)/) {
394 set_display_level_multi($1, $2, $val);
398 my $severity = join("|", @severities);
399 my $certainty = join("|", @certainties);
400 if ($level =~ m/^($severity)$/) {
401 map { $display_level{$1}{$_} = $val } @certainties;
402 } elsif ($level =~ m/^($certainty)$/) {
403 map { $display_level{$_}{$1} = $val } @severities;
404 } elsif ($level =~ m/^($severity)\/($certainty)$/) {
405 $display_level{$1}{$2} = $val;
407 die "invalid argument to --display-level: $level\n";
411 # Hash used to process commandline options
413 # ------------------ actions
414 "setup-lab|S" => \&record_action,
415 "remove-lab|R" => \&record_action,
416 "check|c" => \&record_action,
417 "check-part|C=s" => \&record_check_part,
418 "tags|T=s" => \&record_check_tags,
419 "tags-from-file=s" => \&record_check_tags_from_file,
420 "dont-check-part|X=s" => \&record_dont_check_part,
421 "unpack|u" => \&record_action,
422 "remove|r" => \&record_action,
424 # ------------------ general options
425 "help|h" => \&syntax,
426 "version|V" => \&banner,
427 "print-version" => \&banner,
429 "verbose|v" => \$verbose,
430 "debug|d" => \@debug, # Count the -d flags
431 "quiet|q" => \$quiet,
433 # ------------------ behaviour options
434 "info|i" => \$maemian_info,
435 "display-info|I" => \&display_infotags,
436 "display-experimental|E" => \$display_experimentaltags,
437 "pedantic" => \$display_pedantictags,
438 "display-level|L=s" => \&record_display_level,
439 "display-source=s" => \&record_display_source,
440 "unpack-level|l=i" => \$unpack_level,
441 "no-override|o" => \$no_override,
442 "show-overrides" => \$show_overrides,
443 "color=s" => \$color,
444 "unpack-info|U=s" => \&record_unpack_info,
445 "checksums|md5sums|m" => \$check_checksums,
446 "allow-root" => \$allow_root,
447 "fail-on-warnings" => \$fail_on_warnings,
448 "keep-lab" => \$keep_lab,
449 # Note: Ubuntu has (and other derivatives might gain) a
450 # -D/--debian option to make maemian behave like in Debian, that
451 # is, to revert distribution-specific changes
453 # ------------------ configuration options
454 "cfg=s" => \$MAEMIAN_CFG,
455 "lab=s" => \$OPT_MAEMIAN_LAB,
456 "archivedir=s" => \$OPT_MAEMIAN_ARCHIVEDIR,
457 "dist=s" => \$OPT_MAEMIAN_DIST,
458 "area=s" => \$OPT_MAEMIAN_AREA,
459 "section=s" => \$OPT_MAEMIAN_AREA,
460 "arch=s" => \$OPT_MAEMIAN_ARCH,
461 "root=s" => \$MAEMIAN_ROOT,
463 # ------------------ package selection options
464 "all|a" => \$check_everything,
465 "binary|b" => \&record_pkgmode,
466 "source|s" => \&record_pkgmode,
467 "udeb" => \&record_pkgmode,
468 "packages-file|p=s" => \$packages_file,
470 # ------------------ experimental
471 "exp-output:s" => \$experimental_output_opts,
474 # init display level settings
475 reset_display_level();
476 set_display_level_multi('>=', 'important', 1);
477 set_display_level_multi('>=', 'normal/possible', 1);
478 set_display_level('minor/certain', 1);
480 # init commandline parser
481 Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev');
483 # process commandline options
485 or die("error parsing options\n");
487 # determine current working directory--we'll need this later
490 # determine MAEMIAN_ROOT if it was not set with --root.
491 $MAEMIAN_ROOT = $MAEMIAN_ROOT || $ENV{'MAEMIAN_ROOT'};
492 if (defined $MAEMIAN_ROOT) {
493 unless ($MAEMIAN_ROOT =~ m,^/,) {
494 $MAEMIAN_ROOT = "$cwd/$MAEMIAN_ROOT";
497 $MAEMIAN_ROOT = '/usr/share/maemian';
500 # keep-lab implies unpack-level=2 unless explicetly
502 if ($keep_lab and not defined $unpack_level) {
506 # option --all and packages specified at the same time?
507 if (($check_everything or $packages_file) and $#ARGV+1 > 0) {
508 print STDERR "warning: options -a or -p can't be mixed with package parameters!\n";
509 print STDERR "(will ignore -a or -p option)\n";
510 undef $check_everything;
511 undef $packages_file;
514 # check permitted values for --color
515 if ($color and $color !~ /^(never|always|auto|html)$/) {
516 die "invalid argument to --color: $color\n";
519 # check specified action
520 $action = 'check' unless $action;
522 # check for arguments
523 if ($action =~ /^(check|unpack|remove)$/ and $#ARGV == -1 and not $check_everything and not $packages_file) {
529 # {{{ Setup Configuration
532 # check if effective UID is 0
533 if ($> == 0 and not $allow_root) {
534 print STDERR "warning: maemian's authors do not recommend running it with root privileges!\n";
537 # search for configuration file if it was not set with --cfg
538 # do not search the default locations if it was set.
540 } elsif (exists $ENV{'MAEMIAN_CFG'} &&
541 -f ($MAEMIAN_CFG = $ENV{'MAEMIAN_CFG'})) {
542 } elsif (-f ($MAEMIAN_CFG = $MAEMIAN_ROOT . '/maemianrc')) {
543 } elsif (exists $ENV{'HOME'} &&
544 -f ($MAEMIAN_CFG = $ENV{'HOME'} . '/.maemianrc')) {
545 } elsif (-f ($MAEMIAN_CFG = '/etc/maemianrc')) {
550 use constant VARS => qw(LAB ARCHIVEDIR DIST UNPACK_LEVEL SECTION AREA ARCH);
551 # read configuration file
553 open(CFG, '<', $MAEMIAN_CFG)
554 or die("cannot open configuration file $MAEMIAN_CFG for reading: $!");
561 # substitute some special variables
562 s,\$HOME/,$ENV{'HOME'}/,go;
563 s,\~/,$ENV{'HOME'}/,go;
566 foreach my $var (VARS) {
568 $var = "MAEMIAN_$var";
569 if (m/^\s*$var\s*=\s*(.*\S)\s*$/i) {
576 die "syntax error in configuration file: $_\n";
582 # environment variables overwrite settings in conf file:
585 my $var = "MAEMIAN_$_";
586 my $opt_var = "OPT_$var";
587 $$var = $ENV{$var} if $ENV{$var};
588 $$var = $$opt_var if $$opt_var;
591 # MAEMIAN_ARCH must have a value.
592 unless (defined $MAEMIAN_ARCH) {
594 chop($MAEMIAN_ARCH=`dpkg --print-architecture`);
596 $MAEMIAN_ARCH = 'any';
600 # MAEMIAN_SECTION is deprecated in favour of MAEMIAN_AREA
601 if (defined $MAEMIAN_SECTION) {
602 print STDERR "warning: MAEMIAN_SECTION has been deprecated in favour of MAEMIAN_AREA.\n";
603 if (defined $MAEMIAN_AREA) {
604 print STDERR "Using MAEMIAN_AREA as both were defined.\n";
606 print STDERR "Both are currently accepted, but MAEMIAN_SECTION may be removed\n";
607 print STDERR "in a future Maemian release.\n";
608 $MAEMIAN_AREA = $MAEMIAN_SECTION;
612 # determine requested unpack level
613 if (defined($unpack_level)) {
614 # specified through command line
615 } elsif (defined($MAEMIAN_UNPACK_LEVEL)) {
616 # specified via configuration file or env variable
617 $unpack_level = $MAEMIAN_UNPACK_LEVEL;
619 # determine by action
620 if (($action eq 'unpack') or ($action eq 'check')) {
626 unless (($unpack_level == 0) or ($unpack_level == 1) or ($unpack_level == 2)) {
627 die("bad unpack level $unpack_level specified");
630 $MAEMIAN_UNPACK_LEVEL = $unpack_level;
632 # export current settings for our helper scripts
633 foreach (('ROOT', 'CFG', VARS)) {
635 my $var = "MAEMIAN_$_";
644 my $debug = $#debug + 1;
645 $verbose = 1 if $debug;
646 $ENV{'MAEMIAN_DEBUG'} = $debug;
648 # Loading maeian's own libraries (now that MAEMIAN_ROOT is known)
649 unshift @INC, "$MAEMIAN_ROOT/lib";
654 require Read_pkglists;
661 require Maemian::Data;
662 require Maemian::Schedule;
663 require Maemian::Output;
664 import Maemian::Output qw(:messages);
665 require Maemian::Command;
666 import Maemian::Command qw(spawn reap);
667 require Maemian::Check;
668 import Maemian::Check qw(check_maintainer);
671 if (defined $experimental_output_opts) {
672 my %opts = map { split(/=/) } split( /,/, $experimental_output_opts );
673 foreach (keys %opts) {
674 if ($_ eq 'format') {
675 if ($opts{$_} eq 'colons') {
676 require Maemian::Output::ColonSeparated;
677 $Maemian::Output::GLOBAL = new Maemian::Output::ColonSeparated;
678 } elsif ($opts{$_} eq 'letterqualifier') {
679 require Maemian::Output::LetterQualifier;
680 $Maemian::Output::GLOBAL = new Maemian::Output::LetterQualifier;
681 } elsif ($opts{$_} eq 'xml') {
682 require Maemian::Output::XML;
683 $Maemian::Output::GLOBAL = new Maemian::Output::XML;
687 ${"Tags::$_"} = $opts{$_};
691 $Maemian::Output::GLOBAL->verbose($verbose);
692 $Maemian::Output::GLOBAL->debug($debug);
693 $Maemian::Output::GLOBAL->quiet($quiet);
694 $Maemian::Output::GLOBAL->color($color);
695 $Maemian::Output::GLOBAL->showdescription($maemian_info);
697 # Print Debug banner, now that we're finished determining
698 # the values and have Maemian::Output available
701 "Maemian root directory: $MAEMIAN_ROOT",
702 "Configuration file: $MAEMIAN_CFG",
703 "Laboratory: $MAEMIAN_LAB",
704 "Archive directory: $MAEMIAN_ARCHIVEDIR",
705 "Distribution: $MAEMIAN_DIST",
706 "Default unpack level: $MAEMIAN_UNPACK_LEVEL",
707 "Architecture: $MAEMIAN_ARCH",
711 my @l_secs = read_dpkg_control("$MAEMIAN_ROOT/checks/maemian.desc");
713 map { $_->{'script'} = 'maemian'; Tags::add_tag($_) } @l_secs;
715 $Tags::show_experimental = $display_experimentaltags;
716 $Tags::show_pedantic = $display_pedantictags;
717 $Tags::show_overrides = $show_overrides;
718 %Tags::display_level = %display_level;
719 %Tags::display_source = %display_source;
720 %Tags::only_issue_tags = map { $_ => 1 } (split(/,/, $check_tags))
722 if defined $check_tags;
724 use vars qw(%source_info %binary_info %udeb_info); # from the above
726 # Set up clean-up handlers.
727 undef $cleanup_filename;
728 $SIG{'INT'} = \&interrupted;
729 $SIG{'QUIT'} = \&interrupted;
733 # {{{ Create/Maintain Lab and add any specified Debian Archives (*.debs)
735 $LAB = new Lab( $MAEMIAN_LAB, $MAEMIAN_DIST );
737 #######################################
739 if ($action eq 'setup-lab') {
740 if ($#ARGV+1 > 0) { # Cannot define Lab on the command line.
741 warning("ignoring additional command line arguments");
745 or fail("There was an error while setting up the static lab.");
749 #######################################
751 } elsif ($action eq 'remove-lab') {
753 warning("ignoring additional command line arguments");
756 $LAB->delete_static()
757 or fail("There was an error while removing the static lab.");
761 #######################################
762 # Check for non deb specific actions
763 } elsif (not (($action eq 'unpack') or ($action eq 'check')
764 or ($action eq 'remove'))) {
765 fail("bad action $action specified");
769 fail("maemian lab has not been set up correctly (perhaps you forgot to run maemian --setup-lab?)")
770 unless $LAB->is_lab();
772 #XXX: There has to be a cleaner way to do this
773 $MAEMIAN_LAB = $LAB->{dir};
777 # {{{ Compile list of files to process
779 $schedule = new Maemian::Schedule(verbose => $verbose);
780 # process package/file arguments
781 while (my $arg = shift) {
784 # $arg contains absolute dir spec?
785 unless ($arg =~ m,^/,) {
790 if ($arg =~ /\.deb$/) {
791 $schedule->add_deb('b', $arg)
792 or warning("$arg is a zero-byte file, skipping");
795 elsif ($arg =~ /\.udeb$/) {
796 $schedule->add_deb('u', $arg)
797 or warning("$arg is a zero-byte file, skipping");
800 elsif ($arg =~ /\.dsc$/) {
801 $schedule->add_dsc($arg)
802 or warning("$arg is a zero-byte file, skipping");
805 elsif ($arg =~ /\.changes$/) {
806 # get directory and filename part of $arg
807 my ($arg_dir, $arg_name) = $arg =~ m,(.*)/([^/]+)$,;
809 v_msg("Processing changes file $arg_name ...");
811 my ($data) = read_dpkg_control($arg);
812 if (not defined $data) {
813 warning("$arg is a zero-byte file, skipping");
816 Tags::set_pkg( $arg, $arg_name, "", "", 'binary' );
818 # If we don't have a Format key, something went seriously wrong.
819 # Tag the file and skip remaining processing.
820 if (!$data->{'format'}) {
821 tag('malformed-changes-file');
825 # Description is mandated by dak, but only makes sense if binary
826 # packages are included. Don't tag pure source uploads.
827 if (!$data->{'description'} && $data->{'architecture'} ne 'source') {
828 tag("no-description-in-changes-file");
831 # check distribution field
832 if (defined $data->{distribution}) {
833 my $ubuntu_dists = Maemian::Data->new ('changelog-file/ubuntu-dists');
834 my $ubuntu_regex = join('|', $ubuntu_dists->all);
835 my @distributions = split /\s+/o, $data->{distribution};
836 for my $distribution (@distributions) {
837 if ($distribution eq 'UNRELEASED') {
839 } elsif ($data->{version} =~ /ubuntu|$ubuntu_regex/
840 or $distribution =~ /$ubuntu_regex/) {
841 if ($distribution !~ /^($ubuntu_regex)(-(proposed|updates|backports|security))?$/ ) {
842 tag("bad-ubuntu-distribution-in-changes-file",
845 } elsif (! (($distribution eq 'oldstable')
846 or ($distribution eq 'stable')
847 or ($distribution eq 'testing')
848 or ($distribution eq 'unstable')
849 or ($distribution eq 'experimental')
850 or ($distribution =~ /^\w+-backports$/)
851 or ($distribution =~ /^\w+-proposed-updates$/)
852 or ($distribution =~ /^\w+-security$/))
854 # bad distribution entry
855 tag("bad-distribution-in-changes-file",
860 if ($#distributions > 0) {
861 # Currently disabled until dak stops accepting the syntax
862 # tag("multiple-distributions-in-changes-file",
863 # $data->{'distribution'});
867 # Urgency is only recommended by Policy.
868 if (!$data->{'urgency'}) {
869 tag("no-urgency-in-changes-file");
871 my $urgency = lc $data->{'urgency'};
873 unless ($urgency =~ /^(low|medium|high|critical|emergency)$/i) {
874 tag("bad-urgency-in-changes-file", $data->{'urgency'});
878 # Changed-By is optional in Policy, but if set, must be
879 # syntactically correct. It's also used by dak.
880 if ($data->{'changed-by'}) {
881 check_maintainer($data->{'changed-by'}, 'changed-by');
884 # process all listed `files:'
887 my $file_list = $data->{files} || '';
888 for ( split /\n/, $file_list ) {
893 my ($md5sum,$size,$section,$priority,$file) = split(/\s+/o, $_);
894 $files{$file}{md5} = $md5sum;
895 $files{$file}{size} = $size;
898 if (($section eq 'non-free') or ($section eq 'contrib')) {
899 tag( "bad-section-in-changes-file", $file, $section );
904 foreach my $alg (qw(sha1 sha256)) {
905 my $list = $data->{"checksums-$alg"} || '';
906 for ( split /\n/, $list ) {
911 my ($checksum,$size,$file) = split(/\s+/o, $_);
912 $files{$file}{$alg} = $checksum;
913 if ($files{$file}{size} != $size) {
914 tag( "file-size-mismatch-in-changes-file", $file,
915 "$files{$file}{size} != $size" );
921 foreach my $file (keys %files) {
922 my $filename = $arg_dir . '/' . $file;
925 if (not -f $filename) {
926 warning("$file does not exist, exiting");
930 if ($size ne $files{$file}{size}) {
931 tag( "file-size-mismatch-in-changes-file", $file,
932 "$files{$file}{size} != $size");
936 if ($check_checksums or $file =~ /\.dsc$/) {
937 foreach my $alg (qw(md5 sha1 sha256)) {
938 next unless exists $files{$file}{$alg};
940 my $real_checksum = get_file_checksum($alg, $filename);
942 if ($real_checksum ne $files{$file}{$alg}) {
943 tag( "checksum-mismatch-in-changes-file", $alg, $file );
949 if ($file =~ /\.dsc$/) {
950 $schedule->add_dsc($filename);
951 } elsif ($file =~ /\.deb$/) {
952 $schedule->add_deb('b', $filename);
953 } elsif ($file =~ /\.udeb$/) {
954 $schedule->add_deb('u', $filename);
958 unless ($exit_code) {
959 my $stats = Tags::get_stats( $arg );
960 if ($stats->{types}{E}) {
962 } elsif ($fail_on_warnings && $stats->{types}{W}) {
968 fail("bad package file name $arg (neither .deb, .udeb or .dsc file)");
971 # parameter is a package name--so look it up
972 # search the distribution first, then the lab
973 # special case: search only in lab if action is `remove'
976 if ($action eq 'remove') {
977 # search only in lab--see below
980 # search in dist, then in lab
981 $search = 'dist or lab';
986 read_src_list("$MAEMIAN_LAB/info/source-packages", 0);
987 read_bin_list("$MAEMIAN_LAB/info/binary-packages", 0);
988 read_udeb_list("$MAEMIAN_LAB/info/udeb-packages", 0);
990 if (($pkg_mode eq 'b') or ($pkg_mode eq 'a')) {
991 if ($binary_info{$arg}) {
992 $schedule->add_file('b', "$MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}",
993 %{$binary_info{$arg}});
997 if (($pkg_mode eq 'u') or ($pkg_mode eq 'a')) {
998 if ($udeb_info{$arg}) {
999 $schedule->add_file('u', "$MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}",
1000 %{$udeb_info{$arg}});
1004 if (($pkg_mode eq 's') or ($pkg_mode eq 'a')) {
1005 if ($source_info{$arg}) {
1006 $schedule->add_file('s', "$MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}",
1007 %{$source_info{$arg}});
1015 # nothing found so far, so search the lab
1017 my $b = "$MAEMIAN_LAB/binary/$arg";
1018 my $s = "$MAEMIAN_LAB/source/$arg";
1019 my $u = "$MAEMIAN_LAB/udeb/$arg";
1021 if ($pkg_mode eq 'b') {
1023 warn "error: cannot find binary package $arg in $search (skipping)\n";
1027 } elsif ($pkg_mode eq 's') {
1029 warning("cannot find source package $arg in $search (skipping)");
1033 } elsif ($pkg_mode eq 'u') {
1035 warning("cannot find udeb package $arg in $search (skipping)");
1041 unless (-d $b or -d $s or -d $u) {
1042 warning("cannot find binary, udeb or source package $arg in $search (skipping)");
1048 if (($pkg_mode eq 'b') or (($pkg_mode eq 'a') and (-d $b))) {
1049 $schedule->add_file('b', get_bin_info_from_lab($b));
1051 if (($pkg_mode eq 's') or (($pkg_mode eq 'a') and (-d $s))) {
1052 $schedule->add_file('s', get_src_info_from_lab($s));
1054 if (($pkg_mode eq 'u') or (($pkg_mode eq 'a') and (-d $u))) {
1055 $schedule->add_file('u', get_bin_info_from_lab($u));
1060 if (not $check_everything and not $packages_file and not $schedule->count) {
1061 v_msg("No packages selected.");
1066 # {{{ A lone subroutine
1067 #----------------------------------------------------------------------------
1068 # Check to make sure there are packages to check.
1070 my ($f,$target,$field,$source,$required) = @_;
1071 if ($required and not $source->{$field}) {
1072 fail("description file $f does not define required tag $field");
1074 $target->{$field} = $source->{$field};
1075 delete $source->{$field};
1079 # {{{ Load information about collector scripts
1080 opendir(COLLDIR, "$MAEMIAN_ROOT/collection")
1081 or fail("cannot read directory $MAEMIAN_ROOT/collection");
1083 for my $f (readdir COLLDIR) {
1084 next if $f =~ /^\./;
1085 next unless $f =~ /\.desc$/;
1087 debug_msg(2, "Reading collector description file $f ...");
1088 my @secs = read_dpkg_control("$MAEMIAN_ROOT/collection/$f");
1091 or fail("syntax error in description file $f: too many sections");
1093 ($script = $secs[0]->{'collector-script'})
1094 or fail("error in description file $f: `Collector-Script:' not defined");
1096 delete $secs[0]->{'collector-script'};
1097 $collection_info{$script}->{'script'} = $script;
1098 my $p = $collection_info{$script};
1100 set_value($f, $p,'type',$secs[0],1);
1102 my ($b,$s,$u) = ( "", "", "" );;
1103 for (split(/\s*,\s*/o,$p->{'type'})) {
1104 if ($_ eq 'binary') {
1106 } elsif ($_ eq 'source') {
1108 } elsif ($_ eq 'udeb') {
1111 fail("unknown type $_ specified in description file $f");
1114 $p->{'type'} = "$s$b$u";
1116 set_value($f,$p,'unpack-level',$secs[0],1);
1117 set_value($f,$p,'order',$secs[0],1);
1118 set_value($f,$p,'version',$secs[0],1);
1120 if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
1121 for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
1124 delete $secs[0]->{'needs-info'};
1127 # ignore Info: and other fields for now
1128 delete $secs[0]->{'info'};
1129 delete $secs[0]->{'author'};
1131 for (keys %{$secs[0]}) {
1132 warning("unused tag $_ in description file $f");
1135 debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));
1141 # {{{ Now we're ready to load info about checks & tags
1143 # load information about checker scripts
1144 opendir(CHECKDIR, "$MAEMIAN_ROOT/checks")
1145 or fail("cannot read directory $MAEMIAN_ROOT/checks");
1147 for my $f (readdir CHECKDIR) {
1148 next if $f =~ /^\./;
1149 next unless $f =~ /\.desc$/;
1150 debug_msg(2, "Reading checker description file $f ...");
1152 my @secs = read_dpkg_control("$MAEMIAN_ROOT/checks/$f");
1154 ($script = $secs[0]->{'check-script'})
1155 or fail("error in description file $f: `Check-Script:' not defined");
1157 # ignore check `maemian' (this check is a special case and contains the
1158 # tag info for the maemian frontend--this script here)
1159 next if $script eq 'maemian';
1161 delete $secs[0]->{'check-script'};
1162 $check_info{$script}->{'script'} = $script;
1163 my $p = $check_info{$script};
1165 set_value($f,$p,'type',$secs[0],1);
1167 my ($b,$s,$u) = ( "", "", "" );
1168 for (split(/\s*,\s*/o,$p->{'type'})) {
1169 if ($_ eq 'binary') {
1171 } elsif ($_ eq 'source') {
1173 } elsif ($_ eq 'udeb') {
1176 fail("unknown type $_ specified in description file $f");
1179 $p->{'type'} = "$s$b$u";
1181 set_value($f,$p,'unpack-level',$secs[0],1);
1182 set_value($f,$p,'abbrev',$secs[0],1);
1184 if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
1185 for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
1188 delete $secs[0]->{'needs-info'};
1191 # ignore Info: and other fields for now...
1192 delete $secs[0]->{'info'};
1193 delete $secs[0]->{'standards-version'};
1194 delete $secs[0]->{'author'};
1196 for (keys %{$secs[0]}) {
1197 warning("unused tag $_ in description file $f");
1200 debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));
1203 $p->{'requested-tags'} = 0;
1204 foreach my $tag (@secs) {
1205 $tag->{'script'} = $script;
1206 Tags::add_tag($tag);
1207 $p->{'requested-tags'}++ if Tags::display_tag($tag);
1215 # {{{ Again some lone code the author just dumped where his cursor just happened to be
1217 # determine which info has been requested
1218 for my $i (split(/,/,$unpack_info)) {
1219 unless ($collection_info{$i}) {
1220 fail("unknown info specified: $i");
1222 $unpack_infos{$i} = 1;
1226 # create check_abbrev hash
1227 for my $c (keys %check_info) {
1228 $check_abbrev{$check_info{$c}->{'abbrev'}} = $c;
1233 # {{{ determine which checks have been requested
1234 if ($action eq 'check') {
1236 foreach my $t (split(/,/, $check_tags)) {
1237 my $info = Tags::get_tag_info($t);
1239 fail("unknown tag specified: $t") unless defined($info);
1240 my $script = $info->{'script'};
1241 next if $script eq 'maemian';
1242 if ($check_info{$script}) {
1243 $checks{$script} = 1;
1245 # should never happen
1246 fail("no info for script $script");
1250 my %dont_check = map { $_ => 1 } (split m/,/, ($dont_check || ""));
1251 $checks or ($checks = join(',',keys %check_info));
1252 for my $c (split(/,/,$checks)) {
1253 if ($check_info{$c}) {
1255 || ($check_info{$c}->{'abbrev'}
1256 && $dont_check{$check_info{$c}->{'abbrev'}})) {
1257 #user requested not to run this check
1258 } elsif ($check_info{$c}->{'requested-tags'} == 0) {
1259 #no need to run this check, no tags will be issued
1263 } elsif (exists $check_abbrev{$c}) {
1264 #abbrevs only used when -C is given, so we don't need %dont_check
1265 $checks{$check_abbrev{$c}} = 1;
1267 fail("unknown check specified: $c");
1272 # determine which info is needed by the checks
1273 for my $c (keys %checks) {
1274 for my $i (keys %collection_info) {
1276 if ($check_info{$c}->{$i}) {
1277 $unpack_infos{$i} = 1;
1285 # {{{ determine which info is needed by the collection scripts
1286 for my $c (keys %unpack_infos) {
1287 for my $i (keys %collection_info) {
1289 if ($collection_info{$c}->{$i}) {
1290 $unpack_infos{$i} = 1;
1296 # {{{ process all packages in the archive?
1297 if ($check_everything) {
1298 # make sure package info is available
1299 read_src_list("$MAEMIAN_LAB/info/source-packages", 0);
1300 read_bin_list("$MAEMIAN_LAB/info/binary-packages", 0);
1301 read_udeb_list("$MAEMIAN_LAB/info/udeb-packages", 0);
1303 debug_msg(2, "pkg_mode = $pkg_mode");
1305 if (($pkg_mode eq 'a') or ($pkg_mode eq 's')) {
1306 for my $arg (sort keys %source_info) {
1307 debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}");
1308 $schedule->add_file('s', "$MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}",
1309 %{$source_info{$arg}});
1312 if (($pkg_mode eq 'a') or ($pkg_mode eq 'b')) {
1313 for my $arg (sort keys %binary_info) {
1314 debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}");
1315 $schedule->add_file('b', "$MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}",
1316 %{$binary_info{$arg}});
1319 if (($pkg_mode eq 'a') or ($pkg_mode eq 'u')) {
1320 for my $arg (sort keys %udeb_info) {
1321 debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}");
1322 $schedule->add_file('u', "$MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}",
1323 %{$udeb_info{$arg}});
1327 # package list still empty?
1328 unless ($schedule->count) {
1329 warning("no packages found in distribution directory");
1331 } elsif ($packages_file) { # process all packages listed in packages file?
1332 $schedule->add_pkg_list($packages_file);
1336 # {{{ Some silent exit
1337 unless ($schedule->count) {
1338 v_msg("No packages selected.");
1343 # {{{ Okay, now really processing the packages in one huge loop
1344 $unpack_infos{ "override-file" } = 1 unless $no_override;
1345 v_msg(sprintf("Processing %d packages...", $schedule->count));
1347 "Selected action: $action",
1348 "Requested unpack level: $unpack_level",
1349 sprintf("Requested data to collect: %s", join(',',keys %unpack_infos)),
1350 sprintf("Selected checks: %s", join(',',keys %checks)),
1354 require Maemian::Collect;
1359 foreach my $pkg_info ($schedule->get_all) {
1360 my ($type, $pkg, $ver, $arch, $file) =
1361 @$pkg_info{qw(type package version architecture file)};
1362 my $long_type = ($type eq 'b' ? 'binary' :
1363 ($type eq 's' ? 'source' : 'udeb' ));
1365 Tags::set_pkg( $file, $pkg, $ver, $arch, $long_type );
1367 # Kill pending jobs, if any
1368 Maemian::Command::kill(@pending_jobs);
1369 undef @pending_jobs;
1371 # determine base directory
1372 my $base = "$MAEMIAN_LAB/$long_type/$pkg";
1373 unless ($base =~ m,^/,) {
1374 $base = "$cwd/$base";
1376 debug_msg(1, "Base directory in lab: $base");
1378 my $act_unpack_level = 0;
1380 # unpacked package up-to-date?
1382 my $remove_basedir = 0;
1384 # there's a base dir, so we assume that at least
1385 # one level of unpacking has been done
1386 $act_unpack_level = 1;
1388 # maemian status file exists?
1389 unless (-f "$base/.maemian-status") {
1390 v_msg("No maemian status file found (removing old directory in lab)");
1391 $remove_basedir = 1;
1392 goto REMOVE_BASEDIR;
1395 # read unpack status -- catch any possible errors
1397 eval { ($data) = read_dpkg_control("$base/.maemian-status"); };
1400 $remove_basedir = 1;
1401 goto REMOVE_BASEDIR;
1404 # compatible maemian version?
1405 if (not exists $data->{'lab-format'} or ($data->{'lab-format'} < $LAB_FORMAT)) {
1406 v_msg("Lab directory was created by incompatible maemian version");
1407 $remove_basedir = 1;
1408 goto REMOVE_BASEDIR;
1411 # version up to date?
1412 if (not exists $data->{'version'} or ($data->{'version'} ne $ver)) {
1413 debug_msg(1, "Removing package in lab (newer version exists) ...");
1414 $remove_basedir = 1;
1415 goto REMOVE_BASEDIR;
1418 # unpack level defined?
1419 unless (exists $data->{'unpack-level'}) {
1420 warning("cannot determine unpack-level of package");
1421 $remove_basedir = 1;
1422 goto REMOVE_BASEDIR;
1424 $act_unpack_level = $data->{'unpack-level'};
1430 unless (@stat = stat $file) {
1431 warning("cannot stat file $file: $!");
1433 $timestamp = $stat[9];
1435 if ((not defined $timestamp) or (not exists $data->{'timestamp'}) or ($data->{'timestamp'} != $timestamp)) {
1436 debug_msg(1, "Removing package in lab (package has been changed) ...");
1437 $remove_basedir = 1;
1438 goto REMOVE_BASEDIR;
1442 if ($remove_basedir) {
1443 v_msg("Removing $pkg");
1444 unless (remove_pkg($base)) {
1445 warning("skipping $action of $long_type package $pkg");
1449 $act_unpack_level = 0;
1453 # unpack to requested unpack level
1454 $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,
1456 if ($act_unpack_level == -1) {
1457 warning("could not unpack package to desired level",
1458 "skipping $action of $long_type package $pkg");
1463 if (($action eq 'unpack') or ($action eq 'check')) { # collect info
1464 my $current_order = -1;
1465 for my $coll (sort by_collection_order keys %unpack_infos) {
1466 my $ci = $collection_info{$coll};
1467 my %run_opts = ('description' => $coll);
1470 next unless ($ci->{'type'} =~ m/$type/);
1472 # If a file named .SCRIPT-VERSION already exists, we've already
1473 # collected this information and we can skip it. Otherwise,
1474 # remove any .SCRIPT-* files (which are old version information).
1475 next if (-f "$base/.${coll}-$ci->{'version'}");
1476 opendir(BASE, $base)
1477 or fail("cannot read directory $base: $!");
1478 for my $file (readdir BASE) {
1479 if ($file =~ /^\.\Q$coll-/) {
1480 unlink("$base/$file");
1485 # unpack to desired unpack level (if necessary)
1486 $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
1487 if ($act_unpack_level == -1) {
1488 warning("could not unpack package to desired level",
1489 "skipping $action of $long_type package $pkg");
1494 # chdir to base directory
1495 unless (chdir($base)) {
1496 warning("could not chdir into directory $base: $!",
1497 "skipping $action of $long_type package $pkg");
1502 $current_order = $ci->{'order'} if ($current_order == -1);
1503 if ($current_order != $ci->{'order'}) {
1504 debug_msg(1, "Waiting for jobs from order $current_order ...");
1505 unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
1506 warning("skipping $action of $long_type package $pkg");
1510 undef @pending_jobs;
1511 $current_order = $ci->{'order'};
1515 remove_status_file($base);
1516 debug_msg(1, "Collecting info: $coll ...");
1517 my $script = "$MAEMIAN_ROOT/collection/$ci->{'script'}";
1518 unless (spawn(\%run_opts, [ $script, $pkg, $long_type, '&' ])) {
1519 warning("collect info $coll about package $pkg failed",
1520 "skipping $action of $long_type package $pkg");
1524 push @pending_jobs, \%run_opts;
1527 # wait until all the jobs finish and skip this package if any of them
1529 debug_msg(1, "Waiting for jobs from order $current_order ...");
1530 unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
1531 warning("skipping $action of $long_type package $pkg");
1535 undef @pending_jobs;
1538 if ($action eq 'check') { # read override file
1540 unless ($no_override) {
1541 Tags::add_overrides("$base/override", $pkg, $long_type)
1542 if (-f "$base/override")
1546 my $info = Maemian::Collect->new($pkg, $long_type);
1547 for my $check (keys %checks) {
1548 my $ci = $check_info{$check};
1551 next unless ($ci->{'type'} =~ m/$type/);
1553 # unpack to desired unpack level (if necessary)
1554 $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
1555 if ($act_unpack_level == -1) {
1556 warning("could not unpack package to desired level",
1557 "skipping $action of $long_type package $pkg");
1562 # chdir to base directory
1563 unless (chdir($base)) {
1564 warning("could not chdir into directory $base: $!",
1565 "skipping $action of $long_type package $pkg");
1570 my $returnvalue = Checker::runcheck($pkg, $long_type, $info, $check);
1571 # Set exit_code correctly if there was not yet an exit code
1572 $exit_code = $returnvalue unless $exit_code;
1574 if ($returnvalue == 2) {
1575 warning("skipping $action of $long_type package $pkg");
1580 unless ($exit_code) {
1581 my $stats = Tags::get_stats( $file );
1582 if ($stats->{types}{E}) {
1584 } elsif ($fail_on_warnings && $stats->{types}{W}) {
1589 # report unused overrides
1590 if (not $no_override) {
1591 my $overrides = Tags::get_overrides( $file );
1593 for my $tag (sort keys %$overrides) {
1594 my $taginfo = Tags::get_tag_info{$tag};
1595 if (defined $taginfo) {
1596 # Did we run the check script containing the tag?
1597 next unless $checks{$taginfo->{'script'}};
1599 # If only checking specific tags, is this one of them?
1600 next unless (scalar keys %Tags::only_issue_tags == 0)
1601 or exists $Tags::only_issue_tags{$tag};
1604 for my $extra (sort keys %{$overrides->{$tag}}) {
1605 next if $overrides->{$tag}{$extra};
1607 tag( "unused-override", $tag, $extra );
1612 # Report override statistics.
1613 if (not $no_override and not $show_overrides) {
1614 my $stats = Tags::get_stats($file);
1617 my $errors = $stats->{overrides}{types}{E} || 0;
1618 my $warnings = $stats->{overrides}{types}{W} || 0;
1619 my $info = $stats->{overrides}{types}{I} || 0;
1620 $overrides{errors} += $errors;
1621 $overrides{warnings} += $warnings;
1622 $overrides{info} += $info;
1626 # chdir to maemian root directory (to unlock $base so it can be removed below)
1627 unless (chdir($MAEMIAN_ROOT)) {
1628 warning("could not chdir into directory $MAEMIAN_ROOT: $!",
1629 "skipping $action of $long_type package $pkg");
1635 if ($act_unpack_level > $unpack_level) {
1636 $act_unpack_level = clean_pkg($type,$base,$file,$act_unpack_level,$unpack_level);
1637 if ($act_unpack_level == -1) {
1638 warning("could not clean up laboratory for package $pkg: $!",
1639 "skipping clean up");
1645 # create Maemian status file
1646 if (($act_unpack_level > 0) and (not -f "$base/.maemian-status")) {
1648 unless (@stat = stat $file) {
1649 warning("cannot stat file $file: $!",
1650 "skipping creation of status file");
1654 my $timestamp = $stat[9];
1656 unless (open(STATUS, '>', "$base/.maemian-status")) {
1657 warning("could not create status file $base/.maemian-status for package $pkg: $!");
1662 print STATUS "Maemian-Version: $MAEMIAN_VERSION\n";
1663 print STATUS "Lab-Format: $LAB_FORMAT\n";
1664 print STATUS "Package: $pkg\n";
1665 print STATUS "Version: $ver\n";
1666 print STATUS "Type: $type\n";
1667 print STATUS "Unpack-Level: $act_unpack_level\n";
1668 print STATUS "Timestamp: $timestamp\n";
1673 if ($action eq 'check' and not $no_override and not $show_overrides) {
1674 my $errors = $overrides{errors} || 0;
1675 my $warnings = $overrides{warnings} || 0;
1676 my $info = $overrides{info} || 0;
1677 my $total = $errors + $warnings + $info;
1679 my $total = ($total == 1)
1680 ? "$total tag overridden"
1681 : "$total tags overridden";
1684 push (@output, ($errors == 1) ? "$errors error" : "$errors errors");
1687 push (@output, ($warnings == 1) ? "$warnings warning" : "$warnings warnings");
1690 push (@output, "$info info");
1692 msg("$total (". join (', ', @output). ")");
1700 # {{{ Some subroutines
1703 my ($type,$base,$file,$cur_level,$new_level) = @_;
1705 debug_msg(1, sprintf("Current unpack level is %d",$cur_level));
1707 return $cur_level if $cur_level == $new_level;
1709 # remove .maemian-status file
1710 remove_status_file($base);
1712 if ( ($cur_level == 0) and (-d $base) ) {
1713 # We were lied to, there's something already there - clean it up first
1714 remove_pkg($base) or return -1;
1717 if ( ($new_level >= 1) and
1718 (not defined ($cur_level) or ($cur_level < 1)) ) {
1719 # create new directory
1720 debug_msg(1, "Unpacking package to level 1 ...");
1721 if (($type eq 'b') || ($type eq 'u')) {
1722 spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-binpkg-l1", $base, $file])
1725 spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-srcpkg-l1", $base, $file])
1731 if ( ($new_level >= 2) and
1732 (not defined ($cur_level) or ($cur_level < 2)) ) {
1733 # unpack package contents
1734 debug_msg(1, "Unpacking package to level 2 ...");
1735 if (($type eq 'b') || ($type eq 'u')) {
1736 spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-binpkg-l2", $base])
1739 debug_msg(1, "$MAEMIAN_ROOT/unpack/unpack-srcpkg-l2 $base");
1740 spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-srcpkg-l2", $base])
1749 # Given a list of jobs corresponding to collect scripts, reap each of the
1750 # jobs. For each successful job, record that it was successful by creating
1751 # the corresponding version marker file in the lab. For each unsuccessful
1752 # job, warn that it was unsuccessful.
1754 # Takes the current package, base directory, and the list of pending jobs.
1755 # Return true if all jobs were successful, false otherwise.
1756 sub reap_collect_jobs {
1757 my ($pkg, $base, @pending_jobs) = @_;
1758 my $status = reap(@pending_jobs);
1759 for my $job (@pending_jobs) {
1760 my $coll = $job->{'description'};
1761 if ($job->{success}) {
1762 my $ci = $collection_info{$coll};
1763 open(VERSION, '>', "$base/.${coll}-$ci->{'version'}")
1764 or fail("cannot create $base/.${coll}-$ci->{'version'}: $!");
1765 print VERSION "Maemian-Version: $MAEMIAN_VERSION\n"
1766 . "Timestamp: " . time . "\n";
1769 warning("collect info $coll about package $pkg failed");
1775 # TODO: is this the best way to clean dirs in perl?
1776 # no, look at File::Path module
1778 my ($type,$base,$file,$cur_level,$new_level) = @_;
1780 return $cur_level if $cur_level == $new_level;
1782 if ($new_level < 1) {
1783 # remove base directory
1784 remove_pkg($base) or return -1;
1788 if ( ($new_level < 2) and defined ($cur_level) and ($cur_level >= 2) ) {
1789 # remove .maemian-status file
1790 remove_status_file($base);
1792 # remove unpacked/ directory
1793 debug_msg(1, "Decreasing unpack level to 1 (removing files) ...");
1794 if ( -l "$base/unpacked" ) {
1795 delete_dir("$base/".readlink("$base/unpacked"))
1797 delete_dir("$base/unpacked") or return -1;
1799 delete_dir("$base/unpacked") or return -1;
1808 # this function removes a package's base directory in the lab completely
1812 debug_msg(1, "Removing package in lab ...");
1813 unless (delete_dir($base)) {
1814 warning("cannot remove directory $base: $!");
1821 sub remove_status_file {
1824 # status file exists?
1825 if (not -e "$base/.maemian-status") {
1829 if (not unlink("$base/.maemian-status")) {
1830 warning("cannot remove status file $base/.maemian-status: $!");
1837 # -------------------------------
1839 # get package name, version, and file name from the lab
1840 sub get_bin_info_from_lab {
1841 my ($base_dir) = @_;
1842 my ($pkg,$ver,$arch,$file);
1844 ($pkg = read_file("$base_dir/fields/package"))
1845 or fail("cannot read file $base_dir/fields/package: $!");
1847 ($ver = read_file("$base_dir/fields/version"))
1848 or fail("cannot read file $base_dir/fields/version: $!");
1850 ($arch = read_file("$base_dir/fields/architecture"))
1851 or fail("cannot read file $base_dir/fields/architecture: $!");
1853 ($file = readlink("$base_dir/deb"))
1854 or fail("cannot read link $base_dir/deb: $!");
1856 return ($file, package => $pkg, version => $ver, architecture => $arch);
1859 # get package name, version, and file name from the lab
1860 sub get_src_info_from_lab {
1861 my ($base_dir) = @_;
1862 my ($pkg,$ver,$file);
1864 ($pkg = read_file("$base_dir/fields/source"))
1865 or fail("cannot read file $base_dir/fields/source: $!");
1867 ($ver = read_file("$base_dir/fields/version"))
1868 or fail("cannot read file $base_dir/fields/version: $!");
1870 ($file = readlink("$base_dir/dsc"))
1871 or fail("cannot read link $base_dir/dsc: $!");
1873 return ($file, source => $pkg, version => $ver);
1876 # -------------------------------
1878 # read first line of a file
1882 open(T, '<', $_[0]) or return;
1889 # sort collection list by `order'
1890 sub by_collection_order {
1891 $collection_info{$a}->{'order'} <=> $collection_info{$b}->{'order'};
1898 # Prevent Lab::delete from affecting the exit code.
1901 $SIG{'INT'} = 'DEFAULT';
1902 $SIG{'QUIT'} = 'DEFAULT';
1904 $LAB->delete() if $LAB and not $keep_lab;
1908 $SIG{$_[0]} = 'DEFAULT';
1909 die "N: Interrupted.\n";
1914 # indent-tabs-mode: t
1915 # cperl-indent-level: 4
1917 # vim: sw=4 ts=8 noet fdm=marker