view release on metacpan or  search on metacpan

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

#!perl

use strict;
use warnings;
use feature qw(say state);

package App::GitHubPullRequest;
$App::GitHubPullRequest::VERSION = '0.6.0';
# ABSTRACT: Command-line tool to query GitHub pull requests

use JSON qw(decode_json encode_json);
use Carp qw(croak);
use Encode qw(encode_utf8);
use File::Spec;

use constant DEBUG => $ENV{'GIT_PR_DEBUG'} || 0;


sub new {
    my ($class) = @_;
    return bless {}, $class;
}


sub run {
    my ($self, @args) = @_;
    my $cmd = scalar @args ? shift @args : 'list';
    my $method = $self->can($cmd);
    return $self->$method(@args) if $method;
    return $self->help(@args);
}


sub help {
    my ($self, @args) = @_;
    print <<"EOM";
$0 [<command> <args> ...]

Where command is one of these:

  help              Show this page
  list [<state>]    Show all pull requests (state: open/closed)
  show <number>     Show details for the specified pull request
  patch <number>    Fetch a properly formatted patch for specified pull request
  checkout <number> Create tracking branch for specified pull request

  login [<user>] [<password>] [<two-factor-auth-token>]
                              Login to GitHub and receive an access token (deprecated)
  authorize                   Create a GitHub OAuth personal access token
  comment <number> [<text>]   Create a comment on the specified pull request
  close <number>              Close the specified pull request
  open <number>               Reopen the specified pull request

EOM
    return 1;
}


sub list {
    my ($self, $state) = @_;
    $state ||= 'open';
    my $remote_repo = _find_github_remote();
    my $prs = _api_read("/repos/$remote_repo/pulls?state=$state");
    say ucfirst($state) . " pull requests for '$remote_repo':";
    unless ( @$prs ) {
        say "No pull requests found.";
        return 0;
    }
    foreach my $pr ( @$prs ) {
        my $number = $pr->{"number"};
        my $title = encode_utf8( $pr->{"title"} );
        my $date = $pr->{"updated_at"} || $pr->{'created_at'};
        say join(" ", $number, $date, $title);
    }
    return 0;
}


sub show {
    my ($self, $number, @args) = @_;
    die("Please specify a pull request number.\n") unless $number;
    my $pr = $self->_fetch_one($number);
    die("Unable to fetch pull request $number.\n")
        unless defined $pr;
    {
        my $user = $pr->{'user'}->{'login'};
        my $title = encode_utf8( $pr->{"title"} );
        my $body = encode_utf8( $pr->{"body"} );
        my $date = $pr->{"updated_at"} || $pr->{'created_at'};
        say "Date:    $date";
        say "From:    $user";
        say "Subject: $title";
        say "Number:  $number";
        say "\n$body\n" if $body;
    }
    my $comments = _api_read( $pr->{'comments_url'} );
    foreach my $comment (@$comments) {
        my $user = $comment->{'user'}->{'login'};
        my $date = $comment->{'updated_at'} || $comment->{'created_at'};
        my $body = encode_utf8( $comment->{'body'} );
        say "-" x 79;
        say "Date: $date";
        say "From: $user";
        say "\n$body\n";
    }
    return 0;
}


sub patch {
    my ($self, $number) = @_;
    die("Please specify a pull request number.\n") unless $number;
    my $patch = _get_url(
        $self->_fetch_one($number)->{'patch_url'}
    );
    die("Unable to fetch patch for pull request $number.\n")
        unless defined $patch;
    print $patch;
    return 0;
}


