view release on metacpan or  search on metacpan

lib/App/KGB/Client.pm  view on Meta::CPAN

Project module. Default: purple.

=item web

URL to commit information. Default: silver.

=item separator

The separator before the commit log. Default: none.

=back

=back

=cut

require v5.10.0;
use Carp qw(confess);
use Digest::MD5 qw(md5_hex);
use Digest::SHA qw(sha1_hex);
use DirHandle ();
use File::Basename qw(dirname);
use SOAP::Lite;
use Getopt::Long;
use List::Util ();
use User::pwent;
use YAML ();
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors(
    qw( repo_id servers br_mod_re mod_br_re module ignore_branch
        single_line_commits use_irc_notices use_color status_dir verbose protocol
        web_link short_url_service _last_server
        msg_template
        style colors painter
        batch_messages
        _full_user_name
        )
);

=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 ( $class, $init ) = @_;

    my $self = $class->SUPER::new(
        {   use_color => 1,
            %$init,
        }
    );

    print "Configuration: " . YAML::Dump(@_) if $self->verbose;

    defined( $self->repo_id )
        or confess "'repo_id' is mandatory";
    $self->br_mod_re( [ $self->br_mod_re // () ] )
        if not ref( $self->br_mod_re );
    $self->mod_br_re( [ $self->mod_br_re // () ] )
        if not ref( $self->mod_br_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";

    if ( $self->status_dir ) {
        if ( not -e $self->status_dir ) {
            warn "Status directory ".$self->status_dir." doesn't exist.\n";
            $self->status_dir(undef);
        }
        elsif ( not -d $self->status_dir ) {
            warn $self->status_dir." is not a directory\n";
            $self->status_dir(undef);
        }
    }

    $self->protocol('auto') unless defined( $self->protocol );

    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 B<mod_br_re> and if a
regular expression that matches all the changed paths and returns the branch
and module.

    ( $branch, $module ) = $client->detect_branch_and_module($changes);

=cut

sub _run_matches {
    my ( $safe, $changes, $res, $swap ) = @_;

    for my $re (@$res) {
        $re =~ s{,}{\\,}g;    # escape commas
        my $matching = "m,$re,; " . ( $swap ? '($2,$1)' : '($1,$2)' );

        local $_ = $changes->path;