t/fake_ftpdist

   1 #!/usr/bin/perl
   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
   5 # more information.
   6 # Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 fake_ftpdist - generates a fake Debian apt archive for testing from a real apt archive
  18
  19 =head1 SYNOPSIS
  20
  21 fake_ftpdist [options]
  22
  23 Options:
  24 --debug, -d debugging level (Default 0)
  25 --help, -h display this help
  26 --man, -m display manual
  27
  28 =head1 OPTIONS
  29
  30 =over
  31
  32 =item B<--debug, -d>
  33
  34 Debug verbosity. (Default 0)
  35
  36 =item B<--help, -h>
  37
  38 Display brief usage information.
  39
  40 =item B<--man, -m>
  41
  42 Display this manual.
  43
  44 =back
  45
  46 =head1 EXAMPLES
  47
  48 C<fake_ftpdist --ftpdist /srv/ftp.debian.org/ftp/dists>
  49
  50 =cut
  51
  52 use Debbugs::Common qw(open_compressed_file);
  53 use IO::Dir;
  54 use File::Basename;
  55
  56 use vars qw($DEBUG);
  57
  58 my %options = (debug           => 0,
  59                help            => 0,
  60                man             => 0,
  61               );
  62
  63 GetOptions(\%options,
  64            'ftpdist=s',
  65            'progress',
  66            'debug|d+','help|h|?','man|m');
  67
  68 pod2usage() if $options{help};
  69 pod2usage({verbose=>2}) if $options{man};
  70
  71 $DEBUG = $options{debug};
  72
  73 my @USAGE_ERRORS;
  74
  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 $@;
  78 }
  79
  80 if (not defined $options{ftpdist}) {
  81     push @USAGE_ERRORS, "You must provide an --ftpdist option";
  82 }
  83
  84 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
  85
  86 my $prog_bar;
  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;
  90 }
  91
  92 my $dist_dir = IO::Dir->new($options{ftpdist}) or
  93     die "Unable to open directory $options{ftpdist}: $!";
  94 my @dist_names =
  95         grep { $_ !~ /^\./ and
  96                -d $options{ftpdist}.'/'.$_ and
  97                not -l $options{ftpdist}.'/'.$_
  98            } $dist_dir->read;
  99 my %s_p;
 100 my %s_di;
 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;
 107 }
 108 my $tot = 0;
 109 for my $suite (keys %s_p) {
 110         for my $component (keys %{$s_p{$suite}}) {
 111             $tot += scalar keys %{$s_p{$suite}{$component}};
 112         }
 113 }
 114 $prog_bar->target($tot) if $prog_bar;
 115 use Data::Printer;
 116 p %s_di;
 117 my $i = 0;
 118 my $avg_pkgs = 0;
 119 my $tot_suites = scalar keys %s_p;
 120 my $done_suites=0;
 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);
 129         }
 130         for my $arch (@archs) {
 131             # we only need a few architectures
 132             if ($arch !~ /(all|source|amd64|i386)/) {
 133                 $prog_bar->update(++$i);
 134                 next;
 135             }
 136             my $pfh =  open_compressed_file($s_p{$suite}{$component}{$arch}) or
 137                 die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
 138             local $_;
 139             local $/ = '';      # paragraph mode
 140             my @pkgs;
 141             while (<$pfh>) {
 142                 my %pkg;
 143                 for my $field (qw(Package Source)) {
 144                     /^\Q$field\E: (.*)/m;
 145                     $pkg{$field} = $1;
 146                 }
 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} = $_;
 151                 push @pkgs,\%pkg;
 152             }
 153             if (@pkgs) {
 154                 $suite_has_packages = 1;
 155                 output_packages($suite,$component,$arch,\@pkgs);
 156             }
 157             $prog_bar->update(++$i);
 158         }
 159     }
 160     build_release($suite,$s_di{$suite}) if $suite_has_packages;
 161 }
 162 $prog_bar->remove() if $prog_bar;
 163
 164 sub build_release {
 165     my ($suite,$dist_info) = @_;
 166
 167     my $release_file;
 168     my $apt_ftparchive;
 169     open($apt_ftparchive,
 170          '-|',
 171          'apt-ftparchive','release',
 172          $suite,
 173          (map {exists $dist_info->{$_}?
 174                    ('-o=APT::FTPArchive::Release::'.$_.'='.
 175                     $dist_info->{$_}):()}
 176             qw(Description Origin Suite Version Codename Components Date)
 177          )) or
 178              die "Unable to run apt-ftparchive: $!";
 179     local $/;
 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: $!";
 189 }
 190
 191 sub output_packages {
 192     my ($suite,$component,$arch,$pkgs) = @_;
 193     mkdir_if_ne($suite);
 194     mkdir_if_ne("$suite/$component");
 195     mkdir_if_ne("$suite/$component/$arch");
 196     my $packages;
 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
 200         $pkg->{paragraph} =~
 201             s/(<\S+\@)\S+(>)/${1}example.com${2}/g;
 202         print {$packages} $pkg->{paragraph};
 203     }
 204     close($packages);
 205 }
 206
 207
 208 sub mkdir_if_ne {
 209     if (! -d $_[0]) {
 210         mkdir $_[0] or die "unable to mkdir $_[0]";
 211     }
 212 }
 213
 214 sub interesting_package {
 215     my ($pkg) = @_;
 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
 218     # debug
 219     if ($pkg->{Package} eq 'debbugs' or
 220         ($pkg->{Source} // $pkg->{Package}) eq 'glibc'
 221        ) {
 222         return 1;
 223     }
 224     return 0;
 225 }
 226
 227
 228 sub read_release_file {
 229     my ($file) = @_;
 230     # parse release
 231     my $rfh =  open_compressed_file($file) or
 232         die "Unable to open $file for reading: $!";
 233     my %dist_info;
 234     my $in_sha1;
 235     my %p_f;
 236     while (<$rfh>) {
 237         chomp;
 238         if (s/^(\S+):\s*//) {
 239             if ($1 eq 'SHA1'or $1 eq 'SHA256') {
 240                 $in_sha1 = 1;
 241                 next;
 242             }
 243             $dist_info{$1} = $_;
 244         } elsif ($in_sha1) {
 245             s/^\s//;
 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);
 252         }
 253     }
 254     return (\%dist_info,\%p_f);
 255 }
 256
 257
 258 __END__
 259 # Local Variables:
 260 # indent-tabs-mode: nil
 261 # cperl-indent-level: 4
 262 # End: