r8792 - in /scripts/qa/QA: ./ Cache.pm Config.pm DebianArchive.pm VerComp.pm
tincho-guest at users.alioth.debian.org
tincho-guest at users.alioth.debian.org
Sat Nov 3 15:56:00 UTC 2007
Author: tincho-guest
Date: Sat Nov 3 15:56:00 2007
New Revision: 8792
URL: http://svn.debian.org/wsvn/?sc=1&rev=8792
Log:
First version of a new set of scripts for versioncheck.
These modules implement:
- Cache managing in a generic way; with locking and timestamping at different
levels.
- Debian package version comparing, using the same algorithm as dpkg.
- A placeholder for real configuration (later).
- Downloading and age verification of information from the Debian Archive.
Added:
scripts/qa/QA/
scripts/qa/QA/Cache.pm
scripts/qa/QA/Config.pm (with props)
scripts/qa/QA/DebianArchive.pm (with props)
scripts/qa/QA/VerComp.pm (with props)
Added: scripts/qa/QA/Cache.pm
URL: http://svn.debian.org/wsvn/scripts/qa/QA/Cache.pm?rev=8792&op=file
==============================================================================
--- scripts/qa/QA/Cache.pm (added)
+++ scripts/qa/QA/Cache.pm Sat Nov 3 15:56:00 2007
@@ -1,0 +1,186 @@
+# vim:ts=4:sw=4:et:ai:sts=4
+# $Id: Common.pm 6650 2007-08-15 10:17:36Z tincho-guest $
+#
+# Routines for handling cache files
+#
+# Copyright MartÃn Ferrari <martin.ferrari at gmail.com>, 2007
+# Released under the terms of the GNU GPL 2
+
+package QA::Cache;
+use strict;
+use warnings;
+
+our @ISA = "Exporter";
+our @EXPORT = qw(dump_cache read_cache update_cache find_timestamp);
+
+use QA::Config;
+use Storable qw(store_fd fd_retrieve);
+use Fcntl qw(:seek :flock);
+use File::Path;
+
+my %fd; # Hash of open FDs, to keep locks.
+
+sub dump_cache {
+ my($cache, $root) = @_;
+ $root ||= "";
+ $root =~ s{/+$}{};
+
+ if(! defined($fd{$cache})) {
+ mkpath $CACHEDIR;
+ open $fd{$cache}, "<", "$CACHEDIR/$cache"
+ or die "Error opening cache: $!\n";
+ flock($fd{$cache}, LOCK_SH) or die "Error locking cache: $!\n";
+ }
+ my $fd = $fd{$cache};
+ seek($fd, 0, SEEK_SET) or die "Can't seek: $!\n";
+ my $data = {};
+ if(-s $fd) {
+ $data = fd_retrieve($fd) or die "Can't read cache: $!\n";
+ }
+ close $fd;
+ require Data::Dumper;
+ print Data::Dumper::Dumper(dive_hash($data, $root));
+ 1;
+}
+sub read_cache {
+ # * $root specifies a path inside the cache hash.
+ # * If $keep_lock, file is kept open and write-locked until the next
+ # operation.
+ #
+ # In scalar context returns the data as a hashref. In array context also
+ # returns the effective timestamp as a second element. The effective
+ # timestamp is the value of a "/timestamp" key at the same level (or up) as
+ # $root. If there are single elements with newer timestamps, they will have
+ # a "/timestamp" subkey.
+ my($cache, $root, $keep_lock) = @_;
+ $root ||= "";
+ $cache ||= "";
+ $keep_lock ||= 0;
+ warn("read_cache($cache, $root, $keep_lock) invoked\n") if($DEBUG);
+
+ $root = "/$root";
+ $root =~ s{/+$}{};
+
+ unless(-e "$CACHEDIR/$cache") {
+ return({}, 0) if(wantarray);
+ return {};
+ }
+ if(! defined($fd{$cache})) {
+ mkpath $CACHEDIR;
+ if($keep_lock) {
+ open $fd{$cache}, "+<", "$CACHEDIR/$cache"
+ or die "Error opening cache: $!\n";
+ flock($fd{$cache}, LOCK_EX) or die "Error locking cache: $!\n";
+ } else {
+ open $fd{$cache}, "<", "$CACHEDIR/$cache"
+ or die "Error opening cache: $!\n";
+ flock($fd{$cache}, LOCK_SH) or die "Error locking cache: $!\n";
+ }
+ }
+ my $fd = $fd{$cache};
+ seek($fd, 0, SEEK_SET) or die "Can't seek: $!\n";
+ my $data = {};
+ if(-s $fd) {
+ $data = fd_retrieve($fd) or die "Can't read cache: $!\n";
+ }
+ unless($keep_lock) {
+ close($fd);
+ $fd{$cache} = undef;
+ }
+ my $rootd = dive_hash($data, $root);
+ return $rootd if(not wantarray);
+ return($rootd, find_timestamp($data, $root));
+}
+sub update_cache($$$$$) {
+ # * $root specifies a path inside the cache hash.
+ # * $data is the data to merge/replace (depending on $replace) in the cache
+ # starting from $root. Note that it's merged at the first level: so
+ # existent data inside a key won't be kept.
+ # * If $keep_lock, file is kept open and write-locked until the next
+ # operation.
+ #
+ # A timestamp is added with key "/timestamp", at the $root level if
+ # $replace, inside each key if not.
+ #
+ # Returns the whole cache
+ my($cache, $data, $root, $replace, $keep_lock) = @_;
+ $root ||= "";
+ $replace ||= 0;
+ $keep_lock ||= 0;
+ warn("update_cache($cache, $data, $root, $replace, $keep_lock) invoked\n")
+ if($DEBUG);
+
+ $root = "/$root";
+ $root =~ s{/+$}{};
+ my $tsmp = time;
+
+ if(! defined($fd{$cache})) {
+ mkpath $CACHEDIR;
+ open($fd{$cache}, (-e "$CACHEDIR/$cache" ? "+<" : "+>"),
+ "$CACHEDIR/$cache") or die "Error opening cache: $!\n";
+ flock($fd{$cache}, LOCK_EX) or die "Error locking cache: $!\n";
+ }
+ my $fd = $fd{$cache};
+ seek($fd, 0, SEEK_SET) or die "Can't seek: $!\n";
+ my $cdata = {};
+ if(-s $fd) {
+ $cdata = fd_retrieve($fd) or die "Can't read cache: $!\n";
+ }
+ if($replace and $root eq "") {
+ $root = $cdata = {};
+ } elsif($replace) {
+ $root =~ s{/+([^/]+)$}{};
+ my $leaf = $1;
+ $root = dive_hash($cdata, $root);
+ $root = $root->{$leaf} = $data;
+ $root->{"/timestamp"} = $tsmp;
+ } else {
+ $root = dive_hash($cdata, $root);
+ foreach(keys(%$data)) {
+ $root->{$_} = $data->{$_};
+ $root->{$_}{"/timestamp"} = $tsmp;
+ }
+ }
+ seek($fd, 0, SEEK_SET) or die "Can't seek: $!\n";
+ store_fd($cdata, $fd) or die "Can't save cache: $!\n";
+ unless($keep_lock) {
+ close($fd);
+ $fd{$cache} = undef;
+ }
+ return $cdata;
+}
+# Return a reference into $hash, as specified with $path
+# Creates or replaces any component that is not a hashref
+sub dive_hash($$) {
+ my($hash, $path) = @_;
+ warn("dive_hash($hash, $path) invoked\n") if($DEBUG);
+ die "Invalid hashref" unless($hash and ref $hash and ref $hash eq "HASH");
+ my @path = split(m#/+#, $path);
+ my $ref = $hash;
+ foreach(@path) {
+ next unless($_);
+ my $r = $ref->{$_};
+ unless($r and ref $r and ref $r eq "HASH") {
+ $r = $ref->{$_} = {};
+ }
+ $ref = $r;
+ }
+ return $ref;
+}
+# Search a timestamp in $hash, starting at $path and going upwards until the
+# root
+sub find_timestamp {
+ my($hash, $path) = @_;
+ warn("find_timestamp($hash, $path) invoked\n") if($DEBUG);
+ die "Invalid hashref" unless($hash and ref $hash and ref $hash eq "HASH");
+ my $ctsmp = 0;
+ if($path =~ s{^/*([^/]+)}{}) {
+ my $root = $1;
+ $ctsmp = find_timestamp($hash->{$root}, $path) if($hash->{$root});
+ }
+ if(not $ctsmp and exists($hash->{"/timestamp"})) {
+ $ctsmp = $hash->{"/timestamp"};
+ }
+ return $ctsmp;
+}
+1;
Added: scripts/qa/QA/Config.pm
URL: http://svn.debian.org/wsvn/scripts/qa/QA/Config.pm?rev=8792&op=file
==============================================================================
--- scripts/qa/QA/Config.pm (added)
+++ scripts/qa/QA/Config.pm Sat Nov 3 15:56:00 2007
@@ -1,0 +1,115 @@
+# $Id: Common.pm 6650 2007-08-15 10:17:36Z tincho-guest $
+package QA::Config;
+
+use strict;
+use warnings;
+
+use Sys::Hostname;
+# This doesn't seem to be used, and also, use CPAN modifies @INC -- looks like
+# a bug to me
+#use CPAN;
+
+our @EXPORT = qw(
+ $SVN_REPO
+ $MIRROR
+ $CPAN_MIRROR
+ $CACHEDIR
+ $DEBUG
+);
+our @ISA = "Exporter";
+
+our $SVN_REPO = "svn://svn.debian.org/svn/pkg-perl";
+our $MIRROR = "MIRROR=ftp://ftp.debian.org";
+our $CPAN_MIRROR = "ftp://cpan.org/pub/CPAN";
+our $CACHEDIR = "$ENV{HOME}/.dpg/versioncheck";
+our $DEBUG = 1;
+
+# special hosts
+for( hostname )
+{
+ # alioth
+ /alioth/ && do {
+ $SVN_REPO = "file:///svn/pkg-perl";
+ $MIRROR = "ftp://ftp.nl.debian.org";
+ $CPAN_MIRROR = "ftp://cpan.wanadoo.nl/pub/CPAN";
+ last;
+ };
+
+ # Gregor
+ /belanna|nerys/ && do {
+ $MIRROR = "ftp://ftp.at.debian.org";
+ $CPAN_MIRROR = "ftp://gd.tuwien.ac.at/pub/CPAN";
+ last;
+ };
+
+ # dam
+ /pc1/ && do {
+ $MIRROR = "http://proxy:9999";
+ $CPAN_MIRROR = "ftp://ftp.uni-sofia.bg/cpan";
+ last;
+ };
+ /beetle/ && do {
+ $MIRROR = "http://localhost:9999";
+ $CPAN_MIRROR = "ftp://ftp.uni-sofia.bg/cpan";
+ last;
+ };
+
+ # Tincho
+ /abraxas/ && do {
+ $MIRROR = "file:///media/IOMega/mirror/";
+ $CPAN_MIRROR = "ftp://cpan.ip.pt/pub/cpan/";
+ last;
+ };
+
+ die "Unknown host $_";
+}
+
+# This mirror is near alioth. From #alioth:
+# <ard> ard at c32791:~$ sudo /usr/sbin/traceroute -A cpan.wanadoo.nl|grep AS1200
+# <ard> traceroute to ftp.wanadoo.nl (194.134.17.10), 64 hops max, 40 byte packets
+# <ard> 5 ams-ix.euro.net (195.69.144.70) [AS1200] 1 ms 1 ms 1 ms
+# <ard> jups
+# <ard> 10G going to as1200
+# <ard> As long as it passes as1200 it's ok... Everything else is $$ :-(
+# CPAN=ftp://cpan.wanadoo.nl/pub/CPAN
+
+my $home = $ENV{HOME};
+$CPAN::Config = {
+ 'build_cache' => q[10],
+ 'build_dir' => "$home/.cpan/build",
+ 'cache_metadata' => q[1],
+ 'cpan_home' => "$home/.cpan",
+ 'cpan_version_check' => q[0],
+ 'dontload_hash' => { },
+ 'ftp' => q[],
+ 'ftp_proxy' => q[],
+ 'getcwd' => q[cwd],
+ 'gpg' => q[/usr/bin/gpg],
+ 'gzip' => q[/bin/gzip],
+ 'histfile' => "/dev/null",
+ 'histsize' => q[100],
+ 'http_proxy' => q[],
+ 'inactivity_timeout' => q[0],
+ 'index_expire' => q[1],
+ 'inhibit_startup_message' => q[1],
+ 'keep_source_where' => "$home/.cpan/sources",
+ 'lynx' => q[/usr/bin/lynx],
+ 'make' => q[/usr/bin/make],
+ 'make_arg' => q[],
+ 'make_install_arg' => q[],
+ 'makepl_arg' => q[INSTALLDIRS=site],
+ 'ncftp' => q[],
+ 'ncftpget' => q[],
+ 'no_proxy' => q[],
+ 'pager' => q[/usr/bin/less],
+ 'prerequisites_policy' => q[ignore],
+ 'scan_cache' => q[never],
+ 'shell' => q[/bin/bash],
+ 'tar' => q[/bin/tar],
+ 'term_is_latin' => q[0],
+ 'unzip' => q[],
+ 'urllist' => [ $CPAN_MIRROR ],
+ 'wget' => q[/usr/bin/wget],
+};
+
+1;
Propchange: scripts/qa/QA/Config.pm
------------------------------------------------------------------------------
svn:keywords = QA/Cache.pm
Added: scripts/qa/QA/DebianArchive.pm
URL: http://svn.debian.org/wsvn/scripts/qa/QA/DebianArchive.pm?rev=8792&op=file
==============================================================================
--- scripts/qa/QA/DebianArchive.pm (added)
+++ scripts/qa/QA/DebianArchive.pm Sat Nov 3 15:56:00 2007
@@ -1,0 +1,188 @@
+# vim:ts=4:sw=4:et:ai:sts=4
+# $Id: Common.pm 6650 2007-08-15 10:17:36Z tincho-guest $
+#
+# Routines for comparing package versions, based on policy + dpkg code
+# I'm not using AptPkg::Version since it depends on having a working apt and
+# dpkg, it's overly complicated and underdocumented.
+#
+# Copyright gregor herrmann <gregor+debian at comodo.priv.at>, 2007
+# Copyright Damyan Ivanov <dmn at debian.org>, 2007
+# Copyright MartÃn Ferrari <martin.ferrari at gmail.com>, 2007
+# Released under the terms of the GNU GPL 2
+
+package QA::DebianArchive;
+use strict;
+use warnings;
+
+our @ISA = "Exporter";
+our @EXPORT = qw(deb_download deb_get);
+
+use QA::Config;
+use QA::Cache;
+use QA::VerComp;
+use LWP::UserAgent;
+use IO::Uncompress::Gunzip;
+use HTML::TableExtract;
+
+# Table of cache validity, also used as index of valid "suites"
+my %ttl = (
+ new => 60, # 1 hour
+ incoming => 60, # 1 hour
+ experimental => 360, # 6 hours
+ unstable => 360, # 6 hours
+ testing => 360, # 6 hours
+ stable => 10080, # 1 week
+ oldstable => 10080, # 1 week
+);
+
+my $ua = new LWP::UserAgent;
+$ua->timeout(10);
+$ua->env_proxy;
+
+# Main routine.
+# * For each named suite in @LIST, checks cache validity and updates it if
+# necessary. If @list is empty, checks all seven suites.
+# * If $force, current cache is ignored.
+#
+# Re-generates and returns the hash of consolidated versions (key "global"),
+# which is keyed on package name and contains:
+# {
+# most_recent => $most_recent_version,
+# testing => $version_in_testing,
+# ....
+# }
+sub deb_download {
+ my($force, @list) = @_;
+ foreach(@list) {
+ die "Invalid suite: $_\n" unless(defined $ttl{$_});
+ }
+ @list = keys(%ttl) unless(@list);
+ my $data = {};
+ unless($force) {
+ $data = read_cache("archive", "", 0);
+ }
+ my $modified;
+ foreach my $src (@list) {
+ if($force or $ttl{$src} * 60 < time - find_timestamp($data, $src)) {
+ warn("$src is stale, getting new version\n") if($DEBUG);
+ my $d;
+ if($src eq "new") {
+ $d = get_new();
+ } elsif($src eq "incoming") {
+ $d = get_incoming();
+ } else {
+ $d = get_sources($src);
+ }
+ if($d) {
+ update_cache("archive", $d, $src, 1, 0);
+ $modified = 1;
+ }
+ }
+ }
+ return $data->{global} unless($modified);
+ # retain lock, we need consistency
+ warn("Re-generating consolidated hash\n") if($DEBUG);
+ $data = read_cache("archive", "", 1);
+ my $g = {};
+ foreach my $suite (keys(%$data)) {
+ next unless($ttl{$suite});
+ foreach my $pkg (keys(%{$data->{$suite}})) {
+ $g->{$pkg}{$suite} = $data->{$suite}{$pkg};
+ }
+ }
+ foreach(keys(%$g)) {
+ $g->{$_}{most_recent} = (sort( {
+ deb_compare($b, $a)
+ } values( %{$g->{$_}} )) )[0];
+ }
+ $data = update_cache("archive", $g, "global", 1, 0);
+ return $data->{global};
+}
+# Returns the consolidated hash of versions. Doesn't download anything.
+sub deb_get {
+ return read_cache("archive", "global", 0);
+}
+sub get_sources {
+ my($suite) = shift;
+ my %vers;
+ foreach my $section qw(main contrib non-free) {
+ my $url = "$MIRROR/debian/dists/$suite/$section/source/Sources.gz";
+ warn("Downloading $url\n") if($DEBUG);
+ my $res = $ua->get($url);
+ unless($res->is_success()) {
+ warn "Can't download $url: " . $res->message();
+ return 0;
+ }
+ # Still reading it all in memory, couldn't find any nice way to
+ # interact with gunzip
+ my $data = $res->decoded_content();
+ my $z = new IO::Uncompress::Gunzip(\$data);
+
+ # Blank line as "line" separator, so a "line" is a full record
+ local $/ = "";
+ while(<$z>) {
+ s/\n\s+//gm;
+ /^package:\s*(\S+)\s*$/mi or next;
+ my $pkg = $1;
+ /^version:\s*(\S+)\s*$/mi or next;
+ $vers{$pkg} = $1;
+ }
+ }
+ return \%vers;
+}
+sub get_incoming {
+ my $url = 'http://incoming.debian.org';
+ warn("Downloading $url\n") if($DEBUG);
+ my $res = $ua->get($url);
+ unless($res->is_success()) {
+ warn "Can't download $url: " . $res->message();
+ return 0;
+ }
+ my $data = $res->decoded_content();
+ my %vers;
+ while($data =~ /<a href="([^_]+)_(.+)\.dsc">/g) {
+ # debug
+ warn "existing $1: $vers{$1} / $2\n" if($DEBUG and defined($vers{$1}));
+ if(!defined $vers{$1} or deb_compare($2, $vers{$1}) > 0) {
+ warn "replaced $1: $vers{$1} -> $2\n" if($DEBUG and
+ defined($vers{$1}));
+ $vers{$1} = $2;
+ }
+ }
+ return \%vers;
+}
+sub get_new {
+ my $url = 'http://ftp-master.debian.org/new.html';
+ warn("Downloading $url\n") if($DEBUG);
+ my $res = $ua->get($url);
+ unless($res->is_success()) {
+ warn "Can't download $url: " . $res->message();
+ return 0;
+ }
+ my $data = $res->decoded_content();
+ my $te = new HTML::TableExtract( headers => [ qw(
+ Package Version Arch Distribution Age Maintainer Closes
+ ) ]);
+ $te->parse($data);
+ my %vers;
+ foreach my $table ($te->tables) {
+ foreach my $row ($table->rows) {
+ next unless $row->[2] =~ /source/;
+ my $pkg = $row->[0];
+ foreach(split(/\s+/, $row->[1])) {
+ next unless($_);
+ # debug
+ warn "existing $pkg: $vers{$pkg} / $_\n" if($DEBUG and
+ defined($vers{$pkg}));
+ if(!defined $vers{$pkg} or deb_compare($_, $vers{$pkg}) > 0) {
+ warn "replaced $pkg: $vers{$pkg} -> $_\n" if($DEBUG and
+ defined($vers{$pkg}));
+ $vers{$pkg} = $_;
+ }
+ }
+ }
+ }
+ return \%vers;
+}
+
+1;
Propchange: scripts/qa/QA/DebianArchive.pm
------------------------------------------------------------------------------
svn:keywords = QA/Cache.pm
Added: scripts/qa/QA/VerComp.pm
URL: http://svn.debian.org/wsvn/scripts/qa/QA/VerComp.pm?rev=8792&op=file
==============================================================================
--- scripts/qa/QA/VerComp.pm (added)
+++ scripts/qa/QA/VerComp.pm Sat Nov 3 15:56:00 2007
@@ -1,0 +1,69 @@
+# vim:ts=4:sw=4:et:ai:sts=4
+# $Id: Common.pm 6650 2007-08-15 10:17:36Z tincho-guest $
+#
+# Routines for comparing package versions, based on policy + dpkg code
+# I'm not using AptPkg::Version since it depends on having a working apt and
+# dpkg, it's overly complicated and underdocumented.
+#
+# Copyright MartÃn Ferrari <martin.ferrari at gmail.com>, 2007
+# Released under the terms of the GNU GPL 2
+
+package QA::VerComp;
+use strict;
+use warnings;
+
+our @ISA = "Exporter";
+our @EXPORT = qw( deb_compare );
+
+sub deb_parse($) {
+ my $v = shift;
+ unless($v =~ /^(?:(\d+):)?([A-Za-z0-9+.:~-]*?)(?:-([+.~A-Za-z0-9]+))?$/) {
+ warn "Invalid debian package version: $v\n";
+ return ();
+ };
+ return($1 || 0, $2, $3 || "");
+}
+sub dpkg_order($) {
+ my $v = shift;
+ return 0 if (! defined($v) or $v =~ /[0-9]/);
+ return -1 if ($v eq '~');
+ return ord($v) if ($v =~ /[a-zA-Z]/);
+ return ord($v) + 256;
+}
+sub deb_verrevcmp($$) {
+ my($a, $b) = @_;
+ my($x, $y);
+ while(length($a) or length($b)) {
+ while(1) {
+ $x = length($a) ? substr($a, 0, 1) : undef;
+ $y = length($b) ? substr($b, 0, 1) : undef;
+ last unless((defined $x and $x =~ /\D/) or
+ (defined $y and $y =~ /\D/));
+ my $r = dpkg_order($x) <=> dpkg_order($y);
+ return $r if($r);
+ substr($a, 0, 1, "") if(defined $x);
+ substr($b, 0, 1, "") if(defined $y);
+ }
+ $a =~ s/^(\d*)//;
+ $x = $1 || 0;
+ $b =~ s/^(\d*)//;
+ $y = $1 || 0;
+ my $r = $x <=> $y;
+ return $r if($r);
+ }
+ return 0;
+}
+sub deb_compare($$) {
+ my @va = deb_parse($_[0]) or return undef;
+ my @vb = deb_parse($_[1]) or return undef;
+
+ # Epoch
+ return $va[0] <=> $vb[0] unless($va[0] == $vb[0]);
+
+ my $upstreamcmp = deb_verrevcmp($va[1], $vb[1]);
+ return $upstreamcmp unless(defined $upstreamcmp and $upstreamcmp == 0);
+
+ return deb_verrevcmp($va[2], $vb[2]);
+}
+
+1;
Propchange: scripts/qa/QA/VerComp.pm
------------------------------------------------------------------------------
svn:keywords = QA/Cache.pm
More information about the Pkg-perl-cvs-commits
mailing list