view release on metacpan or  search on metacpan

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

=item B<send_changes> (I<message parameters>)

Transmits the change set and all data about it along with the necessary
authentication hash. If an error occurs, an exception is thrown.

Message parameters are passed as arguments in the following order:

=over

=item Client instance (L<App::KGB::Client>)

=item Protocol version (or 'auto')

=item Commit (an instance of L<App::KGB::Commit>)

=item Branch

=item Module

=item Extra

This is a hash reference with additional parameters.

=back

=item B<relay_message>(I<client>, I<message> [, I<options hash> ])

Sends a message to the server for relaying.

=item send_changes_v2($info)
=item send_changes_v3($info)
=item send_changes_v4($info)

Methods implementing different protocol versions

=item send_changes_soap($message)

Helper method sending commit information via SOAP. Dies on any error or SOAP
FAULT.

=item send_changes_json($message)

Helper method sending commit information via JSON-RPC. Dies on errors.

=back

=cut

require v5.10.0;
use base 'Class::Accessor::Fast';

__PACKAGE__->mk_accessors( qw( uri proxy password timeout verbose dry_run ) );

use utf8;
use Carp qw(confess);
use Digest::SHA qw(sha1_hex);
use YAML ();

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, $client, $protocol_ver, $commit, $branch, $module, $extra )
        = @_;

    # Detect utf8 strings and set the utf8 flag, or try to convert from latin1
    my $repo_id = $client->repo_id;
    my $commit_id = $commit->id;
    my $commit_author = $commit->author;
    my $commit_log = $commit->log;
    my @commit_changes = $commit->changes ? @{ $commit->changes } : ();
    my $password = $self->password;

    my $slc = $client->single_line_commits;
    if ( $slc eq 'forced' ) {
        $commit_log =~ s/\n.*//s;
    }
    elsif ( $slc eq 'auto' ) {
        $commit_log =~ s/^[^\n]+\K\n\n.*//s;
    }

    foreach ( $repo_id, $commit_id, @commit_changes, $commit_log,
        $commit_author, $branch, $module, $password ) {
        next unless ( defined );
        next if ( utf8::is_utf8($_) );
        my $t = $_;
        if ( utf8::decode($t) ) {
            # valid utf8 char seq
            utf8::decode($_);
        } else {
            # try with legacy encoding
            utf8::upgrade($_);
        }
    }

    my $info = {
        repo_id    => $repo_id,
        rev_prefix => $client->rev_prefix,
        commit_id  => $commit_id,
        changes    => [ map ( "$_", @commit_changes ) ],
        commit_log => $commit_log,
        author     => $commit_author,
        branch     => $branch,
        module     => $module,
        extra      => $extra,
    };

    my $meth;
    if ( $protocol_ver eq 'auto' ) {
        $meth = 'send_changes_v4';