r27343 - /trunk/dh-make-perl/dh-make-perl

[dmn at users.alioth.debian.org]

Author: dmn
Date: Thu Nov 27 09:51:25 2008
New Revision: 27343

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=27343
Log:
filter possible Contents files by the contents of sources.list

no longer parsing of Contents files of mirrors you don't use years ago

Modified:
    trunk/dh-make-perl/dh-make-perl

Modified: trunk/dh-make-perl/dh-make-perl
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/dh-make-perl/dh-make-perl?rev=27343&op=diff
==============================================================================
--- trunk/dh-make-perl/dh-make-perl (original)
+++ trunk/dh-make-perl/dh-make-perl Thu Nov 27 09:51:25 2008
@@ -96,7 +96,7 @@
 __PACKAGE__->mk_accessors(
     qw(
         cache homedir cache_file contents_dir contents_files verbose
-        source
+        source sources_file
     )
 );
 
@@ -116,6 +116,8 @@
     # some defaults
     $self->contents_dir( '/var/cache/apt/apt-file' )
         unless $self->contents_dir;
+    $self->sources_file('/etc/apt/sources.list')
+        unless defined( $self->sources_file );
     $self->contents_files( $self->get_contents_file_list )
         unless $self->contents_files;
     $self->cache_file( catfile( $self->homedir, 'Contents.cache' ) )
@@ -135,15 +137,80 @@
     warn "$msg\n" if $self->verbose >= $level;
 }
 
+sub get_contents_filename_filters
+{
+    my $self = shift;
+
+    my $sources = IO::File->new( $self->sources_file, 'r' )
+        or die "Unable to open '" . $self->sources_file . "': $!\n";
+
+    my @re;
+
+    while( <$sources> ) {
+        chomp;
+        s/#.*//;
+        s/^\s+//;
+        s/\s+$//;
+        next unless $_;
+
+        my ( $schema, $proto, $host, $port, $dir, $dist, $components ) = m{
+            ^
+            (\S+)           # deb or deb-src
+            \s+
+            ([^:\s]+)       # ftp/http/file/cdrom
+            ://
+            (/?             # file:///
+                [^:/\s]+    # host name or path
+            )
+            (?:
+                :(\d+)      # optional port number
+            )?
+            (?:
+                /
+                (\S+)       # path on server (or local)
+            )?
+            \s+
+            (\S+)           # distribution
+            \s+
+            (.+)            # components
+        }x;
+
+        unless ( defined $schema ) {
+            $self->warning( 1, "'$_' has unknown format" );
+            next;
+        }
+
+        next unless $schema eq 'deb';
+
+        s{/}{_}g for( $host, $dir, $dist );
+
+        push @re, qr,${host}_${dir}_dists_${dist}_,;
+    }
+
+    return @re;
+}
+
 sub get_contents_file_list {
     my $self = shift;
 
     my $archspec = `dpkg --print-architecture`;
     chomp($archspec);
 
-    my $pattern = catfile( $self->contents_dir, "*_debian_dists_{unstable,sid}_Contents{,-$archspec}{,.gz}" );
-
-    return [ sort glob $pattern ];
+    my @re = $self->get_contents_filename_filters;
+
+    my $pattern = catfile( $self->contents_dir, "*_Contents{,-$archspec}{,.gz}" );
+
+    my @list = glob $pattern;
+
+    my @filtered;
+    for my $path (@list) {
+        my( $vol, $dirs, $file ) = splitpath( $path );
+
+        for (@re) {
+            push @filtered, $path if $file =~ $_;
+        }
+    }
+    return [ sort @filtered ];
 }
 
 sub read_cache() {