/usr/share/debdelta/debmarshal_list_useless_debs is in debdelta 0.59.
This file is owned by root:root, with mode 0o755.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | #!/usr/bin/perl -w
#
#
# Scan pool and dist directories and snapshots.
# List any deb that is not in a dist.
#
# Copyright 2010 Google Inc. , 2011 A. Mennucci
#
# downloaded from
# http://debmarshal.googlecode.com/svn/trunk/repository2/pooldebclean/pooldebclean.pl
# and then slighlty patched
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
# Author: Drake Diedrich <dld@google.com>, A. Mennucci
use Getopt::Long;
use Pod::Usage;
use DirHandle;
use FileHandle;
use File::Path;
use File::Find;
use strict;
#
# Return a list of files of all the Packages files
#
sub packages_files($);
sub packages_files($) {
my ($dir) = @_;
my (@packages);
find(sub {/^Packages$/ && -f $_ && push(@packages,$File::Find::name); },
$dir);
@packages;
}
#
# Parse an open filehandle that is a Packages file for the complete
# list of .debs that are indexed in a repository.
#
sub parse_packages($$) {
my ($fh,$packages) = @_;
while (my $line = $fh->getline) {
if ($line =~ /^Filename:\s*(\S+)\s*$/) {
$packages->{$1}++;
}
}
}
sub purge_pool($$$$);
sub purge_pool($$$$) {
my ($dir,$path,$packages,$unlink) = @_;
my $dh = new DirHandle $dir;
while (my $de = $dh->read) {
my $fullpath = "$dir/$de";
next if $de eq '.' || $de eq '..';
if (-d $fullpath) {
purge_pool("$dir/$de","$path/$de",$packages,$unlink);
} elsif (-f $fullpath) {
if ($de =~ /\.deb$/) {
if (!defined $packages->{"$path/$de"}) {
&{$unlink}($fullpath);
}
}
}
}
}
sub pooldebclean($) {
my ($repository) = @_;
my (%packages);
if (! -d $repository) {
return ["$repository/ does not exist", 2];
}
if (! -d "$repository/dists") {
return ["$repository/dists/ does not exist", 2];
}
if (! -d "$repository/pool") {
return ["$repository/pool/ does not exist",2];
}
my (@packages) = packages_files("$repository/dists");
foreach my $package (@packages) {
my $packagefh = new FileHandle $package;
parse_packages($packagefh,\%packages);
}
purge_pool("$repository/pool", "pool", \%packages, sub {print @_ ; print "\n" ;} );
[undef, 0];
}
# main()
#
# Parse options, print usage, and return with exit codes.
#
sub main {
my %options;
my $result = GetOptions(\%options,
'help|?',
'man')
or pod2usage(2);
pod2usage(1) if $options{'help'};
pod2usage(-verbose => 2) if $options{'man'};
if (@ARGV != 1) {
pod2usage("$0: Repository directory required.\n");
}
my ($inputdir) = @ARGV;
my ($rcmsg,$rc) = @{pooldebclean($inputdir)};
print STDERR $rcmsg if defined $rcmsg;
$rc;
}
if (!caller()) {
main();
} else {
return 1;
}
__END__
=head1 NAME
debmarshal_list_useless_debs - list unused .deb pool files from a repository
=head1 SYNOPSIS
debmarshal_list_useless_debs {repository directory}
Options:
-help brief help message
-man full documentation
=head1 OPTIONS
=over 8
=item B<-help>
Print a brief help message and exits.
=item B<-man>
Prints the manual page and exits.
=back
=head1 DESCRIPTION
B<debmarshal_list_useless_debs> will list all the unused .debs in a repository
pool, including debmarshal snapshot and regular Debian repositories.
=cut
|