r44072 - in /scripts/KGB: debian/control lib/App/KGB/Change.pm lib/App/KGB/Client.pm lib/App/KGB/Client/ServerRef.pm lib/App/KGB/Client/Subversion.pm lib/App/KGB/Commit.pm
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Sun Sep 13 20:36:51 UTC 2009
Author: dmn
Date: Sun Sep 13 20:36:47 2009
New Revision: 44072
URL: http://svn.debian.org/wsvn/?sc=1&rev=44072
Log:
create a modular client implementation
Added:
scripts/KGB/lib/App/KGB/Change.pm
scripts/KGB/lib/App/KGB/Client.pm (with props)
scripts/KGB/lib/App/KGB/Client/ServerRef.pm
scripts/KGB/lib/App/KGB/Client/Subversion.pm (with props)
scripts/KGB/lib/App/KGB/Commit.pm
Modified:
scripts/KGB/debian/control
Modified: scripts/KGB/debian/control
URL: http://svn.debian.org/wsvn/scripts/KGB/debian/control?rev=44072&op=diff
==============================================================================
--- scripts/KGB/debian/control (original)
+++ scripts/KGB/debian/control Sun Sep 13 20:36:47 2009
@@ -3,6 +3,7 @@
Priority: extra
Build-Depends: debhelper (>= 7.0.50)
Build-Depends-Indep: perl (>= 5.10),
+ libclass-accessor-perl,
libdigest-sha1-perl,
libpoe-component-irc-perl (>= 5.56),
libpoe-component-server-soap-perl,
@@ -39,6 +40,7 @@
Package: kgb-client
Architecture: all
Depends: ${misc:Depends}, ${perl:Depends}, perl (>= 5.10),
+ libclass-accessor-perl,
libdigest-sha1-perl,
libsoap-lite-perl,
libyaml-perl
Added: scripts/KGB/lib/App/KGB/Change.pm
URL: http://svn.debian.org/wsvn/scripts/KGB/lib/App/KGB/Change.pm?rev=44072&op=file
==============================================================================
--- scripts/KGB/lib/App/KGB/Change.pm (added)
+++ scripts/KGB/lib/App/KGB/Change.pm Sun Sep 13 20:36:47 2009
@@ -1,0 +1,146 @@
+# vim: ts=4:sw=4:et:ai:sts=4
+#
+# KGB - an IRC bot helping collaboration
+# Copyright © 2008 MartÃn Ferrari
+# Copyright © 2009 Damyan Ivanov
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program; if not, write to the Free Software Foundation, Inc., 51
+# Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+package App::KGB::Change;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+App::KGB::Change - a single file change
+
+=head1 SYNOPSIS
+
+ my $c = App::KGB::Change->new(
+ { action => "M", prop_change => 1, path => "/there" } );
+
+ print $c;
+
+ my $c = App::KGB::Change->new("(M+)/there");
+
+=head1 DESCRIPTION
+
+B<App::KGB::Change> encapsulates a sing epath change from a given change set
+(or commit).
+
+B<App::KGB::Change> overloads the "" operator in order to provide a default
+string representation of changes.
+
+=head1 FIELDS
+
+=over
+
+=item B<action> (B<mandatory>)
+
+The action performed on the item. Possible values are:
+
+=over
+
+=item B<M>
+
+The path was modified.
+
+=item B<A>
+
+The path was added.
+
+=item B<D>
+
+The path was deleted.
+
+=item B<R>
+
+The path was replaced.
+
+=back
+
+=item path (B<mandatory>)
+
+The path that was changed.
+
+=item prop_change
+
+Boolean. Indicated that some properties of the path, not the content were
+changed.
+
+=back
+
+=cut
+
+use base 'Class::Accessor::Fast';
+__PACKAGE__->mk_accessors(qw( action prop_change path ));
+
+use Carp qw(confess);
+
+=head1 CONSTRUCTOR
+
+=head2 new ( { I<initial values> } )
+
+More-or-less standard constructor.
+
+It can take a hashref with keys all the field names (See L<|FIELDS>).
+
+Or, it can take a single string, which is de-composed into components.
+
+See L<|SYNOPSIS> for examples.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new();
+
+ my $h = shift;
+ if ( ref($h) ) {
+ defined( $self->action( delete $h->{action} ) )
+ or confess "'action' is required";
+ defined( $self->path( delete $h->{path} ) )
+ or confess "'path' is required";
+ $self->prop_change( delete $h->{prop_change} );
+ }
+ else {
+ my ( $a, $pc, $p ) = $h =~ /^(?:\(([MADR])?(\+)?\))?(.+)$/
+ or confess "'$h' is not recognized as a change string";
+ $self->action( $a //= 'M' );
+ $self->prop_change( defined $pc );
+ $self->path($p);
+ }
+
+ return $self;
+}
+
+use overload '""' => \&_change2text;
+
+sub _change2text {
+ my $c = shift;
+ my $a = $c->action;
+ my $pc = $c->prop_change;
+ my $p = $c->path;
+
+ my $text = '';
+
+ # ignore flags for modifications (unlless there is also a property change)
+ $text = "($a$pc)" if $a ne 'M' or $pc;
+ $p =~ s,^/,,; # strip leading slash from paths
+ $text .= $p;
+ return $text;
+}
+
+1;
Added: scripts/KGB/lib/App/KGB/Client.pm
URL: http://svn.debian.org/wsvn/scripts/KGB/lib/App/KGB/Client.pm?rev=44072&op=file
==============================================================================
--- scripts/KGB/lib/App/KGB/Client.pm (added)
+++ scripts/KGB/lib/App/KGB/Client.pm Sun Sep 13 20:36:47 2009
@@ -1,0 +1,332 @@
+package App::KGB::Client;
+use utf8;
+require v5.10.0;
+
+# vim: ts=4:sw=4:et:ai:sts=4
+#
+# KGB - an IRC bot helping collaboration
+# Copyright © 2008 MartÃn Ferrari
+# Copyright © 2009 Damyan Ivanov
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program; if not, write to the Free Software Foundation, Inc., 51
+# Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+App::KGB::Client - relay commits to KGB servers
+
+=head1 SYNOPSIS
+
+ use App::KGB::Client;
+ my $client = App::KGB::Client( <parameters> );
+ $client->run;
+
+=head1 DESCRIPTION
+
+B<App::KGB::Client> is the backend behind L<kgb-client(1)>. It handles
+the repository-independent parts of sending the notifications to the KGB server,
+L<kgb-bot(1)>. Details about extracting change from commits, branches and
+modules is done by sub-classes specific to the version control system in use.
+
+=head1 CONFIGURATION
+
+The following parameters are accepted in the constructor:
+
+=over
+
+=item B<repo_id> I<repository name>
+
+Short repository identifier. Will be used for identifying the repository to the
+KGB daemon, which will also use this for IRC notifications. B<Mandatory>.
+
+=item B<uri> I<URI>
+
+URI of the KGB server. Something like C<http://some.server:port>. B<Mandatory>
+either as a top-level parameter or as a sub-parameter of B<servers> array.
+
+=item B<proxy> I<URI>
+
+URI of the SOAP proxy. If not given, it is the value of the B<uri> option, with
+C<?session=KGB> added.
+
+=item B<password> I<password>
+
+Password for authentication to the KGB server. B<Mandatory> either as a
+top-level parameter or as a sub-parameter of B<servers> array.
+
+=item B<timeout> I<seconds>
+
+Timeout for server communication. Default is 15 seconds, as we want instant IRC
+and commit response.
+
+=item B<servers>
+
+An array of servers, each an instance of L<App::KGB::Client::ServerRef> class.
+
+When several servers are configured, the list is shuffled and then the servers
+are tried one after another until a successful request is done, or the list is
+exhausted, in which case an exception is thrown.
+
+=item B<br_mod_re>
+
+A list of regular expressions (simple strings, not L<qr> objects) that serve
+for detection of branch and module of commits. Each item from the list is tried
+in turn, until an item is found that matches all the paths that were modified
+by the commit. Regular expressions must have two captures: the first one giving
+the branch name, and the second one giving the module name.
+
+All the paths that were modified by the commit must resolve to the same branch
+and module in order for the branch and module to be transmitted to the KGB
+server.
+
+ Example: ([^/]+)/([^/]+)/
+ # branch/module
+
+=item B<br_mod_re_swap> I<1>
+
+If you can only provide the module name in the first capture and the branch
+name in the second, use this option to signal the fact to B<kgb-client>.
+
+=item ignore_branch
+
+When most of the development is in one branch, transmitting it to the KGB
+server and seeing it on ORC all the time can be annoing. Therefore, if you
+define B<ignore_branch>, and a given commit is in a branch with that name, the
+branch name is not transmitted to the server. Module name is still transmitted.
+
+=back
+
+=cut
+
+require v5.10.0;
+use Carp qw(confess);
+use Digest::SHA1 qw(sha1_hex);
+use SOAP::Lite;
+use Getopt::Long;
+use List::Util ();
+use base 'Class::Accessor::Fast';
+__PACKAGE__->mk_accessors(
+ qw( repo_id servers br_mod_re br_mod_re_swap ignore_branch ));
+
+=head1 CONSTRUCTOR
+
+=head2 new ( { I<initial values> } )
+
+Standard constructor with initial values in a hashref.
+
+ my $c = App::KGB::Client->new(
+ { repo_id => 'my-repo',
+ servers => \@servers,
+ ...
+ }
+ );
+
+See L<|FIELDS> above.
+
+=cut
+
+sub new {
+ my $self = shift->SUPER::new(@_);
+ defined( $self->repo_id )
+ or confess "'repo_id' is mandatory";
+ $self->br_mod_re( [ $self->br_mod_re ] )
+ if $self->br_mod_re and not ref( $self->br_mod_re );
+ $self->servers( [] ) unless defined( $self->servers );
+
+ ref( $self->servers ) and ref( $self->servers ) eq 'ARRAY'
+ or confess "'servers' must be an arrayref";
+
+ @{ $self->servers } or confess "No 'servers' specified";
+
+ return $self;
+}
+
+=head1 METHODS
+
+=over
+
+=item detect_branch_and_module ( $changes )
+
+Given a set of changes (an arrayref of L<App::KGB::Change> objects), runs all
+the regular expressions as listed in B<br_mod_re> and if a regular expression
+that matches all the changed paths and returns the branch and module.
+
+In case the module detected is the same as B<ignore_module>, C<undef> is
+returned for module.
+
+ ( $branch, $module ) = $client->detect_branch_and_module($changes);
+
+=cut
+
+sub detect_branch_and_module {
+ my ( $self, $changes ) = @_;
+ return () unless $self->br_mod_re;
+
+ require Safe;
+ my $safe = Safe->new;
+ $safe->permit_only(
+ qw(padany lineseq match const leaveeval
+ rv2sv pushmark list warn)
+ );
+
+ my ( $branch, $module, $matched_re );
+
+ # for a successful branch/module extraction, we require that all the
+ # changes share the same branch/module
+ for my $c (@$changes) {
+ my ( $change_branch, $change_module );
+
+ for my $re ( @{ $self->br_mod_re } ) {
+ $re =~ s{,}{\\,}g; # escape commas
+ my $matching = "m,$re,; "
+ . ( $self->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 = $matched_re = 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 (@$changes) {
+
+ #warn "FROM ".$c->{path};
+ $_ = $c->path;
+ $safe->reval("s,.*$matched_re,,");
+ die "Eror while evaluating s/.*$matched_re//: $@" if $@;
+ $c->path($_);
+
+ #warn " TO $_";
+ }
+ }
+
+ $branch = undef
+ if $branch and $branch eq ( $self->ignore_branch // '' );
+
+ return ( $branch, $module );
+}
+
+=item process_commit ($commit)
+
+Processes a single commit, trying to send the changes summary to each of the
+servers, defined inn B<servers>, until some server is successfuly notified.
+
+=cut
+
+sub process_commit {
+ my ( $self, $commit ) = @_;
+
+ my ( $branch, $module )
+ = $self->detect_branch_and_module( $commit->changes );
+
+ my @servers = List::Util::shuffle( @{ $self->servers } );
+
+ # try all servers in turn until someone succeeds
+ my $failure;
+ for my $srv (@servers) {
+ $failure = eval {
+ $srv->send_changes( $self->repo_id, $commit, $branch, $module );
+ 0;
+ } // 1;
+
+ warn $@ if $@;
+
+ last unless $failure;
+ }
+
+ die "Unable to complete notification. All servers failed\n"
+ if $failure;
+}
+
+=item process
+
+The main processing method. Calls B<describe_commit> and while it returns true
+values, gives them to B<process_commit>.
+
+=cut
+
+sub process {
+ my $self = shift;
+
+ while ( my $commit = $self->describe_commit ) {
+ $self->process_commit($commit);
+ }
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 PROVIDING REPOSITORY-SPECIFIC FUNCTIONALITY
+
+L<App::KGB::Client> is a generic class providing repository-agnostic
+functionality. All repository-specific methods are to be provided by classes,
+inheriting from L<App::KGB::Client>. See L<App::KGB::Client::Subversion> and
+L<App::KGB::Client::Git>.
+
+Repository classes must provide the following method:
+
+=over
+
+=item B<dsescribe_commit>
+
+This method returns an L<App::KGB::Commit> object that
+represent a single commit of the repository.
+
+B<describe_commit> is called several times, until it returns C<undef>. The idea
+is that a single L<App::KGB::Client> run can be used to process several commits
+(for example if the repository is L<Git>). If this is the case each call to
+B<describe_commit> shall return information about the next commit in the
+serries. For L<Subversion>, this module is expected to return only one commit,
+subsequent calls shall return C<undef>.
+
+=cut
+
Propchange: scripts/KGB/lib/App/KGB/Client.pm
------------------------------------------------------------------------------
svn:executable = *
Added: scripts/KGB/lib/App/KGB/Client/ServerRef.pm
URL: http://svn.debian.org/wsvn/scripts/KGB/lib/App/KGB/Client/ServerRef.pm?rev=44072&op=file
==============================================================================
--- scripts/KGB/lib/App/KGB/Client/ServerRef.pm (added)
+++ scripts/KGB/lib/App/KGB/Client/ServerRef.pm Sun Sep 13 20:36:47 2009
@@ -1,0 +1,173 @@
+# vim: ts=4:sw=4:et:ai:sts=4
+#
+# KGB - an IRC bot helping collaboration
+# Copyright © 2008 MartÃn Ferrari
+# Copyright © 2009 Damyan Ivanov
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program; if not, write to the Free Software Foundation, Inc., 51
+# Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+package App::KGB::Client::ServerRef;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+App::KGB::Client::ServerRef - server instance in KGB client
+
+=head1 SYNOPSIS
+
+ use App::KGB::Client::ServerRef;
+ my $s = App::KGB::Client::ServerRef->new(
+ { uri => "http://some.server:port/",
+ password => 's3cr1t',
+ timeout => 5
+ }
+ );
+
+ $s->send_changes( $repo_id, $commit, $branch, $module );
+
+=head1 DESCRIPTION
+
+B<App::KGB::Client::ServerRef> is used in L<App::KGB::Client> to refer to
+remote KGB server instances. It encapsulates sending change sets to the remote
+server, maintaining the SOAP protocol encapsulation and authentication to the
+remote KGB server.
+
+=head1 CONSTRUCTOR
+
+=over
+
+=item new
+
+The usual constructor. Accepts a hashref of initialiers.
+
+=back
+
+=head1 FIELDS
+
+=over
+
+=item B<uri> (B<mandatory>)
+
+The URI of the remote KGB server. Something like C<http://some.host:port/>.
+
+=item B<proxy>
+
+This is the SOAP proxy used to communicate with the server. If omitted,
+defaults to the value of B<uri> field, with C<?session=KGB> appended.
+
+=item B<password> (B<mandatory>)
+
+Password, to be used for authentication to the remote KGB server.
+
+=item B<timeout>
+
+Specifies the timeout for the SOAP transaction in seconds. Defaults to 15
+seconds.
+
+=back
+
+=head1 METHODS
+
+=over
+
+=item B<send_changes> (I<message parameters>)
+
+Transmits the change set and all data about it along with the necessary
+authentication hash. If error occures, an exception is thrown.
+
+Message parameters are passed as arguments in the following order:
+
+=over
+
+=item Repository id.
+
+=item Commit (an instance of L<App::KGB::Commit>)
+
+=item Branch
+
+=item Module
+
+=back
+
+=back
+
+=cut
+
+require v5.10.0;
+use base 'Class::Accessor::Fast';
+
+__PACKAGE__->mk_accessors( qw( uri proxy password timeout ) );
+
+use Carp qw(confess);
+use Digest::SHA1 qw(sha1_hex);
+use SOAP::Lite;
+
+sub new {
+ my $self = shift->SUPER::new( @_ );
+
+ defined( $self->uri )
+ or confess "'uri' is mandatory";
+ defined( $self->proxy )
+ or $self->proxy( $self->uri . '?session=KGB' );
+ defined( $self->password )
+ or confess "'password' is mandatory";
+
+ return $self;
+}
+
+sub send_changes {
+ my ( $self, $repo_id, $commit, $branch, $module ) = @_;
+
+ my $s = SOAP::Lite->new( uri => $self->uri, proxy => $self->proxy );
+ $s->transport->proxy->timeout( $self->timeout // 15 );
+
+ # v1 protocol
+ my $checksum = sha1_hex(
+ $repo_id, $commit->id,
+ map( "$_", @{ $commit->changes } ), $commit->log,
+ $commit->author, $branch // (),
+ $module // (), $self->password
+ );
+
+ my $res = $s->commit(
+ [ 1, $repo_id,
+ $checksum,
+ SOAP::Data->type( int => $commit->id ),
+ [ map { SOAP::Data->type( string => "$_" ) }
+ @{ $commit->changes }
+ ],
+ SOAP::Data->type( string => $commit->log ),
+ SOAP::Data->type( string => $commit->author ),
+ SOAP::Data->type( string => $branch ),
+ SOAP::Data->type( string => $module ),
+ ]
+ );
+
+ if ( $res->fault ) {
+ die 'SOAP FAULT while talking to '
+ . $self->uri . "\n"
+ . 'FAULT MESSAGE: ', $res->fault->{faultstring}, "\n"
+ . (
+ $res->fault->{detail}
+ ? 'FAULT DETAILS: ' . $res->fault->{detail}
+ : ''
+ );
+ }
+
+ #print $res->result(), "\n";
+}
+
+1;
Added: scripts/KGB/lib/App/KGB/Client/Subversion.pm
URL: http://svn.debian.org/wsvn/scripts/KGB/lib/App/KGB/Client/Subversion.pm?rev=44072&op=file
==============================================================================
--- scripts/KGB/lib/App/KGB/Client/Subversion.pm (added)
+++ scripts/KGB/lib/App/KGB/Client/Subversion.pm Sun Sep 13 20:36:47 2009
@@ -1,0 +1,170 @@
+package App::KGB::Client::Subversion;
+use utf8;
+
+# vim: ts=4:sw=4:et:ai:sts=4
+#
+# KGB - an IRC bot helping collaboration
+# Copyright © 2008 MartÃn Ferrari
+# Copyright © 2009 Damyan Ivanov
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program; if not, write to the Free Software Foundation, Inc., 51
+# Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+App::KGB::Client::Subversion - KGB interface to Subversion
+
+=head1 SYNOPSIS
+
+ use App::KGB::Client::Subversion;
+ my $client = App::KGB::Client::Subversion(
+ # common App::KGB::Client parameters
+ repo_id => 'my-repo',
+ ...
+ # Subversion-specific
+ repo_path => '/svn/project',
+ revision => 42,
+ );
+ $client->run;
+
+=head1 DESCRIPTION
+
+B<App::KGB::Client::Subversion> provides Subversion-specific retrieval of
+commits and changes for L<KGB::Client>.
+
+=head1 CONSTRUCTOR
+
+=head2 B<new> ( { initializers } )
+
+Standard constructor. Accepts inline hash with initial field values.
+
+=head1 FIELDS
+
+App:KGB::Client::Subversion defines two additional fields:
+
+=over
+
+=item B<repo_path> (B<mandatory>)
+
+Phisical path to Subversion repository.
+
+=item B<revision>
+
+The revision about which to notify. If ommitted defaults to the last revision
+of the repository.
+
+=back
+
+=head1 METHODS
+
+=over
+
+=item describe_commit
+
+The first time this method is called, it retrieves commit number and repository
+path from command-line parameters and returns an instance of
+L<App::KGB::Commit> class describing the commit.
+
+All subsequential invocations return B<undef>.
+
+=back
+
+=cut
+
+require v5.10.0;
+use base 'App::KGB::Client';
+use App::KGB::Change;
+use App::KGB::Commit;
+use Carp qw(confess);
+use SVN::Fs;
+use SVN::Repos;
+use SVN::Core;
+__PACKAGE__->mk_accessors(qw( _called repo_path revision ));
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->_called(0);
+
+ defined( $self->repo_path )
+ or confess "'repo_path' is mandatory";
+
+ return $self;
+}
+
+sub describe_commit {
+ my ($self) = @_;
+
+ return undef if $self->_called;
+
+ my ( $author, $log, @changes );
+
+ # Shut up the perl compiler warnings
+ if ( $SVN::Fs::PathChange::modify
+ and $SVN::Fs::PathChange::add
+ and $SVN::Fs::PathChange::delete
+ and $SVN::Fs::PathChange::replace )
+ {
+ }
+
+ my $repo = SVN::Repos::open( $self->repo_path );
+ my $fs = $repo->fs or die $!;
+
+ $self->revision( $fs->youngest_rev ) unless defined( $self->revision );
+ $log = $fs->revision_prop( $self->revision, "svn:log" );
+ $author = $fs->revision_prop( $self->revision, "svn:author" );
+
+ my $root = $fs->revision_root( $self->revision );
+ my $changed = $root->paths_changed();
+ foreach ( keys %$changed ) {
+ my $k = $changed->{$_}->change_kind();
+ if ( $k == $SVN::Fs::PathChange::modify ) {
+ $k = "M";
+ }
+ elsif ( $k == $SVN::Fs::PathChange::add ) {
+ $k = "A";
+ }
+ elsif ( $k == $SVN::Fs::PathChange::delete ) {
+ $k = "D";
+ }
+ elsif ( $k == $SVN::Fs::PathChange::replace ) {
+ $k = "R";
+ }
+
+ my $pm = $changed->{$_}->prop_mod();
+
+ push @changes,
+ App::KGB::Change->new(
+ { action => $k,
+ prop_change => $pm,
+ path => $_,
+ }
+ );
+ }
+
+ $self->_called(1);
+
+ return App::KGB::Commit->new(
+ { id => $self->revision,
+ changes => \@changes,
+ author => $author,
+ log => $log,
+ }
+ );
+}
+
+1;
Propchange: scripts/KGB/lib/App/KGB/Client/Subversion.pm
------------------------------------------------------------------------------
svn:executable = *
Added: scripts/KGB/lib/App/KGB/Commit.pm
URL: http://svn.debian.org/wsvn/scripts/KGB/lib/App/KGB/Commit.pm?rev=44072&op=file
==============================================================================
--- scripts/KGB/lib/App/KGB/Commit.pm (added)
+++ scripts/KGB/lib/App/KGB/Commit.pm Sun Sep 13 20:36:47 2009
@@ -1,0 +1,98 @@
+# vim: ts=4:sw=4:et:ai:sts=4
+#
+# KGB - an IRC bot helping collaboration
+# Copyright © 2008 MartÃn Ferrari
+# Copyright © 2009 Damyan Ivanov
+#
+# This program is free software; you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program; if not, write to the Free Software Foundation, Inc., 51
+# Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+package App::KGB::Commit;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+App::KGB::Commit - a single commit
+
+=head1 SYNOPSIS
+
+ my $c = App::KGB::Commit->new(
+ { id => 4536,
+ changes => ["(M)/there"],
+ log => "fixed /there",
+ author => "My Self <mself at here.at>",
+ branch => "trunk",
+ module => "test",
+ }
+ );
+
+=head1 DESCRIPTION
+
+B<App::KGB::Change> encapsulates a single commit. A commit has several
+properties: an ID, a list of changes, an author, a log message, optionally also
+a branch and a module.
+
+=head1 FIELDS
+
+=over
+
+=item B<id> (B<mandatory>)
+
+The commit ID that uniquely identifies it in the repository.
+
+=item B<changes>
+
+An arrayref of L<App::KGB::Change> instances or other objects that behave as
+strings.
+
+=item B<author>
+
+=item B<log>
+
+=item B<branch>
+
+=item B<module>
+
+=back
+
+=cut
+
+use base 'Class::Accessor::Fast';
+__PACKAGE__->mk_accessors( qw( id changes log author branch module ) );
+
+use Carp qw(confess);
+
+=head1 CONSTRUCTOR
+
+=head2 new ( { I<initial field values> } )
+
+Standard constructor. Accepts a hashref with field values.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+
+ defined( $self->id )
+ or confess "'id' is required";
+ not defined( $self->changes )
+ or ref( $self->changes ) and ref( $self->changes ) eq 'ARRAY'
+ or confess "'changes' must be an arrayref";
+
+ return $self;
+}
+
+1;
More information about the Pkg-perl-cvs-commits
mailing list