summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorSean Whitton <spwhitton@spwhitton.name>2020-02-11 14:34:08 -0700
committerSean Whitton <spwhitton@spwhitton.name>2020-02-16 15:48:07 -0700
commit89b581c6fa663d8a9db728d98e7f56c83c991444 (patch)
tree1e4247118c26fb47e9353bc1344b65466d23969b /lib
downloadp5-API-GitForge-89b581c6fa663d8a9db728d98e7f56c83c991444.tar.gz
rework script into API::GitForge generic interface
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
Diffstat (limited to 'lib')
-rw-r--r--lib/API/GitForge.pm135
-rw-r--r--lib/API/GitForge/GitHub.pm150
-rw-r--r--lib/API/GitForge/GitLab.pm130
-rw-r--r--lib/API/GitForge/Role/GitForge.pm160
-rw-r--r--lib/App/git/clean_forge_fork.pm84
-rw-r--r--lib/App/git/clean_forge_repo.pm78
-rw-r--r--lib/App/git/nuke_forge_fork.pm85
7 files changed, 822 insertions, 0 deletions
diff --git a/lib/API/GitForge.pm b/lib/API/GitForge.pm
new file mode 100644
index 0000000..7c83d03
--- /dev/null
+++ b/lib/API/GitForge.pm
@@ -0,0 +1,135 @@
+package API::GitForge;
+# ABSTRACT: generic interface to APIs of sites like GitHub, GitLab etc.
+#
+# Copyright (C) 2020 Sean Whitton <spwhitton@spwhitton.name>
+#
+# 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 3 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, see <http://www.gnu.org/licenses/>.
+
+=head1 SYNOPSIS
+
+ # try to autodetect the forge type; works for GitHub and some others
+ my $github = API::GitForge->new_from_domain(
+ domain => "github.com",
+ access_key => "12345678"
+ );
+
+ # specify the forge type yourself by instantiating the right class
+ my $salsa = API::GitForge::GitLab->new(
+ domain => "salsa.debian.org",
+ access_key => "abcdef"
+ );
+
+ # generic user operations regardless of the forge type
+ $github->clean_fork("spwhitton/git-remote-gcrypt");
+ $salsa->clean_fork("Debian/devscripts");
+
+=head1 DESCRIPTION
+
+A I<git forge> is a site like GitHub, GitLab etc. This module
+provides access to some operations which one might wish to perform
+against any git forge, wrapping the details of the APIs of particular
+forges. An example of such an operation is forking a repository into
+the user's own namespace.
+
+See L<API::GitForge::Role::GitForge> for details of all the currently
+supported operations. Patches adding other operations, and support
+for other git forges, are welcome.
+
+=cut
+
+use 5.028;
+use strict;
+use warnings;
+
+use Carp;
+use Exporter "import";
+use File::Spec::Functions qw(catfile);
+use Git::Wrapper;
+use Cwd;
+use API::GitForge::GitHub;
+use API::GitForge::GitLab;
+
+our @EXPORT_OK = qw(new_from_domain forge_access_token remote_forge_info);
+
+our %known_forges = (
+ "github.com" => "API::GitForge::GitHub",
+ "salsa.debian.org" => "API::GitForge::GitLab",
+);
+
+=func new_from_domain domain => $domain, access_key => $key
+
+Instantiate an object representing the GitForge at C<$domain> which
+does L<API::GitForge::Role::GitForge>. This function will only
+succeed for known forges; see C<%API::GitForge::known_forges>. The
+C<access_key> argument is optional; if present, it should be an API
+key for the forge.
+
+ $API::GitForge::known_forges{"ourlab.com"} = "API::GitForge::GitLab";
+
+ my $ourlab = API::GitForge::new_from_domain(
+ domain => "ourlab.com",
+ access_key => API::GitForge::forge_access_token("ourlab.com")
+ );
+
+=cut
+
+sub new_from_domain {
+ my %opts = @_;
+ croak "unknown domain" unless exists $known_forges{ $opts{domain} };
+ $known_forges{ $opts{domain} }->new(%opts);
+}
+
+=func forge_access_token $domain
+
+Return access token for forge at C<$domain>, assumed to be stored
+under C<$ENV{XDG_CONFIG_HOME}/gitforge/access_tokens/$domain> where
+the environment variable defaults to C<~/.config> if unset.
+
+=cut
+
+sub forge_access_token {
+ my $domain = shift;
+ my $root = $ENV{XDG_CONFIG_HOME} || catfile $ENV{HOME}, ".config";
+ my $file = catfile $root, "gitforge", "access_tokens", $domain;
+ -e $file and -r _ or croak "$file does not exist or is not readable";
+ open my $fh, "<", $file or die "failed to open $file for reading: $!";
+ chomp(my $key = <$fh>);
+ $key;
+}
+
+=func remote_forge_info($remote)
+
+Look at the URL for git remote C<$remote>, as returned by C<git remote
+get-url>, assume that this remote is a git forge, and return the
+domain name of that forge and the path to the repository.
+
+ system qw(git remote add salsa https://salsa.debian.org/spwhitton/foo);
+ my ($forge_domain, $forge_repo) = API::GitForge::remote_forge_info("salsa");
+
+ say $forge_domain; # outputs 'salsa.debian.org'
+ say $forge_repo; # outputs 'spwhitton/foo'
+
+=cut
+
+sub remote_forge_info {
+ my $remote = shift;
+ my $git = Git::Wrapper->new(getcwd);
+ my ($uri) = $git->remote("get-url", $remote);
+ $uri =~ m#^https?://([^:/@]+)/#
+ or $uri =~ m#^(?:\w+\@)?([^:/@]+):#
+ or croak "couldn't determine git forge info from $remote remote";
+ ($1, $');
+}
+
+1;
diff --git a/lib/API/GitForge/GitHub.pm b/lib/API/GitForge/GitHub.pm
new file mode 100644
index 0000000..0bc481a
--- /dev/null
+++ b/lib/API/GitForge/GitHub.pm
@@ -0,0 +1,150 @@
+package API::GitForge::GitHub;
+# ABSTRACT: common git forge operations using the GitHub API
+#
+# Copyright (C) 2017, 2020 Sean Whitton <spwhitton@spwhitton.name>
+#
+# 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 3 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, see <http://www.gnu.org/licenses/>.
+
+=head1 DESCRIPTION
+
+See L<API::GitForge> and L<API::GitForge::Role::GitForge> for how to
+use this class.
+
+=cut
+
+use 5.028;
+use strict;
+use warnings;
+
+use Role::Tiny::With;
+
+use Carp;
+use Net::GitHub;
+
+with "API::GitForge::Role::GitForge";
+
+sub _make_api {
+ my $self = shift;
+ my %opts;
+ $opts{access_token} = $self->{_access_token}
+ if exists $self->{_access_token};
+ $self->{_api} = Net::GitHub->new(%opts);
+}
+
+sub _ensure_fork {
+ my ($self, $upstream) = @_;
+ my ($org, $repo) = _extract_repo($upstream);
+
+ my $repos = $self->{_api}->repos;
+ my $user = $self->{_api}->user->show->{login};
+ my @user_repos = $repos->list_user($user);
+ my $repo_exists = sub {
+ grep { $_->{name} eq $repo } @user_repos;
+ };
+ if (&$repo_exists) {
+ $self->_assert_fork_has_parent($upstream);
+ } else {
+ $repos->create_fork($org, $repo);
+ until (&$repo_exists) {
+ sleep 5;
+ @user_repos = $repos->list_user($user);
+ }
+ }
+ return "https://github.com/$user/$repo";
+}
+
+sub _assert_fork_has_parent {
+ my ($self, $upstream) = @_;
+ my (undef, $repo) = _extract_repo($upstream);
+ my $user = $self->{_api}->user->show->{login};
+ my $fork = $self->{_api}->repos->get($user, $repo);
+
+ $fork->{parent}{full_name} eq $upstream
+ or croak
+ "$user/$repo does not have parent $upstream; don't know what to do";
+}
+
+sub _clean_config_repo {
+ my ($self, $target) = @_;
+ my ($org, $repo) = _extract_repo($target);
+ my $repos = $self->{_api}->repos;
+ $repos->set_default_user_repo($org, $repo);
+ $repos->update({
+ name => "$repo",
+ has_wiki => 0,
+ has_issues => 0,
+ has_downloads => 0,
+ has_pages => 0,
+ has_projects => 0,
+ });
+}
+
+sub _clean_config_fork {
+ my ($self, $upstream) = @_;
+ my (undef, $repo) = _extract_repo($upstream);
+ my $user = $self->{_api}->user->show->{login};
+
+ my $repos = $self->{_api}->repos;
+ $repos->set_default_user_repo($user, $repo);
+ $repos->update({
+ name => "$repo",
+ homepage => "",
+ description => "Temporary fork for pull request(s)",
+ default_branch => "gitforge",
+ });
+
+ $self->_clean_config_repo("$user/$repo");
+}
+
+sub _ensure_repo {
+ my ($self, $target) = @_;
+ my ($org, $repo) = _extract_repo($target);
+ my $repos = $self->{_api}->repos;
+ my $user = $self->{_api}->user->show->{login};
+ my %create_opts = (name => $repo);
+ my $list_method;
+ if ($org eq $user) {
+ $list_method = "list_user";
+ } else {
+ $list_method = "list_org";
+ $create_opts{org} = $org unless $org eq $user;
+ }
+ my @list_repos = $repos->$list_method($org);
+ my $repo_exists = sub {
+ grep { $_->{name} eq $repo } @list_repos;
+ };
+ unless (&$repo_exists) {
+ $repos->create(\%create_opts);
+ until (&$repo_exists) {
+ sleep 5;
+ @list_repos = $repos->$list_method($org);
+ }
+ }
+ return "https://github.com/$org/$repo";
+}
+
+sub _nuke_fork {
+ my ($self, $upstream) = @_;
+ $self->_assert_fork_has_parent($upstream);
+ my (undef, $repo) = _extract_repo($upstream);
+ my $user = $self->{_api}->user->show->{login};
+ $self->{_api}->repos->delete($user, $repo);
+}
+
+sub _extract_repo {
+ $_[0] =~ m#^([^/]+)/(.+)(?:\.git)?$#;
+ ($1, $2);
+}
+
+1;
diff --git a/lib/API/GitForge/GitLab.pm b/lib/API/GitForge/GitLab.pm
new file mode 100644
index 0000000..7ffd844
--- /dev/null
+++ b/lib/API/GitForge/GitLab.pm
@@ -0,0 +1,130 @@
+package API::GitForge::GitLab;
+# ABSTRACT: common git forge operations using the GitLab API
+#
+# Copyright (C) 2020 Sean Whitton <spwhitton@spwhitton.name>
+#
+# 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 3 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, see <http://www.gnu.org/licenses/>.
+
+=head1 DESCRIPTION
+
+See L<API::GitForge> and L<API::GitForge::Role::GitForge> for how to
+use this class.
+
+=cut
+
+use 5.028;
+use strict;
+use warnings;
+
+use Role::Tiny::With;
+
+use Carp;
+use GitLab::API::v4;
+
+with "API::GitForge::Role::GitForge";
+
+sub _make_api {
+ my $self = shift;
+ my %opts = (url => "https://" . $self->{_domain} . "/api/v4");
+ $opts{private_token} = $self->{_access_token}
+ if exists $self->{_access_token};
+ $self->{_api} = GitLab::API::v4->new(%opts);
+}
+
+sub _ensure_fork {
+ my ($self, $upstream) = @_;
+ my ($path, $repo) = _extract_project_id($upstream);
+
+ my $user = $self->{_api}->current_user->{username};
+ my @user_repos;
+ my $update_user_repos = sub {
+ @user_repos
+ = @{ $self->{_api}->projects({ search => "$user/$repo" }) };
+ };
+ my $repo_exists = sub {
+ grep { $_->{path_with_namespace} eq "$user/$repo" } @user_repos;
+ };
+ &$update_user_repos;
+ if (&$repo_exists) {
+ $self->_assert_fork_has_parent($upstream);
+ } else {
+ $self->{_api}->fork_project("$path/$repo");
+ until (&$repo_exists) {
+ sleep 5;
+ &$update_user_repos;
+ }
+ }
+ return "https://" . $self->{_domain} . "/$user/$repo.git";
+}
+
+sub _assert_fork_has_parent {
+ my ($self, $upstream) = @_;
+ my (undef, $repo) = _extract_project_id($upstream);
+ my $user = $self->{_api}->current_user->{username};
+ my $fork = $self->{_api}->project("$user/$repo");
+
+ $upstream =~ s/\.git$//;
+ $fork->{forked_from_project}{path_with_namespace} eq $upstream
+ or croak
+ "$user/$repo does not have parent $upstream; don't know what to do";
+}
+
+sub _clean_config_repo {
+ my ($self, $upstream) = @_;
+ my (undef, $repo) = _extract_project_id($upstream);
+ my $user = $self->{_api}->current_user->{username};
+
+ $self->{_api}->edit_project(
+ "$user/$repo",
+ {
+ issues_access_level => "disabled",
+ merge_requests_access_level => "disabled",
+ });
+}
+
+sub _clean_config_fork {
+ my ($self, $upstream) = @_;
+ my (undef, $repo) = _extract_project_id($upstream);
+ my $user = $self->{_api}->current_user->{username};
+
+ $self->{_api}->edit_project(
+ "$user/$repo",
+ {
+ default_branch => "gitforge",
+ description => "Temporary fork for merge request(s)",
+ });
+
+ $self->_clean_config_repo("$user/$repo");
+}
+
+sub _ensure_repo {
+ die "unimplemented";
+}
+
+sub _nuke_fork {
+ my ($self, $upstream) = @_;
+ $self->_assert_fork_has_parent($upstream);
+ my (undef, $repo) = _extract_project_id($upstream);
+ my $user = $self->{_api}->current_user->{username};
+ $self->{_api}->delete_project("$user/$repo");
+}
+
+sub _extract_project_id {
+ my $project = shift;
+ $project =~ s#(?:\.git)?/?$##;
+ $project =~ m#/([^/]+)$#;
+ ($`, $1);
+}
+
+1;
diff --git a/lib/API/GitForge/Role/GitForge.pm b/lib/API/GitForge/Role/GitForge.pm
new file mode 100644
index 0000000..46877ba
--- /dev/null
+++ b/lib/API/GitForge/Role/GitForge.pm
@@ -0,0 +1,160 @@
+package API::GitForge::Role::GitForge;
+# ABSTRACT: role implementing generic git forge operations
+#
+# Copyright (C) 2017, 2020 Sean Whitton <spwhitton@spwhitton.name>
+#
+# 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 3 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, see <http://www.gnu.org/licenses/>.
+
+=head1 DESCRIPTION
+
+Operations which one might wish to perform against any git forge. See
+L<API::GitForge>.
+
+In this documentation, C<example.com> should be replaced with the
+domain at which your GitForge is hosted, e.g. C<salsa.debian.org>.
+
+=cut
+
+use 5.028;
+use strict;
+use warnings;
+
+use Role::Tiny;
+
+use Carp;
+use File::Temp qw(tempdir);
+use Git::Wrapper;
+use File::Spec::Functions qw(catfile);
+
+=method new(domain => $domain, access_token => $token)
+
+Instantiate an object representing the GitForge at C<$domain>. The
+C<access_key> argument is optional; if present, it should be an API
+key for the forge.
+
+=cut
+
+sub new {
+ my ($class, %opts) = @_;
+ croak "need domain!" unless exists $opts{domain};
+
+ my %attrs = (_domain => $opts{domain});
+ $attrs{_access_token} = $opts{access_token} if exists $opts{access_token};
+ my $self = bless \%attrs => $class;
+
+ $self->_make_api;
+
+ return $self;
+}
+
+=method ensure_repo($repo)
+
+Create a new repo at C<https://example.com/$repo>.
+
+=cut
+
+sub ensure_repo { shift->_create_repo(@_) }
+
+=method clean_repo($repo)
+
+Create a new repo at C<https://example.com/$repo> and turn off
+optional forge features.
+
+=cut
+
+sub clean_repo {
+ my ($self, $repo) = @_;
+ $self->_ensure_repo($repo);
+ $self->_clean_config_repo($repo);
+}
+
+=method ensure_fork($upstream)
+
+Ensure that the current user has a fork of the repo at
+C<https://example.com/$upstream>, and return URI to that fork suitable
+for adding as a git remote.
+
+=cut
+
+sub ensure_fork { shift->_ensure_fork(@_) }
+
+=method clean_fork($upstream)
+
+Ensure that the current user has a fork of the repo at
+C<https://example.com/$upstream>, config that fork to make it obvious
+it's only there for submitting change proposals, and return URI to
+fork suitable for adding as a git remote.
+
+=cut
+
+sub clean_fork {
+ my $self = shift;
+ my $fork_uri = $self->_ensure_fork(@_);
+
+ my $temp = tempdir CLEANUP => 1;
+ my $git = Git::Wrapper->new($temp);
+ $git->init;
+ $git->remote(qw(add fork), $fork_uri);
+ my @fork_branches
+ = map { m#refs/heads/#; $' } $git->ls_remote(qw(--heads fork));
+ return $fork_uri if grep /\Agitforge\z/, @fork_branches;
+
+ open my $fh, ">", catfile $temp, "README.md";
+ say $fh "This repository exists only in order to submit pull request(s).";
+ close $fh;
+ $git->add("README.md");
+ $git->commit({ message => "Temporary fork for pull request(s)" });
+ $git->RUN("push", $fork_uri, "master:gitforge");
+ $self->_clean_config_fork(@_);
+
+ # assume that if we had to create the gitforge branch, we just
+ # created the fork, so can go ahead and nuke all branches there.
+ # may fail if some branches are protected; that's okay.
+ eval { $git->push($fork_uri, "--delete", @fork_branches) };
+
+ return $fork_uri;
+}
+
+=method nuke_fork($upstream)
+
+Delete the user's fork of the repo at
+C<https://example.com/$upstream>.
+
+=cut
+
+sub nuke_fork { shift->_nuke_fork(@_) }
+
+=method clean_config_repo($repo)
+
+Turn off optional forge features for repo at
+C<https://example.com/$repo>.
+
+=cut
+
+sub clean_config_repo { shift->_clean_config_repo(@_) }
+
+=method clean_config_fork($upstream)
+
+Configure user's fork of repo at C<https://example.com/$upstream> to
+make it obvious that it's only there for submitting change proposals.
+
+=cut
+
+sub clean_config_fork { shift->_clean_config_fork(@_) }
+
+requires
+ qw<_make_api _ensure_repo _clean_config_repo _clean_config_fork
+ _ensure_fork _nuke_fork>;
+
+1;
diff --git a/lib/App/git/clean_forge_fork.pm b/lib/App/git/clean_forge_fork.pm
new file mode 100644
index 0000000..bffcbab
--- /dev/null
+++ b/lib/App/git/clean_forge_fork.pm
@@ -0,0 +1,84 @@
+package App::git::clean_forge_fork;
+# ABSTRACT: create tidy forks for pull requests
+#
+# Copyright (C) 2017, 2020 Sean Whitton <spwhitton@spwhitton.name>
+#
+# 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 3 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, see <http://www.gnu.org/licenses/>.
+
+use 5.028;
+use strict;
+use warnings;
+
+use subs 'main';
+use Term::UI;
+use Getopt::Long;
+use Git::Wrapper;
+use API::GitForge qw(new_from_domain forge_access_token remote_forge_info);
+use Try::Tiny;
+use Cwd;
+
+my $exit_main = 0;
+
+CORE::exit main unless caller;
+
+=func main
+
+Implementation of git-clean-forge-fork(1). Please see documentation
+for that command.
+
+Normally takes no arguments and responds to C<@ARGV>. If you want to
+override that you can pass an arrayref of arguments, and those will be
+used instead of the contents of C<@ARGV>.
+
+=cut
+
+sub main {
+ shift if $_[0] and ref $_[0] eq "";
+ local @ARGV = @{ $_[0] } if $_[0] and ref $_[0] ne "";
+
+ my $term = Term::ReadLine->new("brand");
+ my $upstream = "origin";
+ my $git = Git::Wrapper->new(getcwd);
+ #<<<
+ try {
+ $git->rev_parse({ git_dir => 1 });
+ } catch {
+ die "pwd doesn't look like a git repository ..\n";
+ };
+ #>>>
+ GetOptions "upstream=s" => \$upstream;
+
+ my ($forge_domain, $upstream_repo) = remote_forge_info $upstream;
+ exit
+ unless $term->ask_yn(
+ prompt => "Do you want to submit changes against $upstream_repo?");
+
+ my $forge = new_from_domain
+ domain => $forge_domain,
+ access_token => forge_access_token $forge_domain;
+ my $fork_uri = $forge->clean_fork($upstream_repo);
+ if (grep /\Afork\z/, $git->remote) {
+ $fork_uri eq ($git->remote(qw(get-url fork)))[0]
+ or die "fork remote exists but has wrong URI\n";
+ } else {
+ $git->remote(qw(add fork), $fork_uri);
+ }
+
+ EXIT_MAIN:
+ return $exit_main;
+}
+
+sub exit { $exit_main = shift // 0; goto EXIT_MAIN }
+
+1;
diff --git a/lib/App/git/clean_forge_repo.pm b/lib/App/git/clean_forge_repo.pm
new file mode 100644
index 0000000..6ecb790
--- /dev/null
+++ b/lib/App/git/clean_forge_repo.pm
@@ -0,0 +1,78 @@
+package App::git::clean_forge_repo;
+# ABSTRACT: create repos on git forges with optional features disabled
+#
+# Copyright (C) 2020 Sean Whitton <spwhitton@spwhitton.name>
+#
+# 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 3 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, see <http://www.gnu.org/licenses/>.
+
+use 5.028;
+use strict;
+use warnings;
+
+use subs 'main';
+use Cwd;
+use Term::UI;
+use Getopt::Long;
+use Git::Wrapper;
+use API::GitForge qw(new_from_domain forge_access_token remote_forge_info);
+use Try::Tiny;
+
+my $exit_main = 0;
+
+CORE::exit main unless caller;
+
+=func main
+
+Implementation of git-clean-forge-repo(1). Please see documentation
+for that command.
+
+Normally takes no arguments and responds to C<@ARGV>. If you want to
+override that you can pass an arrayref of arguments, and those will be
+used instead of the contents of C<@ARGV>.
+
+=cut
+
+sub main {
+ shift if $_[0] and ref $_[0] eq "";
+ local @ARGV = @{ $_[0] } if $_[0] and ref $_[0] ne "";
+
+ my $term = Term::ReadLine->new("brand");
+ my $remote = "origin";
+ my $git = Git::Wrapper->new(getcwd);
+ #<<<
+ try {
+ $git->rev_parse({ git_dir => 1 });
+ } catch {
+ die "pwd doesn't look like a git repository ..\n";
+ };
+ #>>>
+ GetOptions "remote=s" => \$remote;
+
+ my ($forge_domain, $forge_repo) = remote_forge_info $remote;
+ exit
+ unless $term->ask_yn(
+ prompt => "Do you want to create repo $forge_repo?");
+
+ my $forge = new_from_domain
+ domain => $forge_domain,
+ access_token => forge_access_token $forge_domain;
+ $forge->clean_repo($forge_repo);
+
+ EXIT_MAIN:
+ return $exit_main;
+}
+
+sub exit { $exit_main = shift // 0; goto EXIT_MAIN }
+
+1;
diff --git a/lib/App/git/nuke_forge_fork.pm b/lib/App/git/nuke_forge_fork.pm
new file mode 100644
index 0000000..6e6997a
--- /dev/null
+++ b/lib/App/git/nuke_forge_fork.pm
@@ -0,0 +1,85 @@
+package App::git::nuke_forge_fork;
+# ABSTRACT: delete forks created by git-clean-forge-fork(1)
+#
+# Copyright (C) 2020 Sean Whitton <spwhitton@spwhitton.name>
+#
+# 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 3 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, see <http://www.gnu.org/licenses/>.
+
+use 5.028;
+use strict;
+use warnings;
+
+use subs 'main';
+use Getopt::Long;
+use Git::Wrapper;
+use API::GitForge qw(new_from_domain forge_access_token remote_forge_info);
+use Try::Tiny;
+use Cwd;
+use Term::UI;
+
+my $exit_main = 0;
+
+CORE::exit main unless caller;
+
+=func main
+
+Implementation of git-nuke-forge-fork(1). Please see documentation
+for that command.
+
+Normally takes no arguments and responds to C<@ARGV>. If you want to
+override that you can pass an arrayref of arguments, and those will be
+used instead of the contents of C<@ARGV>.
+
+=cut
+
+sub main {
+ shift if $_[0] and ref $_[0] eq "";
+ local @ARGV = @{ $_[0] } if $_[0] and ref $_[0] ne "";
+
+ my $term = Term::ReadLine->new("brand");
+ my $upstream = "origin";
+ my $git = Git::Wrapper->new(getcwd);
+ #<<<
+ try {
+ $git->rev_parse({ git_dir => 1 });
+ } catch {
+ die "pwd doesn't look like a git repository ..\n";
+ };
+ #>>>
+ GetOptions "upstream=s" => \$upstream;
+
+ my @fork_branches
+ = grep !/\Agitforge\z/,
+ map { m#refs/heads/#; $' } $git->ls_remote(qw(--heads fork));
+ if (@fork_branches) {
+ say "Would delete the following branches:";
+ say " $_" for @fork_branches;
+ print "\n";
+ exit unless $term->ask_yn(prompt => "Are you sure?");
+ }
+
+ my ($forge_domain, $upstream_repo) = remote_forge_info $upstream ;
+ my $forge = new_from_domain
+ domain => $forge_domain,
+ access_token => forge_access_token $forge_domain;
+ $forge->nuke_fork($upstream_repo);
+ $git->remote(qw(rm fork));
+
+ EXIT_MAIN:
+ return $exit_main;
+}
+
+sub exit { $exit_main = shift // 0; goto EXIT_MAIN }
+
+1;