2 # fake_ftpdist generates a fake Debian apt archive for testing
3 # and is released under the terms of the GNU GPL version 3, or any
4 # later version, at your option. See the file README and COPYING for
6 # Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
17 fake_ftpdist - generates a fake Debian apt archive for testing from a real apt archive
21 fake_ftpdist [options]
24 --debug, -d debugging level (Default 0)
25 --help, -h display this help
26 --man, -m display manual
34 Debug verbosity. (Default 0)
38 Display brief usage information.
48 C<fake_ftpdist --ftpdist /srv/ftp.debian.org/ftp/dists>
52 use Debbugs::Common qw(open_compressed_file);
58 my %options = (debug => 0,
66 'debug|d+','help|h|?','man|m');
68 pod2usage() if $options{help};
69 pod2usage({verbose=>2}) if $options{man};
71 $DEBUG = $options{debug};
75 if ($options{progress}) {
76 eval "use Term::ProgressBar";
77 push @USAGE_ERRORS, "You asked for a progress bar, but Term::ProgressBar isn't installed" if $@;
80 if (not defined $options{ftpdist}) {
81 push @USAGE_ERRORS, "You must provide an --ftpdist option";
84 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
87 if ($options{progress}) {
88 $prog_bar = eval "Term::ProgressBar->new({count => 1,ETA=>q(linear)})";
89 warn "Unable to initialize progress bar: $@" if not $prog_bar;
92 my $dist_dir = IO::Dir->new($options{ftpdist}) or
93 die "Unable to open directory $options{ftpdist}: $!";
95 grep { $_ !~ /^\./ and
96 -d $options{ftpdist}.'/'.$_ and
97 not -l $options{ftpdist}.'/'.$_
101 while (my $dist = shift @dist_names) {
102 my $dist_dir = $options{ftpdist}.'/'.$dist;
103 my ($dist_info,$package_files) =
104 read_release_file($dist_dir.'/Release');
105 $s_di{$dist_info->{Codename}} = $dist_info;
106 $s_p{$dist_info->{Codename}} = $package_files;
109 for my $suite (keys %s_p) {
110 for my $component (keys %{$s_p{$suite}}) {
111 $tot += scalar keys %{$s_p{$suite}{$component}};
114 $prog_bar->target($tot) if $prog_bar;
119 my $tot_suites = scalar keys %s_p;
121 my $completed_pkgs=0;
122 # parse packages files
123 for my $suite (keys %s_p) {
124 my $suite_has_packages = 0;
125 for my $component (keys %{$s_p{$suite}}) {
126 my @archs = keys %{$s_p{$suite}{$component}};
127 if (grep {$_ eq 'source'} @archs) {
128 @archs = ('source',grep {$_ ne 'source'} @archs);
130 for my $arch (@archs) {
131 # we only need a few architectures
132 if ($arch !~ /(all|source|amd64|i386)/) {
133 $prog_bar->update(++$i);
136 my $pfh = open_compressed_file($s_p{$suite}{$component}{$arch}) or
137 die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
139 local $/ = ''; # paragraph mode
143 for my $field (qw(Package Source)) {
144 /^\Q$field\E: (.*)/m;
147 next unless defined $pkg{Package};
148 # skip packages which we aren't actually interested in
149 next unless interesting_package(\%pkg);
150 $pkg{paragraph} = $_;
154 $suite_has_packages = 1;
155 output_packages($suite,$component,$arch,\@pkgs);
157 $prog_bar->update(++$i);
160 build_release($suite,$s_di{$suite}) if $suite_has_packages;
162 $prog_bar->remove() if $prog_bar;
165 my ($suite,$dist_info) = @_;
169 open($apt_ftparchive,
171 'apt-ftparchive','release',
173 (map {exists $dist_info->{$_}?
174 ('-o=APT::FTPArchive::Release::'.$_.'='.
175 $dist_info->{$_}):()}
176 qw(Description Origin Suite Version Codename Components Date)
178 die "Unable to run apt-ftparchive: $!";
180 my ($rf_temp) = <$apt_ftparchive>;
181 close($apt_ftparchive) or
182 die "apt-ftparchive failed: $!";
183 open($release_file,'>',"$suite/Release") or
184 die "Unable to open file $suite/Release: $!";
185 print {$release_file} $rf_temp or
186 die "Unable to print to release file: $!";
187 close($release_file) or
188 die "Unable to close release file: $!";
191 sub output_packages {
192 my ($suite,$component,$arch,$pkgs) = @_;
194 mkdir_if_ne("$suite/$component");
195 mkdir_if_ne("$suite/$component/$arch");
197 open($packages,">:encoding(UTF-8)","$suite/$component/$arch/Packages");
198 for my $pkg (@{$pkgs}) {
199 # replace all e-mail address looking things with foo@example.com
201 s/(<\S+\@)\S+(>)/${1}example.com${2}/g;
202 print {$packages} $pkg->{paragraph};
210 mkdir $_[0] or die "unable to mkdir $_[0]";
214 sub interesting_package {
216 # currently, we only want debbugs, packages containing libc, or source of
217 # glibc. Add more packages here if there are interesting cases we need to
219 if ($pkg->{Package} eq 'debbugs' or
220 ($pkg->{Source} // $pkg->{Package}) eq 'glibc'
228 sub read_release_file {
231 my $rfh = open_compressed_file($file) or
232 die "Unable to open $file for reading: $!";
238 if (s/^(\S+):\s*//) {
239 if ($1 eq 'SHA1'or $1 eq 'SHA256') {
246 my ($sha,$size,$f) = split /\s+/,$_;
247 next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/;
248 next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$};
249 my ($component,$arch,$package_source) = ($1,$2,$3);
250 next if exists $p_f{$component}{$arch};
251 $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f);
254 return (\%dist_info,\%p_f);
260 # indent-tabs-mode: nil
261 # cperl-indent-level: 4