sub checkout {
    my ($self, $number) = @_;
    $number =~ s{[^\d]}{}g if defined $number;
    die("Please specify a pull request number.\n") unless $number;
    my $pr = $self->_fetch_one($number);

    # Get required contributor branch info
    my $head_repo   = $pr->{'head'}->{'repo'}->{'clone_url'};
    my $head_branch = $pr->{'head'}->{'ref'};
    my $head_user   = $pr->{'head'}->{'user'}->{'login'};

    # Check if the remote already exists in our repo
    my $head_remote;
    foreach my $line ( _qx("git", "remote -v") ) {
        my ($remote, $url, $type) = split /\s+/, $line;
        next unless $type eq '(fetch)'; # only consider fetch remotes
        if ( $url eq $head_repo ) {
            $head_remote = $remote;
            last;
        }
    }

    if ( $head_remote ) {
        # Remote already exists, try to update its state
        unless ( _qx(qw(git branch --list -r), qq{"$head_remote/$head_branch"}) ) {
            # Create a new tracking branch, because one doesn't already exist
            my ($content, $rc) = _run_ext(
                qw(git remote set-branches),
                '--add',        # don't remove any other existing tracking branches
                $head_remote,   # our remote's name/alias
                $head_branch,   # the ref we want to track
            );
            die("git failed with error $rc when trying to add tracking branch"
              . " to existing remote.\n")
                if $rc != 0;
        }

        # Fetch changes from just added remote
        say "Fetching changes from '$head_remote/$head_branch'";
        my ($content, $rc) = _run_ext(
            qw(git fetch),
            $head_remote,
        );
        die("git failed with error $rc when trying to update remote.\n")
            if $rc != 0;
    }
    else {
        # Create and fetch the branch info if it doesn't exist already
        $head_remote = $head_user;
        my ($content, $rc) = _run_ext(
            qw(git remote add),
            '-f',                    # only fetch specific refs
            '-t', $head_branch,      # add only a ref for this ref, not all
            $head_remote,            # what we'll name our remote
            $head_repo,              # URL to the head repo
        );
        die("git failed with error $rc when trying to add remote.\n")
            if $rc != 0;
    }

    # Actually checkout the ref we just updated as pr/<number>
    my ($content, $rc) = _run_ext(
        qw(git checkout),
        '-b', "pr/$number",
        '--track', "$head_remote/$head_branch",
    );
    die("git failed with error $rc when trying to check out branch.\n")
        if $rc != 0;

    return 0;
}


sub close { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my ($self, $number) = @_;
    die("Please specify a pull request number.\n") unless $number;
    my $pr = $self->_state($number, 'closed');
    die("Unable to close pull request $number.\n")
        unless defined $pr;
    say "Pull request $number now in state: " . $pr->{'state'};
    return 0;
}


sub open { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    my ($self, $number) = @_;
    die("Please specify a pull request number.\n") unless $number;
    my $pr = $self->_state($number, 'open');
    die("Unable to open pull request $number.\n")
        unless defined $pr;
    say "Pull request $number now in state: " . $pr->{'state'};
    return 0;
}


sub comment {
    my ($self, $number, $text) = @_;
    die("Please specify a pull request number.\n") unless $number;
    my $remote_repo = _find_github_remote();
    my $filename;
    unless ( $text ) {
        $filename = _tmpfile("$remote_repo-$number");
        # Find and execute editor on temporary file
        my $editor = $ENV{'EDITOR'};
        unless ( $editor ) {
            _require_binary('editor');
            $editor = 'editor';
        }
        system($editor, $filename);
        # Fetch text just edited (if any)
        if ( -r $filename ) {
            CORE::open my $fh, "<:encoding(UTF-8)", $filename or die "Can't open $filename: $!";
            $text = join "", <$fh>;
            CORE::close $fh;
        }
        # Abort if no text found
        unless ( $text ) {
            unlink $filename;
            die("Your comment is empty. Command aborted.\n");
        }
    }
    my $comment = eval {
        _api_create(
            "/repos/$remote_repo/issues/$number/comments",
            { "body" => $text },
        );
    };
    die($@ . ( defined $filename ? "Comment text saved in '$filename'. Please remove it manually." : "" ) ."\n")
        if $@; # most likely network error
    die("Unable to add comment on pull request $number.\n")
        unless defined $comment;
    say "Comment added. You can view it online here: " . $comment->{'html_url'};

    # Remove temporary file if everything went well
    if ( defined $filename and -e $filename ) {
        my $count = unlink $filename;
        warn("Unable to remove temporary file $filename: $!\n")
            unless $count;
    }

    return 0;
}


