path: root/distriblint

#!/usr/bin/perl

#- Mandrakelinux Distribution Checker.
#- Copyright (C) 2002 MandrakeSoft (fpons@mandrakesoft.com)
#-
#- This program is free software; you can redistribute it and/or modify
#- it under the terms of the GNU General Public License as published by
#- the Free Software Foundation; either version 2, or (at your option)
#- any later version.
#-
#- This program is distributed in the hope that it will be useful,
#- but WITHOUT ANY WARRANTY; without even the implied warranty of
#- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#- GNU General Public License for more details.
#-
#- You should have received a copy of the GNU General Public License
#- along with this program; if not, write to the Free Software
#- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

#- check a whole distribution RPMS, SRPMS, compss and contribs associated :
#-   rpms dependancy check (including provides), script usage.
#-   srpms checking with version.
#-   contrib rpms dependancy check with rpms, script usage.
#-   contrib srpms checkig with version.
#-   compss checking, doublons, packages extension and size.

#- options are :
#-   --distrib         : distribution top directory.
use strict qw(subs vars refs);

#- passtest arrays (contains function for test).
my @passtest = (
		\&pass_get_hdlists,
		\&pass_check_filenames,
		\&pass_check_requires,
	       );

#- pass function for getting all package and simple checking.
sub pass_get_hdlists {
    my ($o) = @_;

    $o->{c}->("parsing hdlists from distrib $o->{root}.");
    local *F;
    open F, "$o->{root}/media/media_info/hdlists" or die "unable to open $o->{root}/media/media_info/hdlists";
    foreach (<F>) {
	chomp;
	s/\s*#.*$//;
	/^\s*$/ and next;
	/^(?:askmedia|suppl)/ and next;
	m/^\s*(?:noauto:)?(hdlist\S*\.cz2?)\s+(\S+)\s*(.*)$/ or die "invalid hdlist description \"$_\" in hdlists file";
	
	push @{$o->{hdlists}}, { synthesis => "$o->{root}/media/media_info/synthesis.$1",
				 hdlist => "$o->{root}/media/media_info/$1",
				 dir => $2,
				 descr => $3 };
    }
    close F;

    foreach (@{$o->{hdlists}}) {
	$o->{c}->("parsing hdlist $_->{hdlist}.");
	($_->{start}, $_->{end}) = $o->parse_hdlist($_->{hdlist});
    }

    $o->{c}->("found " . scalar(@{$o->{depslist}}) . " packages.");

    #- now the real works, check no more than one package is listed.
    #- use provides access to simplify.
    foreach my $pkg (@{$o->{depslist}}) {
	my ($self_found, $name_found) = (0, 0);
	foreach (keys %{$o->{provides}{$pkg->name}}) {
	    my $p = $o->{depslist}[$_];
	    $p == $pkg and ++$self_found;
	    $p->name eq $pkg->name and ++$name_found;
	}
	if ($self_found == 1 && $name_found == 1) {
	    $o->{cok}->();
	} else {
	    $o->{cwarn}->("package ".$pkg->fullname." has same name as other packages.");
	}
    }
}

