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;
117 #turn off file buffering
120 # reset locale definition (necessary for tar)
121 $ENV{'LC_ALL'} = 'C';
122 # reset timezone definition (also for tar)
127 # {{{ Process Command Line
129 #######################################
130 # Subroutines called by various options
131 # in the options hash below. These are
132 # invoked to process the commandline
134 #######################################
135 # Display Command Syntax
139 print <<"EOT-EOT-EOT";
140 Syntax: maemian [action] [options] [--] [packages] ...
142 -S, --setup-lab set up static lab
143 -R, --remove-lab remove static lab
144 -c, --check check packages (default action)
145 -C X, --check-part X check only certain aspects
146 -X X, --dont-check-part X don\'t check certain aspects
147 -T X, --tags X only run checks needed for requested tags
148 --tags-from-file X like --tags, but read list from file
149 -u, --unpack only unpack packages in the lab
150 -r, --remove remove package from the lab
152 -h, --help display short help text
153 -v, --verbose verbose messages
154 -V, --version display Maemian version and exit
155 --print-version print unadorned version number and exit
156 -d, --debug turn Maemian\'s debug messages ON
157 -q, --quiet suppress all informational messages
159 -i, --info give detailed info about tags
160 -I, --display-info display "I:" tags (normally suppressed)
161 -E, --display-experimental display "X:" tags (normally suppressed)
162 --pedantic display "P:" tags (normally suppressed)
163 -L, --display-level display tags with the specified level
164 --display-source X restrict displayed tags by source
165 -l X, --unpack-level X set default unpack level to X
166 -o, --no-override ignore overrides
167 --show-overrides output tags that have been overriden
168 --color never/always/auto disable, enable, or enable color for TTY
169 -U X, --unpack-info X specify which info should be collected
170 -m, --md5sums, --checksums check checksums when processing a .changes file
171 --allow-root suppress maemian\'s warning when run as root
172 --fail-on-warnings return a non-zero exit status if warnings found
173 --keep-lab keep lab after run, even if temporary
174 Configuration options:
175 --cfg CONFIGFILE read CONFIGFILE for configuration
176 --lab LABDIR use LABDIR as permanent laboratory
177 --archivedir ARCHIVEDIR location of Debian archive to scan for packages
178 --dist DIST scan packages in this distribution (e.g. sid)
179 --area AREA scan packages in this archive area (e.g. main)
180 --arch ARCH scan packages with architecture ARCH
181 --root ROOTDIR use ROOTDIR instead of /usr/share/maemian
182 Package selection options:
183 -a, --all process all packages in distribution
184 -b, --binary process only binary packages
185 -s, --source process only source packages
186 --udeb process only udeb packages
187 -p X, --packages-file X process all files in file (special syntax!)
193 # Display Version Banner
194 # Options: -V|--version, --print-version
196 if ($_[0] eq 'print-version') {
197 print "$MAEMIAN_VERSION\n";
204 # Record action requested
205 # Options: -S, -R, -c, -u, -r
208 die("too many actions specified: $_[0]");
213 # Record Parts requested for checking
214 # Options: -C|--check-part
215 sub record_check_part {
216 if (defined $action and $action eq 'check' and $checks) {
217 die("multiple -C or --check-part options not allowed");
220 die("both -C or --check-part and -X or --dont-check-part options not allowed");
223 die("too many actions specified: $_[0]");
229 # Record Parts requested for checking
231 sub record_check_tags {
232 if (defined $action and $action eq 'check' and $check_tags) {
233 die("multiple -T or --tags options not allowed");
236 die("both -T or --tags and -C or --check-part options not allowed");
239 die("both -T or --tags and -X or --dont-check-part options not allowed");
242 die("too many actions specified: $_[0]");
245 $check_tags = "$_[1]";
248 # Record Parts requested for checking
249 # Options: --tags-from-file
250 sub record_check_tags_from_file {
251 open my $file, '<', $_[1]
252 or fail("failed to open $_[1]: $!");
253 my $tags = join(',', map { chomp($_); $_ } <$file>);
256 record_check_tags($_[0], $tags);
260 # Record Parts requested not to check
261 # Options: -X|--dont-check-part X
262 sub record_dont_check_part {
263 if (defined $action and $action eq 'check' and $dont_check) {
264 die("multiple -X or --dont-check-part options not allowed");
267 die("both -C or --check-part and -X or --dont-check-part options not allowed");
270 die("too many actions specified: $_[0]");
273 $dont_check = "$_[1]";
277 # Process for -U|--unpack-info flag
278 sub record_unpack_info {
280 die("multiple -U or --unpack-info options not allowed");
282 $unpack_info = "$_[1]";
285 # Record what type of data is specified
286 # Options: -b|--binary, -s|--source, --udeb
288 $pkg_mode = 'b' if $_[0] eq 'binary';
289 $pkg_mode = 's' if $_[0] eq 'source';
290 $pkg_mode = 'u' if $_[0] eq 'udeb';
293 # Process -L|--display-level flag
294 sub record_display_level {
296 if ($level =~ m/^\+(.+)/) {
297 set_display_level($1, 1);
298 } elsif ($level =~ m/^\-(.+)/) {
299 set_display_level($1, 0);
300 } elsif ($level =~ m/^\=?(.+)/) {
301 reset_display_level();
302 set_display_level($1, 1);
304 die "invalid argument to --display-level: $level\n";
308 # Process -I|--display-info flag
309 sub display_infotags {
310 foreach my $s (@severities) {
311 set_display_level($s, 1);
315 # Process --display-source flag
316 sub record_display_source {
317 $display_source{$_[1]} = 1;
320 # Clears current display level information, disabling all severities and
322 sub reset_display_level {
323 foreach my $s (@severities) {
324 foreach my $c (@certainties) {
325 $display_level{$s}{$c} = 0;
330 sub set_display_level_multi {
331 my ($op, $level, $val) = @_;
333 my @inc_severities = @severities;
334 my @inc_certainties = @certainties;
335 my $inc_border = ($op =~ /^[<>]=$/) ? 1 : 0;
337 @inc_severities = reverse @inc_severities;
338 @inc_certainties = reverse @inc_certainties;
340 my $severity = join("|", @severities);
341 my $certainty = join("|", @certainties);
342 if ($level =~ m/^($severity)$/) {
343 foreach my $s (cut_list($level, $inc_border, @inc_severities)) {
344 map { $display_level{$s}{$_} = $val } @certainties;
346 } elsif ($level =~ m/^($certainty)$/) {
347 foreach my $c (cut_list($level, $inc_border, @inc_certainties)) {
348 map { $display_level{$_}{$c} = $val } @severities;
350 } elsif ($level =~ m/^($severity)\/($certainty)$/) {
351 foreach my $s (cut_list($1, $inc_border, @inc_severities)) {
352 foreach my $c (cut_list($2, $inc_border, @inc_certainties)) {
353 $display_level{$s}{$c} = $val;
357 die "invalid argument to --display-level: $level\n";
363 my ($border, $inc_border, @list) = @_;
365 my (@newlist, $found);
368 push @newlist, $_ if $inc_border;
375 die "internal error: cut_list did not find border $border\n"
377 if (!$inc_border and !@newlist
378 and $border eq $list[0]) {
379 warn "warning: display level $border specified with > (or <) is empty set, assuming >= (or <=)\n";
380 push @newlist, $list[0];
386 # Parse input display level to enable (val 1) or disable (val 0) it
388 sub set_display_level {
389 my ($level, $val) = @_;
390 if ($level =~ m/^([<>]=?)(.+)/) {
391 set_display_level_multi($1, $2, $val);
395 my $severity = join("|", @severities);
396 my $certainty = join("|", @certainties);
397 if ($level =~ m/^($severity)$/) {
398 map { $display_level{$1}{$_} = $val } @certainties;
399 } elsif ($level =~ m/^($certainty)$/) {
400 map { $display_level{$_}{$1} = $val } @severities;
401 } elsif ($level =~ m/^($severity)\/($certainty)$/) {
402 $display_level{$1}{$2} = $val;
404 die "invalid argument to --display-level: $level\n";
408 # Hash used to process commandline options
410 # ------------------ actions
411 "setup-lab|S" => \&record_action,
412 "remove-lab|R" => \&record_action,
413 "check|c" => \&record_action,
414 "check-part|C=s" => \&record_check_part,
415 "tags|T=s" => \&record_check_tags,
416 "tags-from-file=s" => \&record_check_tags_from_file,
417 "dont-check-part|X=s" => \&record_dont_check_part,
418 "unpack|u" => \&record_action,
419 "remove|r" => \&record_action,
421 # ------------------ general options
422 "help|h" => \&syntax,
423 "version|V" => \&banner,
424 "print-version" => \&banner,
426 "verbose|v" => \$verbose,
427 "debug|d" => \@debug, # Count the -d flags
428 "quiet|q" => \$quiet,
430 # ------------------ behaviour options
431 "info|i" => \$maemian_info,
432 "display-info|I" => \&display_infotags,
433 "display-experimental|E" => \$display_experimentaltags,
434 "pedantic" => \$display_pedantictags,
435 "display-level|L=s" => \&record_display_level,
436 "display-source=s" => \&record_display_source,
437 "unpack-level|l=i" => \$unpack_level,
438 "no-override|o" => \$no_override,
439 "show-overrides" => \$show_overrides,
440 "color=s" => \$color,
441 "unpack-info|U=s" => \&record_unpack_info,
442 "checksums|md5sums|m" => \$check_checksums,
443 "allow-root" => \$allow_root,
444 "fail-on-warnings" => \$fail_on_warnings,
445 "keep-lab" => \$keep_lab,
446 # Note: Ubuntu has (and other derivatives might gain) a
447 # -D/--debian option to make maemian behave like in Debian, that
448 # is, to revert distribution-specific changes
450 # ------------------ configuration options
451 "cfg=s" => \$MAEMIAN_CFG,
452 "lab=s" => \$OPT_MAEMIAN_LAB,
453 "archivedir=s" => \$OPT_MAEMIAN_ARCHIVEDIR,
454 "dist=s" => \$OPT_MAEMIAN_DIST,
455 "area=s" => \$OPT_MAEMIAN_AREA,
456 "section=s" => \$OPT_MAEMIAN_AREA,
457 "arch=s" => \$OPT_MAEMIAN_ARCH,
458 "root=s" => \$MAEMIAN_ROOT,
460 # ------------------ package selection options
461 "all|a" => \$check_everything,
462 "binary|b" => \&record_pkgmode,
463 "source|s" => \&record_pkgmode,
464 "udeb" => \&record_pkgmode,
465 "packages-file|p=s" => \$packages_file,
467 # ------------------ experimental
468 "exp-output:s" => \$experimental_output_opts,
471 # init display level settings
472 reset_display_level();
473 set_display_level_multi('>=', 'important', 1);
474 set_display_level_multi('>=', 'normal/possible', 1);
475 set_display_level('minor/certain', 1);
477 # init commandline parser
478 Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev');
480 # process commandline options
482 or die("error parsing options\n");
484 # determine current working directory--we'll need this later
487 # determine MAEMIAN_ROOT if it was not set with --root.
488 $MAEMIAN_ROOT = $MAEMIAN_ROOT || $ENV{'MAEMIAN_ROOT'};
489 if (defined $MAEMIAN_ROOT) {
490 unless ($MAEMIAN_ROOT =~ m,^/,) {
491 $MAEMIAN_ROOT = "$cwd/$MAEMIAN_ROOT";
494 $MAEMIAN_ROOT = '/usr/share/maemian';
497 # keep-lab implies unpack-level=2 unless explicetly
499 if ($keep_lab and not defined $unpack_level) {
503 # option --all and packages specified at the same time?
504 if (($check_everything or $packages_file) and $#ARGV+1 > 0) {
505 print STDERR "warning: options -a or -p can't be mixed with package parameters!\n";
506 print STDERR "(will ignore -a or -p option)\n";
507 undef $check_everything;
508 undef $packages_file;
511 # check permitted values for --color
512 if ($color and $color !~ /^(never|always|auto|html)$/) {
513 die "invalid argument to --color: $color\n";
516 # check specified action
517 $action = 'check' unless $action;
519 # check for arguments
520 if ($action =~ /^(check|unpack|remove)$/ and $#ARGV == -1 and not $check_everything and not $packages_file) {
526 # {{{ Setup Configuration
529 # check if effective UID is 0
530 if ($> == 0 and not $allow_root) {
531 print STDERR "warning: maemian's authors do not recommend running it with root privileges!\n";
534 # search for configuration file if it was not set with --cfg
535 # do not search the default locations if it was set.
537 } elsif (exists $ENV{'MAEMIAN_CFG'} &&
538 -f ($MAEMIAN_CFG = $ENV{'MAEMIAN_CFG'})) {
539 } elsif (-f ($MAEMIAN_CFG = $MAEMIAN_ROOT . '/maemianrc')) {
540 } elsif (exists $ENV{'HOME'} &&
541 -f ($MAEMIAN_CFG = $ENV{'HOME'} . '/.maemianrc')) {
542 } elsif (-f ($MAEMIAN_CFG = '/etc/maemianrc')) {
547 use constant VARS => qw(LAB ARCHIVEDIR DIST UNPACK_LEVEL SECTION AREA ARCH);
548 # read configuration file
550 open(CFG, '<', $MAEMIAN_CFG)
551 or die("cannot open configuration file $MAEMIAN_CFG for reading: $!");
558 # substitute some special variables
559 s,\$HOME/,$ENV{'HOME'}/,go;
560 s,\~/,$ENV{'HOME'}/,go;
563 foreach my $var (VARS) {
565 $var = "MAEMIAN_$var";
566 if (m/^\s*$var\s*=\s*(.*\S)\s*$/i) {
573 die "syntax error in configuration file: $_\n";
579 # environment variables overwrite settings in conf file:
582 my $var = "MAEMIAN_$_";
583 my $opt_var = "OPT_$var";
584 $$var = $ENV{$var} if $ENV{$var};
585 $$var = $$opt_var if $$opt_var;
588 # MAEMIAN_ARCH must have a value.
589 unless (defined $MAEMIAN_ARCH) {
591 chop($MAEMIAN_ARCH=`dpkg --print-architecture`);
593 $MAEMIAN_ARCH = 'any';
597 # MAEMIAN_SECTION is deprecated in favour of MAEMIAN_AREA
598 if (defined $MAEMIAN_SECTION) {
599 print STDERR "warning: MAEMIAN_SECTION has been deprecated in favour of MAEMIAN_AREA.\n";
600 if (defined $MAEMIAN_AREA) {
601 print STDERR "Using MAEMIAN_AREA as both were defined.\n";
603 print STDERR "Both are currently accepted, but MAEMIAN_SECTION may be removed\n";
604 print STDERR "in a future Maemian release.\n";
605 $MAEMIAN_AREA = $MAEMIAN_SECTION;
609 # determine requested unpack level
610 if (defined($unpack_level)) {
611 # specified through command line
612 } elsif (defined($MAEMIAN_UNPACK_LEVEL)) {
613 # specified via configuration file or env variable
614 $unpack_level = $MAEMIAN_UNPACK_LEVEL;
616 # determine by action
617 if (($action eq 'unpack') or ($action eq 'check')) {
623 unless (($unpack_level == 0) or ($unpack_level == 1) or ($unpack_level == 2)) {
624 die("bad unpack level $unpack_level specified");
627 $MAEMIAN_UNPACK_LEVEL = $unpack_level;
629 # export current settings for our helper scripts
630 foreach (('ROOT', 'CFG', VARS)) {
632 my $var = "MAEMIAN_$_";
641 my $debug = $#debug + 1;
642 $verbose = 1 if $debug;
643 $ENV{'MAEMIAN_DEBUG'} = $debug;
645 # Loading maeian's own libraries (now that MAEMIAN_ROOT is known)
646 unshift @INC, "$MAEMIAN_ROOT/lib";
651 require Read_pkglists;
658 require Maemian::Data;
659 require Maemian::Schedule;
660 require Maemian::Output;
661 import Maemian::Output qw(:messages);
662 require Maemian::Command;
663 import Maemian::Command qw(spawn reap);
664 require Maemian::Check;
665 import Maemian::Check qw(check_maintainer);
668 if (defined $experimental_output_opts) {
669 my %opts = map { split(/=/) } split( /,/, $experimental_output_opts );
670 foreach (keys %opts) {
671 if ($_ eq 'format') {
672 if ($opts{$_} eq 'colons') {
673 require Maemian::Output::ColonSeparated;
674 $Maemian::Output::GLOBAL = new Maemian::Output::ColonSeparated;
675 } elsif ($opts{$_} eq 'letterqualifier') {
676 require Maemian::Output::LetterQualifier;
677 $Maemian::Output::GLOBAL = new Maemian::Output::LetterQualifier;
678 } elsif ($opts{$_} eq 'xml') {
679 require Maemian::Output::XML;
680 $Maemian::Output::GLOBAL = new Maemian::Output::XML;
684 ${"Tags::$_"} = $opts{$_};
688 $Maemian::Output::GLOBAL->verbose($verbose);
689 $Maemian::Output::GLOBAL->debug($debug);
690 $Maemian::Output::GLOBAL->quiet($quiet);
691 $Maemian::Output::GLOBAL->color($color);
692 $Maemian::Output::GLOBAL->showdescription($maemian_info);
694 # Print Debug banner, now that we're finished determining
695 # the values and have Maemian::Output available
698 "Maemian root directory: $MAEMIAN_ROOT",
699 "Configuration file: $MAEMIAN_CFG",
700 "Laboratory: $MAEMIAN_LAB",
701 "Archive directory: $MAEMIAN_ARCHIVEDIR",
702 "Distribution: $MAEMIAN_DIST",
703 "Default unpack level: $MAEMIAN_UNPACK_LEVEL",
704 "Architecture: $MAEMIAN_ARCH",
708 my @l_secs = read_dpkg_control("$MAEMIAN_ROOT/checks/maemian.desc");
710 map { $_->{'script'} = 'maemian'; Tags::add_tag($_) } @l_secs;
712 $Tags::show_experimental = $display_experimentaltags;
713 $Tags::show_pedantic = $display_pedantictags;
714 $Tags::show_overrides = $show_overrides;
715 %Tags::display_level = %display_level;
716 %Tags::display_source = %display_source;
717 %Tags::only_issue_tags = map { $_ => 1 } (split(/,/, $check_tags))
719 if defined $check_tags;
721 use vars qw(%source_info %binary_info %udeb_info); # from the above
723 # Set up clean-up handlers.
724 undef $cleanup_filename;
725 $SIG{'INT'} = \&interrupted;
726 $SIG{'QUIT'} = \&interrupted;
730 # {{{ Create/Maintain Lab and add any specified Debian Archives (*.debs)
732 $LAB = new Lab( $MAEMIAN_LAB, $MAEMIAN_DIST );
734 #######################################
736 if ($action eq 'setup-lab') {
737 if ($#ARGV+1 > 0) { # Cannot define Lab on the command line.
738 warning("ignoring additional command line arguments");
742 or fail("There was an error while setting up the static lab.");
746 #######################################
748 } elsif ($action eq 'remove-lab') {
750 warning("ignoring additional command line arguments");
753 $LAB->delete_static()
754 or fail("There was an error while removing the static lab.");
758 #######################################
759 # Check for non deb specific actions
760 } elsif (not (($action eq 'unpack') or ($action eq 'check')
761 or ($action eq 'remove'))) {
762 fail("bad action $action specified");
766 fail("maemian lab has not been set up correctly (perhaps you forgot to run maemian --setup-lab?)")
767 unless $LAB->is_lab();
769 #XXX: There has to be a cleaner way to do this
770 $MAEMIAN_LAB = $LAB->{dir};
774 # {{{ Compile list of files to process
776 $schedule = new Maemian::Schedule(verbose => $verbose);
777 # process package/file arguments
778 while (my $arg = shift) {
781 # $arg contains absolute dir spec?
782 unless ($arg =~ m,^/,) {
787 if ($arg =~ /\.deb$/) {
788 $schedule->add_deb('b', $arg)
789 or warning("$arg is a zero-byte file, skipping");
792 elsif ($arg =~ /\.udeb$/) {
793 $schedule->add_deb('u', $arg)
794 or warning("$arg is a zero-byte file, skipping");
797 elsif ($arg =~ /\.dsc$/) {
798 $schedule->add_dsc($arg)
799 or warning("$arg is a zero-byte file, skipping");
802 elsif ($arg =~ /\.changes$/) {
803 # get directory and filename part of $arg
804 my ($arg_dir, $arg_name) = $arg =~ m,(.*)/([^/]+)$,;
806 v_msg("Processing changes file $arg_name ...");
808 my ($data) = read_dpkg_control($arg);
809 if (not defined $data) {
810 warning("$arg is a zero-byte file, skipping");
813 Tags::set_pkg( $arg, $arg_name, "", "", 'binary' );
815 # If we don't have a Format key, something went seriously wrong.
816 # Tag the file and skip remaining processing.
817 if (!$data->{'format'}) {
818 tag('malformed-changes-file');
822 # Description is mandated by dak, but only makes sense if binary
823 # packages are included. Don't tag pure source uploads.
824 if (!$data->{'description'} && $data->{'architecture'} ne 'source') {
825 tag("no-description-in-changes-file");
828 # check distribution field
829 if (defined $data->{distribution}) {
830 my $ubuntu_dists = Maemian::Data->new ('changelog-file/ubuntu-dists');
831 my $ubuntu_regex = join('|', $ubuntu_dists->all);
832 my @distributions = split /\s+/o, $data->{distribution};
833 for my $distribution (@distributions) {
834 if ($distribution eq 'UNRELEASED') {
836 } elsif ($data->{version} =~ /ubuntu|$ubuntu_regex/
837 or $distribution =~ /$ubuntu_regex/) {
838 if ($distribution !~ /^($ubuntu_regex)(-(proposed|updates|backports|security))?$/ ) {
839 tag("bad-ubuntu-distribution-in-changes-file",
842 } elsif (! (($distribution eq 'oldstable')
843 or ($distribution eq 'stable')
844 or ($distribution eq 'testing')
845 or ($distribution eq 'unstable')
846 or ($distribution eq 'experimental')
847 or ($distribution =~ /^\w+-backports$/)
848 or ($distribution =~ /^\w+-proposed-updates$/)
849 or ($distribution =~ /^\w+-security$/))
851 # bad distribution entry
852 tag("bad-distribution-in-changes-file",
857 if ($#distributions > 0) {
858 # Currently disabled until dak stops accepting the syntax
859 # tag("multiple-distributions-in-changes-file",
860 # $data->{'distribution'});
864 # Urgency is only recommended by Policy.
865 if (!$data->{'urgency'}) {
866 tag("no-urgency-in-changes-file");
868 my $urgency = lc $data->{'urgency'};
870 unless ($urgency =~ /^(low|medium|high|critical|emergency)$/i) {
871 tag("bad-urgency-in-changes-file", $data->{'urgency'});
875 # Changed-By is optional in Policy, but if set, must be
876 # syntactically correct. It's also used by dak.
877 if ($data->{'changed-by'}) {
878 check_maintainer($data->{'changed-by'}, 'changed-by');
881 # process all listed `files:'
884 my $file_list = $data->{files} || '';
885 for ( split /\n/, $file_list ) {
890 my ($md5sum,$size,$section,$priority,$file) = split(/\s+/o, $_);
891 $files{$file}{md5} = $md5sum;
892 $files{$file}{size} = $size;
895 if (($section eq 'non-free') or ($section eq 'contrib')) {
896 tag( "bad-section-in-changes-file", $file, $section );
901 foreach my $alg (qw(sha1 sha256)) {
902 my $list = $data->{"checksums-$alg"} || '';
903 for ( split /\n/, $list ) {
908 my ($checksum,$size,$file) = split(/\s+/o, $_);
909 $files{$file}{$alg} = $checksum;
910 if ($files{$file}{size} != $size) {
911 tag( "file-size-mismatch-in-changes-file", $file,
912 "$files{$file}{size} != $size" );
918 foreach my $file (keys %files) {
919 my $filename = $arg_dir . '/' . $file;
922 if (not -f $filename) {
923 warning("$file does not exist, exiting");
927 if ($size ne $files{$file}{size}) {
928 tag( "file-size-mismatch-in-changes-file", $file,
929 "$files{$file}{size} != $size");
933 if ($check_checksums or $file =~ /\.dsc$/) {
934 foreach my $alg (qw(md5 sha1 sha256)) {
935 next unless exists $files{$file}{$alg};
937 my $real_checksum = get_file_checksum($alg, $filename);
939 if ($real_checksum ne $files{$file}{$alg}) {
940 tag( "checksum-mismatch-in-changes-file", $alg, $file );
946 if ($file =~ /\.dsc$/) {
947 $schedule->add_dsc($filename);
948 } elsif ($file =~ /\.deb$/) {
949 $schedule->add_deb('b', $filename);
950 } elsif ($file =~ /\.udeb$/) {
951 $schedule->add_deb('u', $filename);
955 unless ($exit_code) {
956 my $stats = Tags::get_stats( $arg );
957 if ($stats->{types}{E}) {
959 } elsif ($fail_on_warnings && $stats->{types}{W}) {
965 fail("bad package file name $arg (neither .deb, .udeb or .dsc file)");
968 # parameter is a package name--so look it up
969 # search the distribution first, then the lab
970 # special case: search only in lab if action is `remove'
973 if ($action eq 'remove') {
974 # search only in lab--see below
977 # search in dist, then in lab
978 $search = 'dist or lab';
983 read_src_list("$MAEMIAN_LAB/info/source-packages", 0);
984 read_bin_list("$MAEMIAN_LAB/info/binary-packages", 0);
985 read_udeb_list("$MAEMIAN_LAB/info/udeb-packages", 0);
987 if (($pkg_mode eq 'b') or ($pkg_mode eq 'a')) {
988 if ($binary_info{$arg}) {
989 $schedule->add_file('b', "$MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}",
990 %{$binary_info{$arg}});
994 if (($pkg_mode eq 'u') or ($pkg_mode eq 'a')) {
995 if ($udeb_info{$arg}) {
996 $schedule->add_file('u', "$MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}",
997 %{$udeb_info{$arg}});
1001 if (($pkg_mode eq 's') or ($pkg_mode eq 'a')) {
1002 if ($source_info{$arg}) {
1003 $schedule->add_file('s', "$MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}",
1004 %{$source_info{$arg}});
1012 # nothing found so far, so search the lab
1014 my $b = "$MAEMIAN_LAB/binary/$arg";
1015 my $s = "$MAEMIAN_LAB/source/$arg";
1016 my $u = "$MAEMIAN_LAB/udeb/$arg";
1018 if ($pkg_mode eq 'b') {
1020 warn "error: cannot find binary package $arg in $search (skipping)\n";
1024 } elsif ($pkg_mode eq 's') {
1026 warning("cannot find source package $arg in $search (skipping)");
1030 } elsif ($pkg_mode eq 'u') {
1032 warning("cannot find udeb package $arg in $search (skipping)");
1038 unless (-d $b or -d $s or -d $u) {
1039 warning("cannot find binary, udeb or source package $arg in $search (skipping)");
1045 if (($pkg_mode eq 'b') or (($pkg_mode eq 'a') and (-d $b))) {
1046 $schedule->add_file('b', get_bin_info_from_lab($b));
1048 if (($pkg_mode eq 's') or (($pkg_mode eq 'a') and (-d $s))) {
1049 $schedule->add_file('s', get_src_info_from_lab($s));
1051 if (($pkg_mode eq 'u') or (($pkg_mode eq 'a') and (-d $u))) {
1052 $schedule->add_file('u', get_bin_info_from_lab($u));
1057 if (not $check_everything and not $packages_file and not $schedule->count) {
1058 v_msg("No packages selected.");
1062 # Check to make sure there are packages to check.
1064 my ($f,$target,$field,$source,$required) = @_;
1066 # print map { Dump($_) } @_;
1067 if ($required and not $source->{$field}) {
1068 print Dump($f)."\n";
1069 fail("description file $f does not define required tag $field");
1071 $target->{$field} = $source->{$field};
1072 delete $source->{$field};
1075 opendir(COLLDIR, "$MAEMIAN_ROOT/collection")
1076 or fail("cannot read directory $MAEMIAN_ROOT/collection");
1078 for my $f (readdir COLLDIR) {
1079 next if $f =~ /^\./;
1080 next unless $f =~ /\.desc$/;
1082 debug_msg(2, "Reading collector description file $f ...");
1083 my @secs = read_dpkg_control("$MAEMIAN_ROOT/collection/$f");
1086 or fail("syntax error in description file $f: too many sections");
1088 ($script = $secs[0]->{'collector-script'})
1089 or fail("error in description file $f: `Collector-Script:' not defined");
1091 delete $secs[0]->{'collector-script'};
1092 $collection_info{$script}->{'script'} = $script;
1093 my $p = $collection_info{$script};
1095 set_value($f, $p,'type',$secs[0],1);
1097 my ($b,$s,$u) = ( "", "", "" );;
1098 for (split(/\s*,\s*/o,$p->{'type'})) {
1099 if ($_ eq 'binary') {
1101 } elsif ($_ eq 'source') {
1103 } elsif ($_ eq 'udeb') {
1106 fail("unknown type $_ specified in description file $f");
1109 $p->{'type'} = "$s$b$u";
1111 set_value($f,$p,'unpack-level',$secs[0],1);
1112 set_value($f,$p,'order',$secs[0],1);
1113 set_value($f,$p,'version',$secs[0],1);
1115 if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
1116 for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
1119 delete $secs[0]->{'needs-info'};
1122 # ignore Info: and other fields for now
1123 delete $secs[0]->{'info'};
1124 delete $secs[0]->{'author'};
1126 for (keys %{$secs[0]}) {
1127 warning("unused tag $_ in description file $f");
1130 debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));
1136 # {{{ Now we're ready to load info about checks & tags
1138 # load information about checker scripts
1139 opendir(CHECKDIR, "$MAEMIAN_ROOT/checks")
1140 or fail("cannot read directory $MAEMIAN_ROOT/checks");
1142 for my $f (readdir CHECKDIR) {
1143 next if $f =~ /^\./;
1144 next unless $f =~ /\.desc$/;
1145 debug_msg(2, "Reading checker description file $f ...");
1147 my @secs = read_dpkg_control("$MAEMIAN_ROOT/checks/$f");
1149 ($script = $secs[0]->{'check-script'})
1150 or fail("error in description file $f: `Check-Script:' not defined");
1152 # ignore check `maemian' (this check is a special case and contains the
1153 # tag info for the maemian frontend--this script here)
1154 next if $script eq 'maemian';
1156 delete $secs[0]->{'check-script'};
1157 $check_info{$script}->{'script'} = $script;
1158 my $p = $check_info{$script};
1160 set_value($f,$p,'type',$secs[0],1);
1162 my ($b,$s,$u) = ( "", "", "" );
1163 for (split(/\s*,\s*/o,$p->{'type'})) {
1164 if ($_ eq 'binary') {
1166 } elsif ($_ eq 'source') {
1168 } elsif ($_ eq 'udeb') {
1171 fail("unknown type $_ specified in description file $f");
1174 $p->{'type'} = "$s$b$u";
1176 set_value($f,$p,'unpack-level',$secs[0],1);
1177 set_value($f,$p,'abbrev',$secs[0],1);
1179 if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
1180 for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
1183 delete $secs[0]->{'needs-info'};
1186 # ignore Info: and other fields for now...
1187 delete $secs[0]->{'info'};
1188 delete $secs[0]->{'standards-version'};
1189 delete $secs[0]->{'author'};
1191 for (keys %{$secs[0]}) {
1192 warning("unused tag $_ in description file $f");
1195 debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));
1198 $p->{'requested-tags'} = 0;
1199 foreach my $tag (@secs) {
1200 $tag->{'script'} = $script;
1201 Tags::add_tag($tag);
1202 $p->{'requested-tags'}++ if Tags::display_tag($tag);
1210 # {{{ Again some lone code the author just dumped where his cursor just happened to be
1212 # determine which info has been requested
1213 for my $i (split(/,/,$unpack_info)) {
1214 unless ($collection_info{$i}) {
1215 fail("unknown info specified: $i");
1217 $unpack_infos{$i} = 1;
1221 # create check_abbrev hash
1222 for my $c (keys %check_info) {
1223 $check_abbrev{$check_info{$c}->{'abbrev'}} = $c;
1228 # {{{ determine which checks have been requested
1229 if ($action eq 'check') {
1231 foreach my $t (split(/,/, $check_tags)) {
1232 my $info = Tags::get_tag_info($t);
1234 fail("unknown tag specified: $t") unless defined($info);
1235 my $script = $info->{'script'};
1236 next if $script eq 'maemian';
1237 if ($check_info{$script}) {
1238 $checks{$script} = 1;
1240 # should never happen
1241 fail("no info for script $script");
1245 my %dont_check = map { $_ => 1 } (split m/,/, ($dont_check || ""));
1246 $checks or ($checks = join(',',keys %check_info));
1247 for my $c (split(/,/,$checks)) {
1248 if ($check_info{$c}) {
1250 || ($check_info{$c}->{'abbrev'}
1251 && $dont_check{$check_info{$c}->{'abbrev'}})) {
1252 #user requested not to run this check
1253 } elsif ($check_info{$c}->{'requested-tags'} == 0) {
1254 #no need to run this check, no tags will be issued
1258 } elsif (exists $check_abbrev{$c}) {
1259 #abbrevs only used when -C is given, so we don't need %dont_check
1260 $checks{$check_abbrev{$c}} = 1;
1262 fail("unknown check specified: $c");
1267 # determine which info is needed by the checks
1268 for my $c (keys %checks) {
1269 for my $i (keys %collection_info) {
1271 if ($check_info{$c}->{$i}) {
1272 $unpack_infos{$i} = 1;
1280 # {{{ determine which info is needed by the collection scripts
1281 for my $c (keys %unpack_infos) {
1282 for my $i (keys %collection_info) {
1284 if ($collection_info{$c}->{$i}) {
1285 $unpack_infos{$i} = 1;
1291 # {{{ process all packages in the archive?
1292 if ($check_everything) {
1293 # make sure package info is available
1294 read_src_list("$MAEMIAN_LAB/info/source-packages", 0);
1295 read_bin_list("$MAEMIAN_LAB/info/binary-packages", 0);
1296 read_udeb_list("$MAEMIAN_LAB/info/udeb-packages", 0);
1298 debug_msg(2, "pkg_mode = $pkg_mode");
1300 if (($pkg_mode eq 'a') or ($pkg_mode eq 's')) {
1301 for my $arg (sort keys %source_info) {
1302 debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}");
1303 $schedule->add_file('s', "$MAEMIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}",
1304 %{$source_info{$arg}});
1307 if (($pkg_mode eq 'a') or ($pkg_mode eq 'b')) {
1308 for my $arg (sort keys %binary_info) {
1309 debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}");
1310 $schedule->add_file('b', "$MAEMIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}",
1311 %{$binary_info{$arg}});
1314 if (($pkg_mode eq 'a') or ($pkg_mode eq 'u')) {
1315 for my $arg (sort keys %udeb_info) {
1316 debug_msg(1, "doing stuff with $MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}");
1317 $schedule->add_file('u', "$MAEMIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}",
1318 %{$udeb_info{$arg}});
1322 # package list still empty?
1323 unless ($schedule->count) {
1324 warning("no packages found in distribution directory");
1326 } elsif ($packages_file) { # process all packages listed in packages file?
1327 $schedule->add_pkg_list($packages_file);
1331 # {{{ Some silent exit
1332 unless ($schedule->count) {
1333 v_msg("No packages selected.");
1338 # {{{ Okay, now really processing the packages in one huge loop
1339 $unpack_infos{ "override-file" } = 1 unless $no_override;
1340 v_msg(sprintf("Processing %d packages...", $schedule->count));
1342 "Selected action: $action",
1343 "Requested unpack level: $unpack_level",
1344 sprintf("Requested data to collect: %s", join(',',keys %unpack_infos)),
1345 sprintf("Selected checks: %s", join(',',keys %checks)),
1349 require Maemian::Collect;
1354 foreach my $pkg_info ($schedule->get_all) {
1355 my ($type, $pkg, $ver, $arch, $file) =
1356 @$pkg_info{qw(type package version architecture file)};
1357 my $long_type = ($type eq 'b' ? 'binary' :
1358 ($type eq 's' ? 'source' : 'udeb' ));
1360 Tags::set_pkg( $file, $pkg, $ver, $arch, $long_type );
1362 # Kill pending jobs, if any
1363 Maemian::Command::kill(@pending_jobs);
1364 undef @pending_jobs;
1366 # determine base directory
1367 my $base = "$MAEMIAN_LAB/$long_type/$pkg";
1368 unless ($base =~ m,^/,) {
1369 $base = "$cwd/$base";
1371 debug_msg(1, "Base directory in lab: $base");
1373 my $act_unpack_level = 0;
1375 # unpacked package up-to-date?
1377 my $remove_basedir = 0;
1379 # there's a base dir, so we assume that at least
1380 # one level of unpacking has been done
1381 $act_unpack_level = 1;
1383 # maemian status file exists?
1384 unless (-f "$base/.maemian-status") {
1385 v_msg("No maemian status file found (removing old directory in lab)");
1386 $remove_basedir = 1;
1387 goto REMOVE_BASEDIR;
1390 # read unpack status -- catch any possible errors
1392 eval { ($data) = read_dpkg_control("$base/.maemian-status"); };
1395 $remove_basedir = 1;
1396 goto REMOVE_BASEDIR;
1399 # compatible maemian version?
1400 if (not exists $data->{'lab-format'} or ($data->{'lab-format'} < $LAB_FORMAT)) {
1401 v_msg("Lab directory was created by incompatible maemian version");
1402 $remove_basedir = 1;
1403 goto REMOVE_BASEDIR;
1406 # version up to date?
1407 if (not exists $data->{'version'} or ($data->{'version'} ne $ver)) {
1408 debug_msg(1, "Removing package in lab (newer version exists) ...");
1409 $remove_basedir = 1;
1410 goto REMOVE_BASEDIR;
1413 # unpack level defined?
1414 unless (exists $data->{'unpack-level'}) {
1415 warning("cannot determine unpack-level of package");
1416 $remove_basedir = 1;
1417 goto REMOVE_BASEDIR;
1419 $act_unpack_level = $data->{'unpack-level'};
1425 unless (@stat = stat $file) {
1426 warning("cannot stat file $file: $!");
1428 $timestamp = $stat[9];
1430 if ((not defined $timestamp) or (not exists $data->{'timestamp'}) or ($data->{'timestamp'} != $timestamp)) {
1431 debug_msg(1, "Removing package in lab (package has been changed) ...");
1432 $remove_basedir = 1;
1433 goto REMOVE_BASEDIR;
1437 if ($remove_basedir) {
1438 v_msg("Removing $pkg");
1439 unless (remove_pkg($base)) {
1440 warning("skipping $action of $long_type package $pkg");
1444 $act_unpack_level = 0;
1448 # unpack to requested unpack level
1449 $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,
1451 if ($act_unpack_level == -1) {
1452 warning("could not unpack package to desired level",
1453 "skipping $action of $long_type package $pkg");
1458 if (($action eq 'unpack') or ($action eq 'check')) { # collect info
1459 my $current_order = -1;
1460 for my $coll (sort by_collection_order keys %unpack_infos) {
1461 my $ci = $collection_info{$coll};
1462 my %run_opts = ('description' => $coll);
1465 next unless ($ci->{'type'} =~ m/$type/);
1467 # If a file named .SCRIPT-VERSION already exists, we've already
1468 # collected this information and we can skip it. Otherwise,
1469 # remove any .SCRIPT-* files (which are old version information).
1470 next if (-f "$base/.${coll}-$ci->{'version'}");
1471 opendir(BASE, $base)
1472 or fail("cannot read directory $base: $!");
1473 for my $file (readdir BASE) {
1474 if ($file =~ /^\.\Q$coll-/) {
1475 unlink("$base/$file");
1480 # unpack to desired unpack level (if necessary)
1481 $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
1482 if ($act_unpack_level == -1) {
1483 warning("could not unpack package to desired level",
1484 "skipping $action of $long_type package $pkg");
1489 # chdir to base directory
1490 unless (chdir($base)) {
1491 warning("could not chdir into directory $base: $!",
1492 "skipping $action of $long_type package $pkg");
1497 $current_order = $ci->{'order'} if ($current_order == -1);
1498 if ($current_order != $ci->{'order'}) {
1499 debug_msg(1, "Waiting for jobs from order $current_order ...");
1500 unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
1501 warning("skipping $action of $long_type package $pkg");
1505 undef @pending_jobs;
1506 $current_order = $ci->{'order'};
1510 remove_status_file($base);
1511 debug_msg(1, "Collecting info: $coll ...");
1512 my $script = "$MAEMIAN_ROOT/collection/$ci->{'script'}";
1513 unless (spawn(\%run_opts, [ $script, $pkg, $long_type, '&' ])) {
1514 warning("collect info $coll about package $pkg failed",
1515 "skipping $action of $long_type package $pkg");
1519 push @pending_jobs, \%run_opts;
1522 # wait until all the jobs finish and skip this package if any of them
1524 debug_msg(1, "Waiting for jobs from order $current_order ...");
1525 unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
1526 warning("skipping $action of $long_type package $pkg");
1530 undef @pending_jobs;
1533 if ($action eq 'check') { # read override file
1535 unless ($no_override) {
1536 Tags::add_overrides("$base/override", $pkg, $long_type)
1537 if (-f "$base/override")
1541 my $info = Maemian::Collect->new($pkg, $long_type);
1542 for my $check (keys %checks) {
1543 my $ci = $check_info{$check};
1546 next unless ($ci->{'type'} =~ m/$type/);
1548 # unpack to desired unpack level (if necessary)
1549 $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
1550 if ($act_unpack_level == -1) {
1551 warning("could not unpack package to desired level",
1552 "skipping $action of $long_type package $pkg");
1557 # chdir to base directory
1558 unless (chdir($base)) {
1559 warning("could not chdir into directory $base: $!",
1560 "skipping $action of $long_type package $pkg");
1565 my $returnvalue = Checker::runcheck($pkg, $long_type, $info, $check);
1566 # Set exit_code correctly if there was not yet an exit code
1567 $exit_code = $returnvalue unless $exit_code;
1569 if ($returnvalue == 2) {
1570 warning("skipping $action of $long_type package $pkg");
1575 unless ($exit_code) {
1576 my $stats = Tags::get_stats( $file );
1577 if ($stats->{types}{E}) {
1579 } elsif ($fail_on_warnings && $stats->{types}{W}) {
1584 # report unused overrides
1585 if (not $no_override) {
1586 my $overrides = Tags::get_overrides( $file );
1588 for my $tag (sort keys %$overrides) {
1589 my $taginfo = Tags::get_tag_info{$tag};
1590 if (defined $taginfo) {
1591 # Did we run the check script containing the tag?
1592 next unless $checks{$taginfo->{'script'}};
1594 # If only checking specific tags, is this one of them?
1595 next unless (scalar keys %Tags::only_issue_tags == 0)
1596 or exists $Tags::only_issue_tags{$tag};
1599 for my $extra (sort keys %{$overrides->{$tag}}) {
1600 next if $overrides->{$tag}{$extra};
1602 tag( "unused-override", $tag, $extra );
1607 # Report override statistics.
1608 if (not $no_override and not $show_overrides) {
1609 my $stats = Tags::get_stats($file);
1612 my $errors = $stats->{overrides}{types}{E} || 0;
1613 my $warnings = $stats->{overrides}{types}{W} || 0;
1614 my $info = $stats->{overrides}{types}{I} || 0;
1615 $overrides{errors} += $errors;
1616 $overrides{warnings} += $warnings;
1617 $overrides{info} += $info;
1621 # chdir to maemian root directory (to unlock $base so it can be removed below)
1622 unless (chdir($MAEMIAN_ROOT)) {
1623 warning("could not chdir into directory $MAEMIAN_ROOT: $!",
1624 "skipping $action of $long_type package $pkg");
1630 if ($act_unpack_level > $unpack_level) {
1631 $act_unpack_level = clean_pkg($type,$base,$file,$act_unpack_level,$unpack_level);
1632 if ($act_unpack_level == -1) {
1633 warning("could not clean up laboratory for package $pkg: $!",
1634 "skipping clean up");
1640 # create Maemian status file
1641 if (($act_unpack_level > 0) and (not -f "$base/.maemian-status")) {
1643 unless (@stat = stat $file) {
1644 warning("cannot stat file $file: $!",
1645 "skipping creation of status file");
1649 my $timestamp = $stat[9];
1651 unless (open(STATUS, '>', "$base/.maemian-status")) {
1652 warning("could not create status file $base/.maemian-status for package $pkg: $!");
1657 print STATUS "Maemian-Version: $MAEMIAN_VERSION\n";
1658 print STATUS "Lab-Format: $LAB_FORMAT\n";
1659 print STATUS "Package: $pkg\n";
1660 print STATUS "Version: $ver\n";
1661 print STATUS "Type: $type\n";
1662 print STATUS "Unpack-Level: $act_unpack_level\n";
1663 print STATUS "Timestamp: $timestamp\n";
1668 if ($action eq 'check' and not $no_override and not $show_overrides) {
1669 my $errors = $overrides{errors} || 0;
1670 my $warnings = $overrides{warnings} || 0;
1671 my $info = $overrides{info} || 0;
1672 my $total = $errors + $warnings + $info;
1674 my $total = ($total == 1)
1675 ? "$total tag overridden"
1676 : "$total tags overridden";
1679 push (@output, ($errors == 1) ? "$errors error" : "$errors errors");
1682 push (@output, ($warnings == 1) ? "$warnings warning" : "$warnings warnings");
1685 push (@output, "$info info");
1687 msg("$total (". join (', ', @output). ")");
1695 # {{{ Some subroutines
1698 my ($type,$base,$file,$cur_level,$new_level) = @_;
1700 debug_msg(1, sprintf("Current unpack level is %d",$cur_level));
1702 return $cur_level if $cur_level == $new_level;
1704 # remove .maemian-status file
1705 remove_status_file($base);
1707 if ( ($cur_level == 0) and (-d $base) ) {
1708 # We were lied to, there's something already there - clean it up first
1709 remove_pkg($base) or return -1;
1712 if ( ($new_level >= 1) and
1713 (not defined ($cur_level) or ($cur_level < 1)) ) {
1714 # create new directory
1715 debug_msg(1, "Unpacking package to level 1 ...");
1716 if (($type eq 'b') || ($type eq 'u')) {
1717 spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-binpkg-l1", $base, $file])
1720 spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-srcpkg-l1", $base, $file])
1726 if ( ($new_level >= 2) and
1727 (not defined ($cur_level) or ($cur_level < 2)) ) {
1728 # unpack package contents
1729 debug_msg(1, "Unpacking package to level 2 ...");
1730 if (($type eq 'b') || ($type eq 'u')) {
1731 spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-binpkg-l2", $base])
1734 debug_msg(1, "$MAEMIAN_ROOT/unpack/unpack-srcpkg-l2 $base");
1735 spawn({}, ["$MAEMIAN_ROOT/unpack/unpack-srcpkg-l2", $base])
1744 # Given a list of jobs corresponding to collect scripts, reap each of the
1745 # jobs. For each successful job, record that it was successful by creating
1746 # the corresponding version marker file in the lab. For each unsuccessful
1747 # job, warn that it was unsuccessful.
1749 # Takes the current package, base directory, and the list of pending jobs.
1750 # Return true if all jobs were successful, false otherwise.
1751 sub reap_collect_jobs {
1752 my ($pkg, $base, @pending_jobs) = @_;
1753 my $status = reap(@pending_jobs);
1754 for my $job (@pending_jobs) {
1755 my $coll = $job->{'description'};
1756 if ($job->{success}) {
1757 my $ci = $collection_info{$coll};
1758 open(VERSION, '>', "$base/.${coll}-$ci->{'version'}")
1759 or fail("cannot create $base/.${coll}-$ci->{'version'}: $!");
1760 print VERSION "Maemian-Version: $MAEMIAN_VERSION\n"
1761 . "Timestamp: " . time . "\n";
1764 warning("collect info $coll about package $pkg failed");
1770 # TODO: is this the best way to clean dirs in perl?
1771 # no, look at File::Path module
1773 my ($type,$base,$file,$cur_level,$new_level) = @_;
1775 return $cur_level if $cur_level == $new_level;
1777 if ($new_level < 1) {
1778 # remove base directory
1779 remove_pkg($base) or return -1;
1783 if ( ($new_level < 2) and defined ($cur_level) and ($cur_level >= 2) ) {
1784 # remove .maemian-status file
1785 remove_status_file($base);
1787 # remove unpacked/ directory
1788 debug_msg(1, "Decreasing unpack level to 1 (removing files) ...");
1789 if ( -l "$base/unpacked" ) {
1790 delete_dir("$base/".readlink("$base/unpacked"))
1792 delete_dir("$base/unpacked") or return -1;
1794 delete_dir("$base/unpacked") or return -1;
1803 # this function removes a package's base directory in the lab completely
1807 debug_msg(1, "Removing package in lab ...");
1808 unless (delete_dir($base)) {
1809 warning("cannot remove directory $base: $!");
1816 sub remove_status_file {
1819 # status file exists?
1820 if (not -e "$base/.maemian-status") {
1824 if (not unlink("$base/.maemian-status")) {
1825 warning("cannot remove status file $base/.maemian-status: $!");
1832 # get package name, version, and file name from the lab
1833 sub get_bin_info_from_lab {
1834 my ($base_dir) = @_;
1835 my ($pkg,$ver,$arch,$file);
1837 ($pkg = read_file("$base_dir/fields/package"))
1838 or fail("cannot read file $base_dir/fields/package: $!");
1840 ($ver = read_file("$base_dir/fields/version"))
1841 or fail("cannot read file $base_dir/fields/version: $!");
1843 ($arch = read_file("$base_dir/fields/architecture"))
1844 or fail("cannot read file $base_dir/fields/architecture: $!");
1846 ($file = readlink("$base_dir/deb"))
1847 or fail("cannot read link $base_dir/deb: $!");
1849 return ($file, package => $pkg, version => $ver, architecture => $arch);
1852 # get package name, version, and file name from the lab
1853 sub get_src_info_from_lab {
1854 my ($base_dir) = @_;
1855 my ($pkg,$ver,$file);
1857 ($pkg = read_file("$base_dir/fields/source"))
1858 or fail("cannot read file $base_dir/fields/source: $!");
1860 ($ver = read_file("$base_dir/fields/version"))
1861 or fail("cannot read file $base_dir/fields/version: $!");
1863 ($file = readlink("$base_dir/dsc"))
1864 or fail("cannot read link $base_dir/dsc: $!");
1866 return ($file, source => $pkg, version => $ver);
1869 # read first line of a file
1873 open(T, '<', $_[0]) or return;
1874 chop($first_line = <T>);
1880 # sort collection list by `order'
1881 sub by_collection_order {
1882 $collection_info{$a}->{'order'} <=> $collection_info{$b}->{'order'};
1886 # Prevent Lab::delete from affecting the exit code.
1889 $SIG{'INT'} = 'DEFAULT';
1890 $SIG{'QUIT'} = 'DEFAULT';
1892 $LAB->delete() if $LAB and not $keep_lab;
1896 $SIG{$_[0]} = 'DEFAULT';
1897 die "N: Interrupted.\n";