r28043 - in /trunk/dh-make-perl: dh-make-perl lib/Debian/ lib/Debian/AptContents.pm t/AptContents.t

dmn at users.alioth.debian.org dmn at users.alioth.debian.org
Thu Dec 11 08:08:47 UTC 2008


Author: dmn
Date: Thu Dec 11 08:08:44 2008
New Revision: 28043

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=28043
Log:
move AptContents into a separate Debian::AptContents

Added:
    trunk/dh-make-perl/lib/Debian/
    trunk/dh-make-perl/lib/Debian/AptContents.pm
Modified:
    trunk/dh-make-perl/dh-make-perl
    trunk/dh-make-perl/t/AptContents.t

Modified: trunk/dh-make-perl/dh-make-perl
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/dh-make-perl/dh-make-perl?rev=28043&op=diff
==============================================================================
--- trunk/dh-make-perl/dh-make-perl (original)
+++ trunk/dh-make-perl/dh-make-perl Thu Dec 11 08:08:44 2008
@@ -89,285 +89,6 @@
     }
     return $seq_argument;
 }
-
-package AptContents;
-
-use base qw(Class::Accessor);
-__PACKAGE__->mk_accessors(
-    qw(
-        cache homedir cache_file contents_dir contents_files verbose
-        source sources_file dist
-    )
-);
-
-use Storable;
-use File::Spec::Functions qw( catfile catdir splitpath );
-
-sub new
-{
-    my $class = shift;
-    $class = ref($class) if ref($class);
-    my $self = $class->SUPER::new(@_);
-
-    # required options
-    $self->homedir
-        or die "No homedir given";
-
-    # 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->dist('{sid,unstable}') unless $self->dist;
-    $self->contents_files( $self->get_contents_file_list )
-        unless $self->contents_files;
-    $self->cache_file( catfile( $self->homedir, 'Contents.cache' ) )
-        unless $self->cache_file;
-    $self->verbose(1) unless defined( $self->verbose );
-
-    $self->read_cache();
-
-    return $self;
-}
-
-sub warning
-{
-    my( $self, $level, $msg ) = @_;
-
-    warn "$msg\n" if $self->verbose >= $level;
-}
-
-sub repo_source_to_contents_path {
-    my ( $self, $source ) = @_;
-
-    my ( $schema, $proto, $host, $port, $dir, $dist, $components ) = $source =~ 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;
-    }
-
-    return undef unless $schema eq 'deb';
-
-    $dir ||= '';    # deb http://there sid main
-
-        s{/$}{} for( $host, $dir, $dist );  # remove trailing /
-        s{/}{_}g for( $host, $dir, $dist ); # replace remaining /
-
-    return join( "_", $host, $dir||(), "dists", $dist );
-}
-
-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 $path = $self->repo_source_to_contents_path($_);
-        push @re, qr{\Q$path\E} if $path;
-    }
-
-    return @re;
-}
-
-sub get_contents_file_list {
-    my $self = shift;
-
-    my $archspec = `dpkg --print-architecture`;
-    chomp($archspec);
-
-    my @re = $self->get_contents_filename_filters;
-
-    my $pattern = catfile(
-        $self->contents_dir,
-        "*_". $self->dist . "_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() {
-    my $self = shift;
-
-    my $cache;
-
-    if ( -r $self->cache_file ) {
-        $cache = eval { Storable::retrieve(  $self->cache_file ) };
-        undef($cache) unless ref($cache) and ref($cache) eq 'HASH';
-    }
-
-    # see if the cache is stale
-    if ( $cache and $cache->{stamp} and $cache->{contents_files} ) {
-        undef($cache)
-            unless join( '><', @{ $self->contents_files } ) eq
-                join( '><', @{ $cache->{contents_files} } );
-
-        # file lists are the same?
-        # see if any of the files has changed since we
-        # last read it
-        if ( $cache ) {
-            for ( @{ $self->contents_files } ) {
-                if ( ( stat($_) )[9] > $cache->{stamp} ) {
-                    undef($cache);
-                    last;
-                }
-            }
-        }
-    }
-    else {
-        undef($cache);
-    }
-
-    unless ($cache) {
-        $self->source('parsed files');
-        $cache->{stamp}          = time;
-        $cache->{contents_files} = [];
-        $cache->{apt_contents}   = {};
-        for ( @{ $self->contents_files } ) {
-            push @{ $cache->{contents_files} }, $_;
-            my $f = /\.gz$/
-                ? IO::Uncompress::Gunzip->new($_)
-                : IO::File->new( $_, 'r' );
-
-            unless ($f) {
-                warn "Error reading '$_': $!\n";
-                next;
-            }
-
-            $self->warning( 1, "Parsing $_ ..." );
-            my $capturing = 0;
-            my $line;
-            while ( defined( $line = $f->getline ) ) {
-                if ($capturing) {
-                    my ( $file, $packages ) = split( /\s+/, $line );
-                    next unless $file =~ s{
-                        ^usr/
-                        (?:share|lib)/
-                        (?:perl\d+/             # perl5/
-                        | perl/(?:\d[\d.]+)/   # or perl.5.10/
-                        )
-                    }{}x;
-                    $cache->{apt_contents}{$file} = $packages;
-
-                    # $packages is a comma-separated list of
-                    # section/package items. We'll parse it when a file
-                    # matches. Otherwise we'd parse thousands of entries,
-                    # while checking only a couple
-                }
-                else {
-                    $capturing = 1 if $line =~ /^FILE\s+LOCATION/;
-                }
-            }
-        }
-
-        if ( %{ $cache->{apt_contents} } ) {
-            $self->cache($cache);
-            $self->store_cache;
-        }
-    }
-    else {
-        $self->source('cache');
-        $self->warning( 1,
-            "Using cached Contents from "
-            . localtime( $cache->{stamp} )
-        );
-
-        $self->cache($cache);
-    }
-}
-
-sub store_cache {
-    my $self = shift;
-
-    my ( $vol, $dir, $file ) = splitpath( $self->cache_file );
-
-    $dir = catdir( $vol, $dir );
-    unless ( -d $dir ) {
-        mkdir $dir
-            or die "Error creating directory '$dir': $!\n"
-    }
-
-    Storable::store( $self->cache, $self->cache_file . '-new' );
-    rename( $self->cache_file . '-new', $self->cache_file );
-}
-
-sub find_file_packages {
-    my( $self, $file ) = @_;
-
-    my $packages = $self->cache->{apt_contents}{$file};
-
-    return () unless $packages;
-
-    my @packages = split( /,/, $packages );     # Contents contains a
-                                                # comma-delimitted list
-                                                # of packages
-
-    s{[^/]+/}{} for @packages;  # remove section
-
-    return @packages;
-}
-
-sub find_perl_module_package {
-    my ( $self, $module ) = @_;
-
-    my $module_file = $module;
-    $module_file =~ s|::|/|g;
-
-    my @matches = $self->find_file_packages("$module_file.pm");
-
-    # rank non -perl packages lower
-    @matches = sort {
-        if    ( $a !~ /-perl: / ) { return 1; }
-        elsif ( $b !~ /-perl: / ) { return -1; }
-        else                      { return $a cmp $b; }    # or 0?
-    } @matches;
-
-    return $matches[0];
-}
-
-1;
 
 # The C<Dep> class represent a dependency relationship in an opaque way
 #
@@ -520,6 +241,11 @@
 ######################################################################
 # Main dh-make-perl starts here, don't look any further!
 package main;
+use strict;
+use warnings;
+
+use Debian::AptContents;
+
 my ($min_perl_version, $debstdversion, $priority,  $section,
     @depends,          @bdepends,      @bdependsi, $maintainer,
     $arch,             $closes,        $date,      $debiandir,
@@ -626,7 +352,7 @@
 die "CPANPLUS support disabled, sorry" if $opt_cpanplus;
 
 if ($opt_refresh_cache) {
-    my $apt_contents = AptContents->new({
+    my $apt_contents = Debian::AptContents->new({
         homedir      => $opt_homedir,
         dist         => $opt_dist,
         sources_file => $opt_sources_list,
@@ -706,7 +432,7 @@
     && die
     "The directory $debiandir is already present and I won't overwrite it: remove it yourself.\n";
 
-my $apt_contents = AptContents->new({
+my $apt_contents = Debian::AptContents->new({
     homedir      => $opt_homedir,
     dist         => $opt_dist,
     sources_file => $opt_sources_list,

Added: trunk/dh-make-perl/lib/Debian/AptContents.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/dh-make-perl/lib/Debian/AptContents.pm?rev=28043&op=file
==============================================================================
--- trunk/dh-make-perl/lib/Debian/AptContents.pm (added)
+++ trunk/dh-make-perl/lib/Debian/AptContents.pm Thu Dec 11 08:08:44 2008
@@ -1,0 +1,278 @@
+package Debian::AptContents;
+
+use base qw(Class::Accessor);
+__PACKAGE__->mk_accessors(
+    qw(
+        cache homedir cache_file contents_dir contents_files verbose
+        source sources_file dist
+    )
+);
+
+use Storable;
+use File::Spec::Functions qw( catfile catdir splitpath );
+
+sub new
+{
+    my $class = shift;
+    $class = ref($class) if ref($class);
+    my $self = $class->SUPER::new(@_);
+
+    # required options
+    $self->homedir
+        or die "No homedir given";
+
+    # 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->dist('{sid,unstable}') unless $self->dist;
+    $self->contents_files( $self->get_contents_file_list )
+        unless $self->contents_files;
+    $self->cache_file( catfile( $self->homedir, 'Contents.cache' ) )
+        unless $self->cache_file;
+    $self->verbose(1) unless defined( $self->verbose );
+
+    $self->read_cache();
+
+    return $self;
+}
+
+sub warning
+{
+    my( $self, $level, $msg ) = @_;
+
+    warn "$msg\n" if $self->verbose >= $level;
+}
+
+sub repo_source_to_contents_path {
+    my ( $self, $source ) = @_;
+
+    my ( $schema, $proto, $host, $port, $dir, $dist, $components ) = $source =~ 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;
+    }
+
+    return undef unless $schema eq 'deb';
+
+    $dir ||= '';    # deb http://there sid main
+
+        s{/$}{} for( $host, $dir, $dist );  # remove trailing /
+        s{/}{_}g for( $host, $dir, $dist ); # replace remaining /
+
+    return join( "_", $host, $dir||(), "dists", $dist );
+}
+
+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 $path = $self->repo_source_to_contents_path($_);
+        push @re, qr{\Q$path\E} if $path;
+    }
+
+    return @re;
+}
+
+sub get_contents_file_list {
+    my $self = shift;
+
+    my $archspec = `dpkg --print-architecture`;
+    chomp($archspec);
+
+    my @re = $self->get_contents_filename_filters;
+
+    my $pattern = catfile(
+        $self->contents_dir,
+        "*_". $self->dist . "_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() {
+    my $self = shift;
+
+    my $cache;
+
+    if ( -r $self->cache_file ) {
+        $cache = eval { Storable::retrieve(  $self->cache_file ) };
+        undef($cache) unless ref($cache) and ref($cache) eq 'HASH';
+    }
+
+    # see if the cache is stale
+    if ( $cache and $cache->{stamp} and $cache->{contents_files} ) {
+        undef($cache)
+            unless join( '><', @{ $self->contents_files } ) eq
+                join( '><', @{ $cache->{contents_files} } );
+
+        # file lists are the same?
+        # see if any of the files has changed since we
+        # last read it
+        if ( $cache ) {
+            for ( @{ $self->contents_files } ) {
+                if ( ( stat($_) )[9] > $cache->{stamp} ) {
+                    undef($cache);
+                    last;
+                }
+            }
+        }
+    }
+    else {
+        undef($cache);
+    }
+
+    unless ($cache) {
+        $self->source('parsed files');
+        $cache->{stamp}          = time;
+        $cache->{contents_files} = [];
+        $cache->{apt_contents}   = {};
+        for ( @{ $self->contents_files } ) {
+            push @{ $cache->{contents_files} }, $_;
+            my $f = /\.gz$/
+                ? IO::Uncompress::Gunzip->new($_)
+                : IO::File->new( $_, 'r' );
+
+            unless ($f) {
+                warn "Error reading '$_': $!\n";
+                next;
+            }
+
+            $self->warning( 1, "Parsing $_ ..." );
+            my $capturing = 0;
+            my $line;
+            while ( defined( $line = $f->getline ) ) {
+                if ($capturing) {
+                    my ( $file, $packages ) = split( /\s+/, $line );
+                    next unless $file =~ s{
+                        ^usr/
+                        (?:share|lib)/
+                        (?:perl\d+/             # perl5/
+                        | perl/(?:\d[\d.]+)/   # or perl.5.10/
+                        )
+                    }{}x;
+                    $cache->{apt_contents}{$file} = $packages;
+
+                    # $packages is a comma-separated list of
+                    # section/package items. We'll parse it when a file
+                    # matches. Otherwise we'd parse thousands of entries,
+                    # while checking only a couple
+                }
+                else {
+                    $capturing = 1 if $line =~ /^FILE\s+LOCATION/;
+                }
+            }
+        }
+
+        if ( %{ $cache->{apt_contents} } ) {
+            $self->cache($cache);
+            $self->store_cache;
+        }
+    }
+    else {
+        $self->source('cache');
+        $self->warning( 1,
+            "Using cached Contents from "
+            . localtime( $cache->{stamp} )
+        );
+
+        $self->cache($cache);
+    }
+}
+
+sub store_cache {
+    my $self = shift;
+
+    my ( $vol, $dir, $file ) = splitpath( $self->cache_file );
+
+    $dir = catdir( $vol, $dir );
+    unless ( -d $dir ) {
+        mkdir $dir
+            or die "Error creating directory '$dir': $!\n"
+    }
+
+    Storable::store( $self->cache, $self->cache_file . '-new' );
+    rename( $self->cache_file . '-new', $self->cache_file );
+}
+
+sub find_file_packages {
+    my( $self, $file ) = @_;
+
+    my $packages = $self->cache->{apt_contents}{$file};
+
+    return () unless $packages;
+
+    my @packages = split( /,/, $packages );     # Contents contains a
+                                                # comma-delimitted list
+                                                # of packages
+
+    s{[^/]+/}{} for @packages;  # remove section
+
+    return @packages;
+}
+
+sub find_perl_module_package {
+    my ( $self, $module ) = @_;
+
+    my $module_file = $module;
+    $module_file =~ s|::|/|g;
+
+    my @matches = $self->find_file_packages("$module_file.pm");
+
+    # rank non -perl packages lower
+    @matches = sort {
+        if    ( $a !~ /-perl: / ) { return 1; }
+        elsif ( $b !~ /-perl: / ) { return -1; }
+        else                      { return $a cmp $b; }    # or 0?
+    } @matches;
+
+    return $matches[0];
+}
+
+1;

Modified: trunk/dh-make-perl/t/AptContents.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/dh-make-perl/t/AptContents.t?rev=28043&op=diff
==============================================================================
--- trunk/dh-make-perl/t/AptContents.t (original)
+++ trunk/dh-make-perl/t/AptContents.t Thu Dec 11 08:08:44 2008
@@ -3,18 +3,20 @@
 use strict;
 use warnings;
 
-use Test::More tests => 18;
+use Test::More tests => 19;
+
+BEGIN {
+    use_ok 'Debian::AptContents';
+};
 
 use FindBin qw($Bin);
 use File::Touch qw(touch);
-
-require "$Bin/../dh-make-perl";        # Load our code for testing.
 
 unlink("$Bin/Contents.cache");
 
 sub instance
 {
-    AptContents->new({
+    Debian::AptContents->new({
         homedir => $Bin,
         contents_dir    => "$Bin/contents",
         verbose => 0,
@@ -23,7 +25,7 @@
     });
 }
 
-eval { AptContents->new() };
+eval { Debian::AptContents->new() };
 ok( $@, 'AptContents->new with no homedir dies' );
 like( $@, qr/No homedir given/, 'should say why it died' );
 




More information about the Pkg-perl-cvs-commits mailing list