--- /dev/null
+#!/usr/bin/perl
+# fake_ftpdist generates a fake Debian apt archive for testing
+# and is released under the terms of the GNU GPL version 3, or any
+# later version, at your option. See the file README and COPYING for
+# more information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+
+use warnings;
+use strict;
+
+use Getopt::Long;
+use Pod::Usage;
+
+=head1 NAME
+
+fake_ftpdist - generates a fake Debian apt archive for testing from a real apt archive
+
+=head1 SYNOPSIS
+
+fake_ftpdist [options]
+
+Options:
+--debug, -d debugging level (Default 0)
+--help, -h display this help
+--man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=item B<--debug, -d>
+
+Debug verbosity. (Default 0)
+
+=item B<--help, -h>
+
+Display brief usage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+=head1 EXAMPLES
+
+C<fake_ftpdist --ftpdist /srv/ftp.debian.org/ftp/dists>
+
+=cut
+
+use Debbugs::Common qw(open_compressed_file);
+use IO::Dir;
+use File::Basename;
+
+use vars qw($DEBUG);
+
+my %options = (debug => 0,
+ help => 0,
+ man => 0,
+ );
+
+GetOptions(\%options,
+ 'ftpdist=s',
+ 'progress',
+ 'debug|d+','help|h|?','man|m');
+
+pod2usage() if $options{help};
+pod2usage({verbose=>2}) if $options{man};
+
+$DEBUG = $options{debug};
+
+my @USAGE_ERRORS;
+
+if ($options{progress}) {
+ eval "use Term::ProgressBar";
+ push @USAGE_ERRORS, "You asked for a progress bar, but Term::ProgressBar isn't installed" if $@;
+}
+
+if (not defined $options{ftpdist}) {
+ push @USAGE_ERRORS, "You must provide an --ftpdist option";
+}
+
+pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
+
+my $prog_bar;
+if ($options{progress}) {
+ $prog_bar = eval "Term::ProgressBar->new({count => 1,ETA=>q(linear)})";
+ warn "Unable to initialize progress bar: $@" if not $prog_bar;
+}
+
+my $dist_dir = IO::Dir->new($options{ftpdist}) or
+ die "Unable to open directory $options{ftpdist}: $!";
+my @dist_names =
+ grep { $_ !~ /^\./ and
+ -d $options{ftpdist}.'/'.$_ and
+ not -l $options{ftpdist}.'/'.$_
+ } $dist_dir->read;
+my %s_p;
+my %s_di;
+while (my $dist = shift @dist_names) {
+ my $dist_dir = $options{ftpdist}.'/'.$dist;
+ my ($dist_info,$package_files) =
+ read_release_file($dist_dir.'/Release');
+ $s_di{$dist_info->{Codename}} = $dist_info;
+ $s_p{$dist_info->{Codename}} = $package_files;
+}
+my $tot = 0;
+for my $suite (keys %s_p) {
+ for my $component (keys %{$s_p{$suite}}) {
+ $tot += scalar keys %{$s_p{$suite}{$component}};
+ }
+}
+$prog_bar->target($tot) if $prog_bar;
+use Data::Printer;
+p %s_di;
+my $i = 0;
+my $avg_pkgs = 0;
+my $tot_suites = scalar keys %s_p;
+my $done_suites=0;
+my $completed_pkgs=0;
+# parse packages files
+for my $suite (keys %s_p) {
+ my $suite_has_packages = 0;
+ for my $component (keys %{$s_p{$suite}}) {
+ my @archs = keys %{$s_p{$suite}{$component}};
+ if (grep {$_ eq 'source'} @archs) {
+ @archs = ('source',grep {$_ ne 'source'} @archs);
+ }
+ for my $arch (@archs) {
+ # we only need a few architectures
+ if ($arch !~ /(all|source|amd64|i386)/) {
+ $prog_bar->update(++$i);
+ next;
+ }
+ my $pfh = open_compressed_file($s_p{$suite}{$component}{$arch}) or
+ die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
+ local $_;
+ local $/ = ''; # paragraph mode
+ my @pkgs;
+ while (<$pfh>) {
+ my %pkg;
+ for my $field (qw(Package Source)) {
+ /^\Q$field\E: (.*)/m;
+ $pkg{$field} = $1;
+ }
+ next unless defined $pkg{Package};
+ # skip packages which we aren't actually interested in
+ next unless interesting_package(\%pkg);
+ $pkg{paragraph} = $_;
+ push @pkgs,\%pkg;
+ }
+ if (@pkgs) {
+ $suite_has_packages = 1;
+ output_packages($suite,$component,$arch,\@pkgs);
+ }
+ $prog_bar->update(++$i);
+ }
+ }
+ build_release($suite,$s_di{$suite}) if $suite_has_packages;
+}
+$prog_bar->remove() if $prog_bar;
+
+sub build_release {
+ my ($suite,$dist_info) = @_;
+
+ my $release_file;
+ my $apt_ftparchive;
+ open($apt_ftparchive,
+ '-|',
+ 'apt-ftparchive','release',
+ $suite,
+ (map {exists $dist_info->{$_}?
+ ('-o=APT::FTPArchive::Release::'.$_.'='.
+ $dist_info->{$_}):()}
+ qw(Description Origin Suite Version Codename Components Date)
+ )) or
+ die "Unable to run apt-ftparchive: $!";
+ local $/;
+ my ($rf_temp) = <$apt_ftparchive>;
+ close($apt_ftparchive) or
+ die "apt-ftparchive failed: $!";
+ open($release_file,'>',"$suite/Release") or
+ die "Unable to open file $suite/Release: $!";
+ print {$release_file} $rf_temp or
+ die "Unable to print to release file: $!";
+ close($release_file) or
+ die "Unable to close release file: $!";
+}
+
+sub output_packages {
+ my ($suite,$component,$arch,$pkgs) = @_;
+ mkdir_if_ne($suite);
+ mkdir_if_ne("$suite/$component");
+ mkdir_if_ne("$suite/$component/$arch");
+ my $packages;
+ open($packages,">:encoding(UTF-8)","$suite/$component/$arch/Packages");
+ for my $pkg (@{$pkgs}) {
+ # replace all e-mail address looking things with foo@example.com
+ $pkg->{paragraph} =~
+ s/(<\S+\@)\S+(>)/${1}example.com${2}/g;
+ print {$packages} $pkg->{paragraph};
+ }
+ close($packages);
+}
+
+
+sub mkdir_if_ne {
+ if (! -d $_[0]) {
+ mkdir $_[0] or die "unable to mkdir $_[0]";
+ }
+}
+
+sub interesting_package {
+ my ($pkg) = @_;
+ # currently, we only want debbugs, packages containing libc, or source of
+ # glibc. Add more packages here if there are interesting cases we need to
+ # debug
+ if ($pkg->{Package} eq 'debbugs' or
+ ($pkg->{Source} // $pkg->{Package}) eq 'glibc'
+ ) {
+ return 1;
+ }
+ return 0;
+}
+
+
+sub read_release_file {
+ my ($file) = @_;
+ # parse release
+ my $rfh = open_compressed_file($file) or
+ die "Unable to open $file for reading: $!";
+ my %dist_info;
+ my $in_sha1;
+ my %p_f;
+ while (<$rfh>) {
+ chomp;
+ if (s/^(\S+):\s*//) {
+ if ($1 eq 'SHA1'or $1 eq 'SHA256') {
+ $in_sha1 = 1;
+ next;
+ }
+ $dist_info{$1} = $_;
+ } elsif ($in_sha1) {
+ s/^\s//;
+ my ($sha,$size,$f) = split /\s+/,$_;
+ next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/;
+ next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$};
+ my ($component,$arch,$package_source) = ($1,$2,$3);
+ next if exists $p_f{$component}{$arch};
+ $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f);
+ }
+ }
+ return (\%dist_info,\%p_f);
+}
+
+
+__END__
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
projects / debbugs.git / blobdiff