#! /usr/bin/perl
require
5.6.1;
use
Cwd 2.04
qw(fastcwd)
;
use
File::Glob 0.991
qw(bsd_glob GLOB_QUOTE GLOB_BRACE)
;
no
strict
qw(refs)
;
sub
usage {
print
STDERR
<<"EOF";
Usage: debarnacle [ -v VERBOSITY | -C CONFIGDIR | -c CACHESIZE | -d | -p | -q | -h ][ ROOT ]
-d: do not process filenames from packages
-p: do not process filenames from plugins
-q: be quiet (overrides -v)
-h: print this summary and exit
EOF
exit
2;
}
our
$opt_v
= 1;
our
$opt_C
=
''
;
our
$opt_q
= 0;
our
$opt_d
= 0;
our
$opt_p
= 0;
our
$opt_c
= 0;
our
$opt_h
= 0;
our
$root
=
'/'
;
getopts(
'dpqv:C:c:h'
) or usage;
usage
if
$opt_h
;
scalar
(
@ARGV
) < 2 or usage;
$root
=
$ARGV
[0]
if
$ARGV
[0];
$opt_v
= 0
if
$opt_q
;
our
$pkgconfdir
=
$opt_C
||
"//etc///debarnacle"
;
our
@dpkg_lists
= bsd_glob(
"/var/lib/dpkg/info/*.list"
);
if
(!
$opt_c
) {
$DB_BTREE
->{cachesize} = 2000 *
scalar
@dpkg_lists
;
}
else
{
$DB_BTREE
->{cachesize} =
$opt_c
;
}
sub
chomped_date {
my
$date
= `date`;
chomp
$date
;
return
$date
;
}
our
$dbname
;
$SIG
{
'INT'
} =
$SIG
{
'HUP'
} =
$SIG
{
'TERM'
} =
sub
{
unlink
$dbname
if
$dbname
;
exit
1; };
$dbname
= `tempfile --directory /var/tmp`;
chomp
$dbname
;
our
%filez
;
tie
(
%filez
,
'DB_File'
,
$dbname
, O_RDWR|O_CREAT, 0600,
$DB_BTREE
)
or
die
"can't tie DB_File: $!"
;
our
$fh_prune
= FileHandle->new(
"<$pkgconfdir/prune"
);
defined
$fh_prune
or
die
"can't open $pkgconfdir/prune: $!"
;
our
%prunes
= ();
PRUNE:
while
(
my
$prune
=
$fh_prune
->getline()) {
next
PRUNE
if
$prune
=~ /^ *\
next
PRUNE
if
$prune
=~ /^ *$/;
chomp
$prune
;
$prunes
{
$prune
} = 1;
}
sub
enter_file {
$filez
{
$File::Find::name
} =
'?'
;
$File::Find::prune
= 1
if
$prunes
{
$File::Find::name
};
}
our
%canonical_dirs
= ();
our
$last_dir
=
''
;
our
$last_canonical
=
''
;
sub
canonical {
my
$f
=
$_
[0];
return
'/'
if
$f
eq
'/.'
;
$f
=~ m:^/((.*)/)?([^/]*)$: ;
my
$dir
=
'/'
. ($2 ||
''
);
my
$base
= $3;
return
"/$base"
if
$dir
eq
'/'
;
return
"$last_canonical/$base"
if
$dir
eq
$last_dir
;
$last_dir
=
$dir
;
$last_canonical
=
$canonical_dirs
{
$dir
};
if
(!
defined
$last_canonical
) {
chdir
$dir
;
$canonical_dirs
{
$dir
} =
$last_canonical
= fastcwd;
}
return
"$last_canonical/$base"
;
}
sub
explain {
my
(
$reason
,
$list
) =
@_
;
foreach
my
$f
(@{
$list
}) {
$f
= canonical
$f
;
my
$current
=
$filez
{
$f
};
my
$new_val
=
'!'
;
$current
=
$new_val
=
"?$reason"
if
!
defined
$current
;
$filez
{
$f
} =
$new_val
if
$current
=~ /^\?/;
}
}
print
STDERR (
&chomped_date
(),
" Listing exisiting files\n"
)
if
$opt_v
> 0;
find(\
&enter_file
,
$root
);
print
STDERR (
&chomped_date
(),
" Adding globs\n"
)
if
$opt_v
> 1;
our
$fh_globs
= FileHandle->new(
"<$pkgconfdir/globs"
);
defined
$fh_globs
or
die
"can't open $pkgconfdir/globs: $!"
;
GLOB_LINE:
while
(
my
$glob_line
=
$fh_globs
->getline()) {
next
GLOB_LINE
if
$glob_line
=~ /^\s*\
next
GLOB_LINE
if
$glob_line
=~ /^\s*$/ ;
chomp
$glob_line
;
foreach
my
$f
(bsd_glob(
$glob_line
,
&GLOB_BRACE
|
&GLOB_QUOTE
)) {
$filez
{
$f
} =
'?'
;
}
}
$fh_globs
->
close
();
if
(!
$opt_d
) {
print
STDERR (
&chomped_date
(),
" Processing files in packages\n"
)
if
$opt_v
> 0;
foreach
my
$nextlist
(
@dpkg_lists
) {
my
@pkgfiles
= ();
$nextlist
=~ s:.*/([^/]*)\.list$:$1: ;
print
STDERR (
&chomped_date
(),
" Processing package $nextlist\n"
)
if
$opt_v
> 1;
foreach
my
$pkgfile
qw (list
conffiles postinst postrm preinst prerm shlibs md5sums config templates) {
my
$fullpkgfile
=
"/var/lib/dpkg/info/$nextlist.$pkgfile"
;
push
@pkgfiles
,
$fullpkgfile
if
-f
$fullpkgfile
;
}
my
$fh_list
= FileHandle->new(
"</var/lib/dpkg/info/$nextlist.list"
);
defined
$fh_list
or
die
"can't list package $nextlist: $!"
;
while
(
my
$pkgfile
=
$fh_list
->getline()) {
chop
$pkgfile
;
push
@pkgfiles
,
$pkgfile
;
}
$fh_list
->
close
();
&explain
(
"dpkg: $nextlist"
, \
@pkgfiles
);
}
}
if
(!
$opt_p
) {
print
STDERR (
&chomped_date
(),
" Processing file lists from plugins\n"
)
if
$opt_v
> 0;
our
$dh_plugins
= DirHandle->new(
"$pkgconfdir/plugin.d"
);
defined
$dh_plugins
or
die
"can't open $pkgconfdir/plugin.d: $!"
;
PLUGIN:
while
(
my
$plugin
=
$dh_plugins
->
read
()) {
next
PLUGIN
if
$plugin
!~ /^[A-Z][-_a-zA-Z0-9]*\.pm$/;
print
STDERR (
&chomped_date
(),
" Processing plugin $plugin\n"
)
if
$opt_v
> 1;
require
"$pkgconfdir/plugin.d/$plugin"
;
$plugin
=~ s/\.pm$// ;
my
$plug_list
= &{
"Debian::Debarnacle::${plugin}::get_list"
}();
&explain
(
"plugin: $plugin"
,
$plug_list
);
}
$dh_plugins
->
close
();
}
print
STDERR (
&chomped_date
(),
" Generating report\n"
)
if
$opt_v
> 0;
REPORT:
while
(
my
(
$name
,
$expl
) =
each
%filez
) {
next
REPORT
unless
$expl
=~ /^\?/;
if
(
length
$expl
== 1) {
print
"$name: unexplained\n"
;
}
else
{
print
"$name: missing for "
;
print
substr
(
$expl
, 1);
print
"\n"
;
}
}
END {
unlink
$dbname
if
$dbname
; }
no
warnings
qw(digit)
;
our
$VERSION
=
'$Date: 2002/05/15 19:41:18 $ '
;
$VERSION
=~ s|^\
$Date
:\s*([0-9]{4})/([0-9]{2})/([0-9]{2})\s.*|\1.\2.\3| ;