sub login {
    my ($self, $user, $password, $two_factor_token) = @_;

    # Add deprecation message
    say "\nThis authorization method is deprecated and will be removed on November 13, 2020.";
    say "Please use the 'authorize' command to authenticate with GitHub.\n";

    # Try to fetch user/password from git config (or prompt)
    $user     ||= _qx('git', "config github.user")     || _prompt('GitHub username');
    $password ||= _qx('git', "config github.password") || _prompt('GitHub password', 'hidden');
    die("Please specify a user name.\n") unless $user;
    die("Please specify a password.\n")  unless $password;
    # Prompt for two-factor auth token
    $two_factor_token ||= _prompt('GitHub two-factor authentication token (if any)');

    # Perform authentication
    my $auth = _api_create(
        "/authorizations",
        {
            "scopes"   => [qw( public_repo repo )],
            "note"     => __PACKAGE__,
            "note_url" => 'https://metacpan/module/' . __PACKAGE__,
        },
        $user,
        $password,
        $two_factor_token,
    );
    die("Unable to authenticate with GitHub.\n")
        unless defined $auth;
    my $token = $auth->{'token'};
    die("Authentication data does not include a token.\n")
        unless $token;

    # Store authorization token
    my ($content, $rc) = _run_ext(qw(git config --global github.pr-token), $token);
    die("git config returned message '$content' and code $rc when trying to store your token.\n")
        if $rc != 0;
    say "Access token stored successfully. Go to https://github.com/settings/tokens to revoke access.";
    return 0;
}


sub authorize {
    my ($self, $token) = @_;
    # Verify that you want to overwrite an existing token
    my $old_token = _qx('git', "config github.pr-token");
    if ( $old_token and not $token ) {
        say "You're already authorized.";
        my $q = _prompt("Do you want to generate a new token (y/N)") || "n";
        return 0 if lc($q) ne 'y';
    }
    # Give instructions and ask for token if not specified on command line
    unless ( $token ) {
        say "Go to https://github.com/settings/tokens/new and follow the directions to generate a new token.";
        say "Give the token a name of your choice, e.g. 'git-pr', and give it the 'repo' permission.";
        say "The 'public_repo' permission is enough if you only plan to use it with public repositories.\n";
        $token = _prompt('GitHub OAuth personal access token');
    }
    # Make sure a token is specified
    die("No token was specified. No changes have been made to your configuration.\n")
        unless $token;
    # Store authorization token
    my ($content, $rc) = _run_ext(qw(git config --global github.pr-token), $token);
    die("git config returned message '$content' and code $rc when trying to store your token.\n")
        if $rc != 0;
    say "Access token stored successfully. Go to https://github.com/settings/tokens to revoke access.";
    return 0;
}

sub _state {
    my ($self, $number, $state) = @_;
    croak("Please specify a pull request number") unless $number;
    croak("Please specify a pull request state") unless $state;
    my $remote_repo = _find_github_remote();
    return _api_update(
        "/repos/$remote_repo/pulls/$number",
        { "state" => $state },
    );
}

sub _fetch_one {
    my ($self, $number) = @_;
    my $remote_repo = _find_github_remote();
    return _api_read("/repos/$remote_repo/pulls/$number");
}

sub _find_github_remote {
    # Parse lines from git and use first found github repo
    my @repos;
    my $repo_map = {};
    foreach my $line ( _qx('git', 'remote -v') ) {
        my ($remote, $url, $type) = split /\s+/, $line;
        next unless $type eq '(fetch)'; # only consider fetch remotes
        next unless $url =~ m/github\.com/; # only consider remotes to github
        if ( $url =~ m{github.com[:/](.+?)(?:\.git)?$} ) {
            push @repos, $1;
            $repo_map->{$1} = $remote;
        }
    }

    # Allow override for testing
    @repos = ( $ENV{"GITHUB_REPO"} ) if $ENV{'GITHUB_REPO'};

    die("No valid GitHub repos found.\n")
        unless @repos;

    # Try each repo found in turn
    while ( my $repo = shift @repos ) {
        print "Fetching GitHub repo: $repo\n"
            if DEBUG;
        # Fetch repo information
        my ($repo_info, $code) = _api_read("/repos/$repo", 'return_on_error');

        # Skip repo which is not found
        if ( $code eq 404 ) {
            print STDERR "WARNING: Skipping invalid GitHub repo: $repo\n";
            if ( $repo_map->{$repo} ) {
                print STDERR "WARNING:\n";
                print STDERR "WARNING: Remove invalid git remote with command:\n";
                print STDERR "WARNING:   git remote remove $repo_map->{$repo}\n";
                print STDERR "WARNING:\n";
            }
            next;
        }

        # Return the parent repo if repo is a fork