status-report-scripts dircheck,NONE,1.1

[Jason Tibbitts (tibbs)]

Author: tibbs

Update of /cvs/fedora/status-report-scripts
In directory cvs-int.fedora.redhat.com:/tmp/cvs-serv7089

Added Files:
	dircheck 
Log Message:
Add first-pass hack to find multiply-owned and unowned directories.



--- NEW FILE dircheck ---
#!/usr/bin/perl -w
#use strict 'vars';
use Getopt::Long;
use XML::Simple;
use XML::Twig;
use Data::Dumper;

my @checkfiles;
my @loadfiles;
our($verbose, $multiply, $unowned);

our %dirs;
our %files;

GetOptions('check=s' => \@checkfiles,
#       'load=s' => \@loadfiles,
       'verbose' => \$verbose,
       'multiplyowned' => \$multiply,
       'unowned' => \$unowned,
);
$|=1 if $verbose;
if (!$multiply && !$unowned) {
	$multiply = $unowned = 1;
}

#TODO:
# Parse filelists.xml.gz directly
# Accept command line args:
#   accept an rpm, get a listing of its files, and check those
#   auto-gzcat files ending in .gz
#   allow a filelists file to be loaded in but have no warnings generated
#   against it.
#     since we know the base distro will always be screwed but we may
#     still want to generate a report against a single package or against
#     another repo.

# Suck in data from the various files
$count = 1;
for $i (@checkfiles) {
	if ($i =~ /(.*):(.*)/) {
		$i = $1; $source = $2;
	}
	else {
		$source = $count if $count > 1;
	}
	print "Loading $i\n" if $verbose;
	open $fp, $i or die "Can't open $i: $!";
	read_xml_regexp($fp, $source);
	close $fp;
	$count++;
}

find_multiply_owned() if $multiply;
find_unowned() if $unowned;

exit 0;

sub find_multiply_owned {
	print "Finding multiply owned directories.\n" if $verbose;
	for $i (keys %dirs) {
		next if $i =~ m!/usr/lib/perl5/vendor_perl/5\..*/!;
		@d = uniq(@{$dirs{$i}});
		if (@d > 1) {
			print "$i is multiply owned:\n";
			for $j (@d) {
				print "\t$j\n";
			}
		}
	}
}

sub find_unowned {
	my($i, $j, $p);
	print "Finding unowned directories.\n" if $verbose;
	for $i (sort(keys %dirs, keys %files)) {
		next if $i eq '/';
		($parent) = $i =~ m!^(.*)/[^/]+$!;
		if (length($parent) && !$dirs{$parent}) {
			if ($files{$parent}) {
				print "Odd, parent directory of $i is a file (maybe a symlink).\n" if $verbose;
				next;
			}
			$unowned{$parent} ||= [];
			push @{$unowned{$parent}}, [$i, (@{$files{$i} || $dirs{$i}})];
		}
	}
	for $i (sort keys %unowned) {
		print "$i is unowned, occupied by:\n";
		for $j (@{$unowned{$i}}) {
			print "\t$j->[0], in package $j->[1]\n";
		}
	}
}

sub read_file_list {
	my ($fp, $source, $package) = @_;
	my (@l, $l);
	while (defined($l = <$fp>)) {
		@l = split(/\s+/, $l);
		if ($l[0] =~ /^d/) {
			print "dir: $l[8]\n";
		}
		else {
			print "file: $l[8]\n";
		}
	}
}

sub read_xml_simple {
	my ($fp, $source) = @_;
	my $kernelseen = 0;
	my ($l, $package, $xml);

	$xml = XMLin($fp, ForceArray => 1);

	for $package (@{$xml->{package}}) {
		print Dumper $package;
		$p = $package->{name}[0];
		$kernelseen++ if $p eq 'kernel';
		$p .= " ($source)" if $source;
	}
}

sub read_xml_twig {
	my ($fp, $source) = @_;
	my $kernelseen = 0;
	my ($l, $package, $xml);

	my $t = XML::Twig->new(twig_roots => { package => \&parse_package });
	print "Parsing." if $verbose;
	$t->parse($fp);
	$t->flush;

	sub parse_package {
		my ($t, $elt) = @_;
		print ".";# if $verbose;
		$p = $elt->att('name');
		$kernelseen++ if $p eq 'kernel';
		$p .= " ($source)" if $source;
		for $i ($elt->children) {
			next unless $i->tag eq 'file';
			$type = $i->att('type') || '';
			if ($type eq 'dir') {
				push @{$dirs{$i->text}}, "$p";
			}
#			else {
#				push @{$files{$i->text}}, $p;
#			}
		}
		$t->purge;
		1;
	};

}

sub read_xml_regexp {
	my ($fp, $source) = @_;
	my $kernelseen = 0;
	my ($l, $p);
	while (defined($l = <$fp>)) {
		@l = split(/(?<=>)\s*(?=<)/, $l);
		for $l (@l) {
			next unless length($l);
			if ($l =~ /package.*name=\"([^\"]+)/) {
				$p = $1;
				$p .= " ($source)" if $source;
				next;
			}
			elsif ($l =~ /file type=\"dir\">([^<]+)/) {
				$dirs{$1} ||= [];
				push @{$dirs{$1}}, $p;
			}
			elsif ($l =~ m!^\s*<file>(.*)</file>$!) {
				$files{$1} ||= [];
				push @{$files{$1}}, $p;
			}
		}
	}
}

sub uniq {
	my %seen;
	grep {!$seen{$_}++} @_;
}