r8844 - in /scripts/qa/QA: Cache.pm Config.pm Svn.pm
tincho-guest at users.alioth.debian.org
tincho-guest at users.alioth.debian.org
Sun Nov 4 17:16:28 UTC 2007
Author: tincho-guest
Date: Sun Nov 4 17:16:28 2007
New Revision: 8844
URL: http://svn.debian.org/wsvn/?sc=1&rev=8844
Log:
The big missing piece: svn repo extraction
Added:
scripts/qa/QA/Svn.pm (with props)
Modified:
scripts/qa/QA/Cache.pm
scripts/qa/QA/Config.pm
Modified: scripts/qa/QA/Cache.pm
URL: http://svn.debian.org/wsvn/scripts/qa/QA/Cache.pm?rev=8844&op=diff
==============================================================================
--- scripts/qa/QA/Cache.pm (original)
+++ scripts/qa/QA/Cache.pm Sun Nov 4 17:16:28 2007
@@ -183,7 +183,7 @@
return $ref;
}
# Search a stamp in $hash, starting at $path and going upwards until the
-# root
+# root. Returns 0 if not found.
sub find_stamp {
my($hash, $path) = @_;
$path ||= "";
@@ -197,6 +197,6 @@
if(not $ctsmp and exists($hash->{"/stamp"})) {
$ctsmp = $hash->{"/stamp"};
}
- return $ctsmp;
+ return $ctsmp || 0;
}
1;
Modified: scripts/qa/QA/Config.pm
URL: http://svn.debian.org/wsvn/scripts/qa/QA/Config.pm?rev=8844&op=diff
==============================================================================
--- scripts/qa/QA/Config.pm (original)
+++ scripts/qa/QA/Config.pm Sun Nov 4 17:16:28 2007
@@ -11,6 +11,7 @@
our @EXPORT = qw(
$SVN_REPO
+ $SVN_PKG_PATH
$MIRROR
$CPAN_MIRROR
$CACHEDIR
@@ -20,6 +21,7 @@
our @ISA = "Exporter";
our $SVN_REPO = "svn://svn.debian.org/svn/pkg-perl";
+our $SVN_PKG_PATH = "trunk";
our $MIRROR = "ftp://ftp.debian.org/debian";
our $CPAN_MIRROR = "ftp://cpan.org/pub/CPAN";
our $CACHEDIR = "$ENV{HOME}/.dpg/versioncheck";
Added: scripts/qa/QA/Svn.pm
URL: http://svn.debian.org/wsvn/scripts/qa/QA/Svn.pm?rev=8844&op=file
==============================================================================
--- scripts/qa/QA/Svn.pm (added)
+++ scripts/qa/QA/Svn.pm Sun Nov 4 17:16:28 2007
@@ -1,0 +1,246 @@
+# vim:ts=4:sw=4:et:ai:sts=4
+# $Id$
+#
+# Module for retrieving data from the SVN repository. It understands SVN
+# revisions and uses them instead of timestamps for checking cache validity. It
+# parses changelog and watch files.
+#
+# 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::Svn;
+use strict;
+use warnings;
+
+our @ISA = "Exporter";
+our @EXPORT = qw(svn_download svn_get);
+
+use IO::Scalar;
+use Digest::MD5 "md5_hex";
+use Parse::DebianChangelog;
+use QA::Cache;
+use QA::Common;
+use QA::Config qw($SVN_REPO $SVN_PKG_PATH);
+use SVN::Client;
+
+sub svn_download {
+ my($force, $revision, @dirlist) = @_;
+ $force ||= 0;
+ $revision ||= 0;
+ debug("svn_download($force, $revision, (@dirlist))");
+
+ my $svnpath = "$SVN_REPO/$SVN_PKG_PATH";
+ my $complete = ! @dirlist;
+
+ our $svn = SVN::Client->new();
+ unless($revision) {
+ info("Retrieving last revision number from SVN");
+ $svn->info($svnpath, undef, "HEAD", sub {
+ $revision = $_[1]->rev();
+ }, 0);
+ }
+
+ if($complete) {
+ info("Retrieving list of directories in SVN");
+ @dirlist = keys(%{$svn->ls($svnpath, 'HEAD', 0)});
+ }
+ my(@changed, %svn);
+ if($force) {
+ @changed = @dirlist;
+ } else {
+ my $cdata = read_cache("svn", "", 0);
+ if(find_stamp($cdata, "") == $revision) {
+ return $cdata; # Cache is up-to-date
+ }
+
+ # Stamps from cache
+ my %cache_vers = map({ $_ => find_stamp($cdata, $_) } @dirlist);
+ # Never updated
+ @changed = grep( { not $cache_vers{$_} } @dirlist);
+
+ # Now search in the SVN log to see if there's any interesting change
+ # Remove from list already updated parts of the cache
+ my @to_check = grep( {
+ $cache_vers{$_} and $cache_vers{$_} < $revision } @dirlist);
+ if(@to_check) {
+ my @paths = map({ "$svnpath/$_" } @to_check);
+ my $min_rev = (sort(map({ $cache_vers{$_} } @to_check)))[0];
+
+ my %changed = ();
+ $svn->log(\@paths, $min_rev, "HEAD", 1, 1, sub {
+ foreach(keys %{$_[0]}) {
+ last if($_[1] < $cache_vers{$1});
+ next unless(m{/([^/]+)/debian/(changelog|watch)$});
+ $changed{$1} = 1;
+ }
+ });
+ push @changed, keys %changed;
+ # Copy the not-changed dirs that we want to have the stamp bumped
+ foreach(grep({ ! $changed{$_} } @dirlist)) {
+ $svn{$_} = $cdata->{$_} if($cdata->{$_});
+ }
+ }
+ }
+ foreach my $dir (@changed) {
+ $svn{$dir} = {};
+ info("Retrieving changelog for $dir");
+ my $changelog = get_svn_file($svn, "$svnpath/$dir/debian/changelog");
+
+ unless($changelog) {
+ $svn{$dir}{error} = "Missing";
+ next;
+ }
+ my $parser = Parse::DebianChangelog->init({
+ instring => $changelog });
+ my $error = $parser->get_error() or $parser->get_parse_errors();
+ if($error) {
+ error($error);
+ $svn{$dir}{error} = "Invalid";
+ next;
+ }
+
+ my($lastchl, $unfinishedchl);
+ foreach($parser->data()) {
+ if($_->Distribution eq "unstable") {
+ $lastchl = $_;
+ last;
+ }
+ if(! $unfinishedchl and $_->Distribution eq "UNRELEASED") {
+ $unfinishedchl = $_;
+ }
+ }
+ unless($lastchl or $unfinishedchl) {
+ $svn{$dir}{error} = "Invalid";
+ next;
+ }
+ if($lastchl) {
+ $svn{$dir}{version} = $lastchl->Version;
+ $svn{$dir}{date} = $lastchl->Date;
+ $svn{$dir}{changer} = $lastchl->Maintainer;
+ }
+ if($unfinishedchl) {
+ $svn{$dir}{un_version} = $unfinishedchl->Version;
+ $svn{$dir}{un_date} = $unfinishedchl->Date;
+ $svn{$dir}{un_changer} = $unfinishedchl->Maintainer;
+ }
+ $svn{$dir}{pkgname} = $parser->dpkg()->{Source};
+
+ info("Retrieving watchfile for $dir");
+ my $watch = get_svn_file($svn, "$svnpath/$dir/debian/watch");
+ unless($watch) {
+ $svn{$dir}{watch_error} = "Missing";
+ next;
+ }
+ $watch = parse_watch($svn{$dir}{version}, $watch);
+ # Returns undef on error
+ unless($watch and @$watch) {
+ $svn{$dir}{watch_error} = "Invalid";
+ next;
+ }
+ $svn{$dir}{watch} = $watch;
+ }
+ # if $complete, retain lock
+ my $cdata = update_cache("svn", \%svn, "", $complete, $complete);
+ return $cdata unless($complete);
+
+ my @pkglist = grep({ $svn{$_}{pkgname} } @dirlist);
+ my %pkglist = map({ $svn{$_}{pkgname} => 1 } @pkglist);
+ update_cache("consolidated", \%pkglist, "pkglist", 1, 1);
+
+ my %svn2;
+ foreach(@pkglist) {
+ $svn2{$svn{$_}{pkgname}} = $svn{$_};
+ $svn2{$svn{$_}{pkgname}}{dir} = $_;
+ delete $svn2{$svn{$_}{pkgname}}{watch};
+ delete $svn2{$svn{$_}{pkgname}}{pkgname};
+ }
+ update_cache("consolidated", \%svn2, "svn", 1, 0);
+ unlock_cache("svn");
+ return $cdata;
+}
+# Returns the consolidated hash of svn info. Doesn't download anything.
+sub svn_get {
+ return read_cache("consolidated", "svn", 0);
+}
+# Parses watchfile, returns an arrayref containing one element for each source,
+# consisting of the URL spec, an MD5 sum of the line (to detect changes from
+# the watch module), the mangled debian version, and a hash of options.
+sub parse_watch($$) {
+ my($version, $watch) = @_;
+ $version ||= '';
+ $watch ||= '';
+ debug("parse_watch('$version', '...')");
+ $watch =~ s/\\\n//gs;
+
+ # Strip epoch and debian release
+ $version =~ s/^(?:\d+:)?(.+?)(?:-[^-]+)?$/$1/;
+
+ my @watch_lines = split(/\n/, $watch);
+ @watch_lines = grep((!/^#/ and !/^version\s*=/ and !/^\s*$/),
+ @watch_lines);
+
+ my @wspecs;
+ foreach(@watch_lines) {
+ debug("Watch line: $_");
+
+ # opts either contain no spaces, or is enclosed in double-quotes
+ my $opts = $1 if(s!^\s*opts="([^"]*)"\s+!! or
+ s!^\s*opts=(\S*)\s+!!);
+ debug("Watch line options: $opts") if($opts);
+
+ # several options are separated by comma and commas are not allowed
+ # within
+ my @opts = split(/\s*,\s*/, $opts) if($opts);
+ my %opts;
+ foreach(@opts) {
+ next if /^(?:active|passive|pasv)$/;
+ /([^=]+)=(.*)/;
+ my($k, $v) = ($1, $2);
+ debug("Watch option $k: $v");
+ if($k eq 'versionmangle') {
+ push @{$opts{uversionmangle}}, $v;
+ push @{$opts{dversionmangle}}, $v;
+ } else {
+ push @{$opts{$k}}, $v;
+ }
+ }
+ my $unmangled = $version;
+ if($version and $opts{dversionmangle}) {
+ foreach(split(/;/, @{$opts{dversionmangle}})) {
+ eval "\$unmangled =~ $_";
+ if($@) {
+ error("Invalid watchfile: $@");
+ return undef;
+ }
+ }
+ }
+ push @wspecs, {
+ line => $_,
+ unmangled_ver => $unmangled,
+ md5 => md5_hex($_),
+ opts => \%opts
+ };
+ }
+ return \@wspecs;
+}
+sub get_svn_file($$) {
+ my($svn, $target) = @_;
+ my $svn_error;
+ my $data;
+ {
+ my $fh = IO::Scalar->new(\$data);
+ local $SVN::Error::handler = undef;
+ ($svn_error) = $svn->cat($fh, $target , 'HEAD');
+ }
+ if(SVN::Error::is_error($svn_error)) {
+ if($svn_error->apr_err() == $SVN::Error::FS_NOT_FOUND) {
+ $svn_error->clear();
+ } else {
+ SVN::Error::croak_on_error($svn_error);
+ }
+ }
+ return $data;
+}
+1;
Propchange: scripts/qa/QA/Svn.pm
------------------------------------------------------------------------------
svn:keywords = Id
More information about the Pkg-perl-cvs-commits
mailing list