view release on metacpan or  search on metacpan

lib/App/GitGerrit.pm  view on Meta::CPAN

            }
        }
        $config->{'git-gerrit'}{project}[-1] =~ s:^/+::; # strip leading slashes
    }

    return $config;
}

# The config routine returns the last value associated with Git's
# git-gerrit.$var configuration variable, as output by the 'git config
# -l' command, or undef if the variable isn't defined.

sub config {
    my ($var) = @_;
    state $config = grok_config;
    return exists $config->{'git-gerrit'}{$var} ? $config->{'git-gerrit'}{$var}[-1] : undef;
}

# The configs routine returns all values associated with Git's
# git-gerrit.$var configuration variable or the empty list if the
# variable isn't defined.

sub configs {
    my ($var) = @_;
    state $config = grok_config;
    return exists $config->{'git-gerrit'}{$var} ? @{$config->{'git-gerrit'}{$var}}  : ();
}

# The install_commit_msg_hook routine is invoked by a few of
# git-gerrit subcommands. It checks if the current repository already
# has a commit-msg hook installed. If not, it tries to download and
# install Gerrit's default commit-msg hook, which inserts Change-Ids
# in commits messages.

sub install_commit_msg_hook {
    require File::Spec;

    chomp(my $git_dir = qx/git rev-parse --git-dir/);

    # Do nothing if it already exists
    my $commit_msg = File::Spec->catfile($git_dir, 'hooks', 'commit-msg');
    return if -e $commit_msg;

    # Otherwise, check if we need to mkdir the hooks directory
    my $hooks_dir = File::Spec->catdir($git_dir, 'hooks');
    mkdir $hooks_dir unless -e $hooks_dir;

    # Try to download and install the hook.
    eval { require LWP::Simple };
    if ($@) {
        info "Cannot install $commit_msg hook because you don't have LWP::Simple installed";
    } else {
        info "Installing $commit_msg hook";
        if (LWP::Simple::is_success(LWP::Simple::getstore(config('baseurl') . "/tools/hooks/commit-msg", $commit_msg))) {
            chmod 0755, $commit_msg;
        }
    }
}

# The credential_* routines below use the git-credential command to
# get and set credentials for git commands and also for Gerrit REST
# interactions.

sub url_userinfo {
    my ($url) = @_;
    if (my $userinfo = $url->userinfo) {
        return split /:/, $userinfo, 2;
    } else {
        return (undef, undef);
    }
}

sub credential_description_file {
    my ($baseurl, $password) = @_;

    my %credential = (
        protocol => $baseurl->scheme,
        host     => $baseurl->host,
        path     => $baseurl->path,
        password => $password,
    );

    # Try to get the username from the baseurl
    my ($username) = url_userinfo($baseurl);
    $credential{username} = $username if $username;

    require File::Temp;
    my $fh = File::Temp->new();

    while (my ($key, $value) = each %credential) {
        $fh->print("$key=$value\n") if $value;
    }

    $fh->print("\n\n");
    $fh->close();

    return ($fh, $fh->filename);
}

my $git_credential_supported = 1;
sub get_credentials {
    my $baseurl = URI->new(config('baseurl'));
    my ($fh, $credfile) = credential_description_file($baseurl);

    my %credentials;
    debug "Get credentials from git-credential";
    open my $pipe, '-|', "git credential fill <$credfile"
        or error "Can't open pipe to git-credential: $!";
    while (<$pipe>) {
        chomp;
        $credentials{$1} = $2 if /^([^=]+)=(.*)/;
    }
    unless (close $pipe) {
        error "Can't close pipe to git-credential: $!" if $!;

        # If we get here it is because the shell invoked by open
        # above couldn't exec git-credential, which most probably
        # means that we're using a pre-1.8 Git, which doesn't
        # support git-credential yet.
        $git_credential_supported = 0;
    }

    my ($username, $password) = @credentials{qw/username password/};

    unless (defined $username && defined $password) {
        debug "Get credentials from git-gerrit.baseurl";
        ($username, $password) = url_userinfo(config('baseurl'));
    }

    unless (defined $username && defined $password) {
        debug "Get credentials from a .netrc file";
        if (eval {require Net::Netrc}) {
            if (my $mach = Net::Netrc->lookup(URI->new(config('baseurl'))->host, $username)) {
                ($username, $password) = ($mach->login, $mach->password);
            }
        } else {
            debug "Failed to require Net::Netrc";
        }
    }

    unless (defined $username && defined $password) {
        debug "Prompt the user for the credentials";
        if (eval {require Term::Prompt}) {
            $username = Term::Prompt::prompt('x', 'Gerrit username: ', '', $ENV{USER});
            $password = Term::Prompt::prompt('p', 'Gerrit password: ', '');
            print "\n";
        } else {
            debug "Failed to require Term::Prompt";
        }
    }

    defined $username or error "Couldn't get credential's username";
    defined $password or error "Couldn't get credential's password";

    return ($username, $password);
}

