r43744 - in /scripts/KGB: TODO client/KGB_sendcommit client/kgb-client.conf.sample
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Sat Sep 5 18:14:31 UTC 2009
Author: dmn
Date: Sat Sep 5 18:14:26 2009
New Revision: 43744
URL: http://svn.debian.org/wsvn/?sc=1&rev=43744
Log:
add support for discovering branch and package name
the actual discovery is made by regular expressions in the
configuration file
Modified:
scripts/KGB/TODO
scripts/KGB/client/KGB_sendcommit
scripts/KGB/client/kgb-client.conf.sample
Modified: scripts/KGB/TODO
URL: http://svn.debian.org/wsvn/scripts/KGB/TODO?rev=43744&op=diff
==============================================================================
--- scripts/KGB/TODO (original)
+++ scripts/KGB/TODO Sat Sep 5 18:14:26 2009
@@ -13,8 +13,6 @@
prop_change => 1, # or 0 (or not present)
}
-* transmit branch and package as separate fields so that the server
- can highlight them
* respond to IRC commands
+ should listen only to identified users from a configured list
+ possible commands:
Modified: scripts/KGB/client/KGB_sendcommit
URL: http://svn.debian.org/wsvn/scripts/KGB/client/KGB_sendcommit?rev=43744&op=diff
==============================================================================
--- scripts/KGB/client/KGB_sendcommit (original)
+++ scripts/KGB/client/KGB_sendcommit Sat Sep 5 18:14:26 2009
@@ -1,5 +1,6 @@
#!/usr/bin/perl
use utf8;
+require v5.10.0;
# vim: ts=4:sw=4:et:ai:sts=4
#
# KGB - an IRC bot helping collaboration
@@ -29,7 +30,7 @@
use YAML ();
my( $conf_file, $uri, $proxy, $repo_id, $password, $timeout,
- $repo_type, @servers,
+ $repo_type, @br_mod_re, $br_mod_re_swap, @servers,
);
GetOptions(
'conf=s' => \$conf_file,
@@ -38,6 +39,10 @@
'repo-id=s' => \$repo_id,
'pass=s' => \$password,
'timeout=s' => \$timeout,
+ 'branch-and-module-re=s' => \@br_mod_re,
+ 'br-mod-re=s' => \@br_mod_re,
+ 'branch-and-module-re-swap!' => \$br_mod_re_swap,
+ 'br-mod-re!' => \$br_mod_re_swap,
'repository'=> \$repo_type,
) or exit 1;
@@ -55,6 +60,9 @@
$repo_id ||= $conf->{'repo-id'};
$password ||= $conf->{'password'};
$timeout ||= $conf->{'timeout'};
+ @br_mod_re = @{ $conf->{'branch-and-module-re'} }
+ if !@br_mod_re and $conf->{'branch-and-module-re'};
+ $br_mod_re_swap //= $conf->{'branch-and-module-re-swap'};
@servers = @{ $conf->{servers} } if $conf->{servers};
}
@@ -118,6 +126,67 @@
die "Repository type '$repo_type' not supported\n";
}
+my ( $branch, $module, $matched_re );
+if (@br_mod_re) {
+ require Safe;
+ my $safe = Safe->new;
+ $safe->permit_only(qw(padany lineseq match const leaveeval
+ rv2sv pushmark list warn));
+
+ # for a successful branch/module extraction, we require that all the
+ # changes share the same branch/module
+ for my $c(@changed) {
+ my ( $change_branch, $change_module );
+
+ for my $re (@br_mod_re) {
+ $re =~ s{,}{\\,}g; # escape commas
+ my $matching = "m,$re,; "
+ . ( $br_mod_re_swap ? '($2,$1)' : '($1,$2)' );
+
+ $_ = $c->{path};
+ ( $change_branch, $change_module ) = $safe->reval($matching);
+ die "Error while evaluating `$re': $@" if $@;
+
+ if ( defined($change_branch) and defined($change_module) ) {
+ $matched_re = $re;
+ last;
+ }
+ }
+
+ # some change cannot be tied to a branch and a module?
+ if ( !defined( $change_branch // $change_module ) ) {
+ $branch = $module = undef;
+ last;
+ }
+
+ if ( defined($branch) ) {
+ # this change is for a different branch/module?
+ if ( $branch ne $change_branch or $module ne $change_module ) {
+ $branch = $module = undef;
+ last;
+ }
+ }
+ else {
+ # first change, store branch and module
+ $branch = $change_branch;
+ $module = $change_module;
+ }
+ }
+
+ # remove the part that have matched as it contains information about the
+ # branch and module that we provide otherwise
+ if ($matched_re) {
+ #warn "Branch: ".($branch||"NONE");
+ #warn "Module: ".($module||"NONE");
+ $safe->permit(qw(subst));
+ for my $c(@changed) {
+ $_ = $c->{path};
+ $safe->reval("s,.*$matched_re,,");
+ die "Eror while evaluating s/.*$matched_re//: $@" if $@;
+ $c->{path} = $_;
+ }
+ }
+}
#utf8::encode($author);
#utf8::encode($log);
#utf8::encode($_) foreach(@changed);
@@ -129,7 +198,9 @@
# v1 protocol
my $checksum = sha1_hex($repo_id, $rev, map( change2text($_), @changed ),
- $log, $author, $password);
+ $log, $author, $branch || (), $module || (), $password);
+
+#warn( change2text($_), "\n" ) for @changed;
# try all servers in turn until someone succeeds
for my $srv (@servers) {
@@ -143,7 +214,10 @@
[ map( SOAP::Data->type( string => change2text($_) ),
@changed ) ],
SOAP::Data->type(string => $log),
- SOAP::Data->type(string => $author)]);
+ SOAP::Data->type(string => $author),
+ $branch ? SOAP::Data->type( string => $branch) : (),
+ $module ? SOAP::Data->type( string => $module) : (),
+ ]);
if( $res->fault ) {
warn 'SOAP FAULT while talking to '.$srv->{uri}."\n";
Modified: scripts/KGB/client/kgb-client.conf.sample
URL: http://svn.debian.org/wsvn/scripts/KGB/client/kgb-client.conf.sample?rev=43744&op=diff
==============================================================================
--- scripts/KGB/client/kgb-client.conf.sample (original)
+++ scripts/KGB/client/kgb-client.conf.sample Sat Sep 5 18:14:26 2009
@@ -1,6 +1,24 @@
---
# repo-id is mandatory
repo-id: foo
+# optional list of regular expressions for matching branch and module name each
+# entry is matched against the changed path, $1 is supposed to be the branch
+# name, $2 - the module (package) name
+# forward slashes are escaped, so no special treatment is needed here
+# the sample is taken from pkg-perl SVN repository, which is Layout 2 (all
+# trunks under trunk/ and has a special place for applications and
+# almost-removed stuff)
+branch-and-module-re:
+ - "/(trunk|tags|apps|attic)/([^/]+)"
+ - "/branches/([^/]+)/([^/]+)"
+# for layout 1 package -> trunk/branches/tags) naturally the package name comes
+# into $1 and the branch - into $2, to remedy the situation, a special
+# configuration variable is introduced
+# branch-and-module-re-swap: 1
+# branch-and-mmodule-re:
+# - "/packages/([^/]+)/branches/([^/]+)"
+# - "/packages/([^/]+)/(trunk|tags)"
+#
# some global parameters can be set for all servers
password: "very secret"
timeout: 15
More information about the Pkg-perl-cvs-commits
mailing list