#- pass function for filenames checking, avoiding doublons of different files.
sub pass_check_filenames {
    my ($o) = @_;

    $o->{c}->("check files of all packages, avoid multiple different definition of files without conflicts.");

    foreach my $pkg (@{$o->{depslist}}) {
	my %files;

	my @files = $pkg->files;
	my @md5sums = $pkg->files_md5sum;
	my @modes = $pkg->files_mode;
	my @sizes = $pkg->files_size;
	my @owners = $pkg->files_owner;
	my @groups = $pkg->files_group;

	foreach (0 .. $#files) {
	    my $file = $files[$_];
	    my $key = join ' ', $md5sums[$_], $modes[$_], $sizes[$_], $owners[$_], $groups[$_];
	    my ($existing_id, $existing_key) = $o->{files}{$file} =~ /([^:]*):(.*)/;
	    if (exists $o->{files}{$file} && $existing_key ne $key) {
		#- check if package is marked as conflicting with this one.
		#- if this is the case, everything is right, else complains...
		my $p = $o->{depslist}[$existing_id];
		my $ok = 0;

		my $provide_p = $p->name." == ".$p->epoch.":".$p->version."-".$p->release;
		foreach ($pkg->conflicts) {
		    URPM::ranges_overlap($provide_p, $_) and $ok = 1, last;
		}

		my $provide_pkg = $pkg->name." == ".$pkg->epoch.":".$pkg->version."-".$pkg->release;
		foreach ($p->conflicts) {
		    URPM::ranges_overlap($provide_pkg, $_) and $ok = 1, last;
		}

		$ok or push @{$files{$p->fullname}}, $file; #- conflicting package name is used.
	    } else {
		$o->{files}{$file} = $pkg->id . ':' . $key unless exists $o->{files}{$file};
	    }
	}
	
	#- print summary informations on conflicts.
	if (%files) {
	    my $s = "conflict between ".$pkg->fullname." ...";
	    foreach (keys %files) {
		my @filenames = @{$files{$_}};
		$s .= "\n        ... and $_ on ". scalar @filenames ." file(s)";
		if (scalar @filenames < 10) {
		    $s .= ":";
		    foreach (@filenames) {
			$s .= "\n          $_";
		    }
		} else {
		    $s .= ".";
		}
	    }
	    $o->{cerr}->($s);
	} else {
	    $o->{cok}->();
	}
    }
}

#- pass function for requires checking, at least one provide should be allowed.
sub pass_check_requires {
    my ($o) = @_;

    $o->{c}->("check requires of all packages, avoid unresolved.");

    foreach my $pkg (@{$o->{depslist}}) {
	foreach ($pkg->requires) {
	    if (my ($property, $name) = /^(([^\s\[]*).*)/) {
		my $ok = 0;
		foreach my $id (keys %{$o->{provides}{$name} || {}}) {
		    my $p = $o->{depslist}[$id];
		    foreach ($p->provides) {
			URPM::ranges_overlap($_, $property) and ++$ok;
		    }
		}
		#- for files, check directly into files created by above test.
		exists $o->{files}{$name} and ++$ok;
		if ($ok) {
		    $o->{cok}->();
		} else {
		    $o->{cerr}->($pkg->fullname." has unresolved require [$property].");
		}
	    } else {
		$o->{cerr}->($pkg->fullname." has non parseable require [$_].");
	    }
	}
    }
}

#- main program.
sub main {
    require URPM;
    my $o = new URPM;
    
    while (@_) {
	local $_ = shift;
	$_ eq '--distrib' and do { $o->{root} = shift; next };
	die "usage: $0 --distrib <d>";
    }
    
    #- perform all tests, $i is used for pass numbering.
    print "Starting tests...";
    my $i = 1;
    foreach (@passtest) {
	my ($count_ok, $count_warn, $count_err) = (0, 0, 0);
	
	$o->{c} = sub { print "\nPASS$i: @_" if @_ };
	$o->{cok} = sub { ++$count_ok; print "\nPASS$i: @_" if @_ };
	$o->{cwarn} = sub { ++$count_warn; print "\nPASS$i: warning: @_" if @_ };
	$o->{cerr} = sub { ++$count_err; print "\nPASS$i: error: @_" if @_ };
	
	eval { &$_($o) };
	if ($@) {
	    $o->{c}->("exiting due to fatal: $@");
	    exit 1;
	}
	if ($count_ok < 0 || $count_warn < 0 || $count_err < 0) {
	    $o->{c}->("fatal test result integrity, exiting.");
	    exit 1;
	}
	$o->{c}->("completed [ok=$count_ok, warn=$count_warn, error=$count_err]\n");
	++$i;
    }
}

#- execute the tests.
main(@ARGV);