sub set_credentials {
    my ($username, $password, $what) = @_;

    return 1 unless $git_credential_supported;

    $what =~ /^(?:approve|reject)$/
        or error "set_credentials \$what argument ($what) must be either 'approve' or 'reject'";

    my $baseurl = URI->new(config('baseurl'));
    my ($fh, $credfile) = credential_description_file($baseurl, $password);

    return system("git credential $what <$credfile") == 0;
}

# The get_message routine returns the message argument to the
# --message option. If the option is not present it invokes the git
# editor to let the user compose a message and returns it.

sub get_message {
    return $Options{message} if exists $Options{message};

    chomp(my $editor = qx/git var GIT_EDITOR/);

    error "Please, read 'git help var' to know how to set up an editor for git messages."
        unless $editor;

    require File::Temp;
    my $tmp = File::Temp->new();
    my $filename = $tmp->filename;

    {
        open my $fh, '>', $filename
            or error "Can't open file for writing ($filename): $!\n";
        print $fh <<'EOF';

# Please enter the review message for this change. Lines starting
# with '#' will be ignored, and an empty message aborts the review.
EOF
        close $fh;
    }

    cmd "$editor $filename"
        or error "Aborting because I couldn't invoke '$editor $filename'.";

    my $message;
    {
        open my $fh, '<', $filename
            or error "Can't open file for reading ($filename): $!\n";
        local $/ = undef;       # slurp mode
        $message = <$fh>;
        close $fh;
    }
    $message =~ s/(?<=\n)#.*?\n//gs; # remove all lines starting with '#'
    return $message;
}

# The gerrit routine keeps a cached Gerrit::REST object to which it
# relays REST calls.

sub gerrit {
    my $method = shift;

    state $gerrit;
    unless ($gerrit) {
        my ($username, $password) = get_credentials;
        require Gerrit::REST;
        $gerrit = Gerrit::REST->new(config('baseurl'), $username, $password);
        eval { $gerrit->GET("/projects/" . uri_escape_utf8(config('project'))) };
        if (my $error = $@) {
            set_credentials($username, $password, 'reject') if $error->{code} == 401;
            die $error;
        } else {
            set_credentials($username, $password, 'approve');
        }
    }

    if ($Options{debug}) {
        my ($endpoint, @args) = @_;
        debug "GERRIT->$method($endpoint)";
        if (@args) {
            require Data::Dumper;
            warn Data::Dumper::Dumper(@args);
        }
    }

    return $gerrit->$method(@_);
}

# The gerrit_or_die routine relays its arguments to the gerrit routine
# but catches any exception and dies with a formatted message. It
# should be called instead of gerrit whenever the caller doesn't want
# to treat exceptions.

sub gerrit_or_die {
    my $result = eval { gerrit(@_) };
    die $@->as_text if $@;
    return $result;
}

# The normalize_date routine removes the trailing zeroes from a $date.

sub normalize_date {
    my ($date) = @_;
    $date =~ s/\.0+$//;
    return $date;
}

# The query_changes routine receives a list of strings to query the
# Gerrit server. It returns an array-ref containing a list of
# array-refs, each containing a list of change descriptions.

sub query_changes {
    my @queries = @_;

    return [] unless @queries;

    # If we're inside a git repository, restrict the query to the
    # current project's reviews.
    if (my $project = config('project')) {
        $project = uri_escape_utf8($project);
        @queries = map "q=project:$project+$_", @queries;
    }

    push @queries, "n=$Options{limit}" if $Options{limit};

    push @queries, "o=LABELS";

    my $changes = gerrit_or_die(GET => "/changes/?" . join('&', @queries));
    $changes = [$changes] if ref $changes->[0] eq 'HASH';

    return $changes;
}