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;
117 my $tot_suites = scalar keys %s_p;
119 my $completed_pkgs=0;
120 # parse packages files
121 for my $suite (keys %s_p) {
122 my $suite_has_packages = 0;
123 for my $component (keys %{$s_p{$suite}}) {
124 my @archs = keys %{$s_p{$suite}{$component}};
125 if (grep {$_ eq 'source'} @archs) {
126 @archs = ('source',grep {$_ ne 'source'} @archs);
128 for my $arch (@archs) {
129 # we only need a few architectures
130 if ($arch !~ /(all|source|amd64|i386)/) {
131 $prog_bar->update(++$i);
134 my $pfh = open_compressed_file($s_p{$suite}{$component}{$arch}) or
135 die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
137 local $/ = ''; # paragraph mode
141 for my $field (qw(Package Source)) {
142 /^\Q$field\E: (.*)/m;
145 next unless defined $pkg{Package};
146 # skip packages which we aren't actually interested in
147 next unless interesting_package(\%pkg);
148 $pkg{paragraph} = $_;
152 $suite_has_packages = 1;
153 output_packages($suite,$component,$arch,\@pkgs);
155 $prog_bar->update(++$i);
158 build_release($suite,$s_di{$suite}) if $suite_has_packages;
160 $prog_bar->remove() if $prog_bar;
163 my ($suite,$dist_info) = @_;
167 open($apt_ftparchive,
169 'apt-ftparchive','release',
171 (map {exists $dist_info->{$_}?
172 ('-o=APT::FTPArchive::Release::'.$_.'='.
173 $dist_info->{$_}):()}
174 qw(Description Origin Suite Version Codename Components Date)
176 die "Unable to run apt-ftparchive: $!";
178 my ($rf_temp) = <$apt_ftparchive>;
179 close($apt_ftparchive) or
180 die "apt-ftparchive failed: $!";
181 open($release_file,'>',"$suite/Release") or
182 die "Unable to open file $suite/Release: $!";
183 print {$release_file} $rf_temp or
184 die "Unable to print to release file: $!";
185 close($release_file) or
186 die "Unable to close release file: $!";
189 sub output_packages {
190 my ($suite,$component,$arch,$pkgs) = @_;
192 mkdir_if_ne("$suite/$component");
193 mkdir_if_ne("$suite/$component/$arch");
195 open($packages,">:encoding(UTF-8)","$suite/$component/$arch/Packages");
196 for my $pkg (@{$pkgs}) {
197 # replace all e-mail address looking things with foo@example.com
199 s/(<\S+\@)\S+(>)/${1}example.com${2}/g;
200 print {$packages} $pkg->{paragraph};
208 mkdir $_[0] or die "unable to mkdir $_[0]";
212 sub interesting_package {
214 # currently, we only want debbugs, packages containing libc, or source of
215 # glibc. Add more packages here if there are interesting cases we need to
217 if ($pkg->{Package} eq 'debbugs' or
218 ($pkg->{Source} // $pkg->{Package}) eq 'glibc'
226 sub read_release_file {
229 my $rfh = open_compressed_file($file) or
230 die "Unable to open $file for reading: $!";
236 if (s/^(\S+):\s*//) {
237 if ($1 eq 'SHA1'or $1 eq 'SHA256') {
244 my ($sha,$size,$f) = split /\s+/,$_;
245 next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/;
246 next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$};
247 my ($component,$arch,$package_source) = ($1,$2,$3);
248 next if exists $p_f{$component}{$arch};
249 $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f);
252 return (\%dist_info,\%p_f);
258 # indent-tabs-mode: nil
259 # cperl-indent-level: 4