git-branchmove: rewrite in perldebian/6.1.0archive/debian/6.1.0

Closes: #914398, #914399

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

4 files changed, 222 insertions, 198 deletions

diff --git a/debian/changelog b/debian/changelog
index 55e2097..30436e6 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,14 @@
+chiark-utils (6.1.0) unstable; urgency=medium
+
+  * Non-maintainer upload.
+    - Maintainer has approved this via personal communication.
+  * git-branchmove: rewrite in perl (Closes: #914398, #914399)
+    - Add dependencies on libgit-wrapper-perl, libtry-tiny-perl to
+      bin:chiark-scripts.
+  * git-branchmove: new --detach feature.
+
+ -- Sean Whitton <spwhitton@spwhitton.name>  Sat, 07 Dec 2019 14:10:26 -0700
+
 chiark-utils (6.0.4) unstable; urgency=medium
 
   * sync-accounts: Fix perl syntax error.  Closes:#865985.
diff --git a/debian/control b/debian/control
index 11e1559..db619bb 100644
--- a/debian/control
+++ b/debian/control
@@ -25,7 +25,7 @@ Section: admin
 Priority: extra
 Conflicts: chiark-named-conf, sync-accounts
 Replaces: chiark-named-conf, sync-accounts
-Depends: ${misc:Depends}
+Depends: ${misc:Depends}, libgit-wrapper-perl, libtry-tiny-perl
 Suggests: tcl8.4, python3, gdb
 Architecture: all
 Description: chiark system administration scripts
diff --git a/debian/copyright b/debian/copyright
index 5f44a80..e641751 100644
--- a/debian/copyright
+++ b/debian/copyright
@@ -91,6 +91,9 @@ with-lock-ex
 fishdescriptor
  Copyright 2018 Citrix
 
+git-branchmove
+ Copyright 2019 Sean Whitton <spwhitton@spwhitton.name>
+
 The chiark utilities are all free software; you can redistribute them
 and/or modify them under the terms of the GNU General Public License
 as published by the Free Software Foundation; either version 3 of the
diff --git a/scripts/git-branchmove b/scripts/git-branchmove
index 5751c38..156078f 100755
--- a/scripts/git-branchmove
+++ b/scripts/git-branchmove
@@ -1,201 +1,211 @@
-#!/bin/bash
+#!/usr/bin/perl
+
+# git-branchmove -- move branches to or from a remote
+
+# Copyright (C) 2019 Sean Whitton
+#
+# 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.
 #
-# Moves a branch to or from the current git tree to or from
-# another git tree
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+# This script is based on Ian Jackson's git-branchmove script, in the
+# chiark-utils Debian source package.  Ian's script assumes throughout
+# that it is possible to have unrestricted shell access to the remote,
+# however, while this script avoids that global assumption.
 #
-# usage:   git-branchmove get|put REMOTE PATTERN
-
-set -e
-set -o posix
-
-fail () { echo >&2 "git-branchmove: $*"; exit 16; }
-badusage () { fail "bad usage: $*"; }
-
-if [ $# -lt 3 ]; then badusage "too few arguments"; fi
-
-op="$1"; shift
-case "$op" in get|put) ;; *) badusage "unknown operation \`$op'"; esac
-
-remote="$1"; shift
-
-# Plan of attack:
-#  determine execute-sh runes for src and dst trees
-#  list affected branches on source
-#  check that source branches are not checked out
-#  list affected branches on destination and moan if any nonequal overlap
-#  transfer src->dst refs/heads/BRANCH:refs/heads/BRANCH
-#  transfer and merge reflog(s) xxx todo
-#  delete src refs
-
-case "$remote" in
-*:*)	remoteurl="$remote" ;;
-[/.]*)	remoteurl="$remote" ;;
-*)	remoteurl="$(
-		git config remote."$remote".pushurl ||
-		git config remote."$remote".url ||
-		fail "no pushurl or url defined for remote $remote"
-		)"
-	remotename="$remote"
-esac
-
-remote_spec="$(perl -e '
-    $_ = $ARGV[0];
-    if (m#^ssh://([^:/]+)(?:\:(\w+))?#) {
-	print "$'\''|ssh ";
-	print " -p $3" if $2;
-        print "$1\n";
-    } elsif (m#^([-+_.0-9a-zA-Z\@]+):(?!//|:)#) {
-        print "$'\''|ssh $1\n";
-    } elsif (m#^[/.]#) {
-        print "$_|sh -c $1\n";
+# As much as possible we treat the remote argument as opaque, i.e., we
+# don't distinguish between git URIs and named remotes.  That means
+# that git will expand insteadOf and pushInsteadOf user config for us.
+
+=head1 NAME
+
+git-branchmove - move branches to or from a remote
+
+=head1 SYNOPSIS
+
+B<git-branchmove> [B<--detach>|B<-d>] B<get>|B<put> I<remote> I<pattern>...
+
+=head1 DESCRIPTION
+
+Move branches matching I<pattern> to or from git remote I<remote>.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<--detach>|B<-d>
+
+If the move would delete the currently checked out branch in the
+source repository, attempt to detach HEAD first.
+
+Note that in the case of the B<get> operation, the attempt to detach
+HEAD is somewhat fragile.  You will need unrestricted SSH access to
+the remote, and pushInsteadOf git configuration keys will not always
+be expanded, due to limitations in git.
+
+=back
+
+=head1 AUTHOR
+
+This Perl version of B<git-branchmove> was written by Sean Whitton
+<spwhitton@spwhitton.name>, based on an earlier shell script by Ian
+Jackson.  That script made some assumptions that we try to avoid, for
+compatibility with more git remotes and local git configurations.
+
+=cut
+
+use strict;
+use warnings;
+
+use Git::Wrapper;
+use Try::Tiny;
+
+# git wrapper setup
+my $git = Git::Wrapper->new(".");
+try {
+    $git->rev_parse({ git_dir => 1 });
+} catch {
+    die "git-branchmove: pwd doesn't look like a git repository ..\n";
+};
+
+# process arguments
+die "git-branchmove: not enough arguments\n" if @ARGV < 3;
+my $attempt_detach = 0;
+if ($ARGV[0] eq '-d' or $ARGV[0] eq '--detach') {
+    $attempt_detach = 1;
+    shift @ARGV;
+}
+my ($op, $remote, @patterns) = @ARGV;
+die "git-branchmove: unknown operation\n"
+  unless $op eq 'get' or $op eq 'put';
+
+# is this a named remote or a git URL?  See "GIT URLS" in git-fetch(1)
+my $named_remote = not($remote =~ m|:| or $remote =~ m|^[/.]|);
+
+# Attempt to determine how we might be able to run commands in the
+# remote repo.  This will only be used if we need to try to detach the
+# remote HEAD.  These regexps are lifted from Ian's version of
+# git-branchmove
+my ($rurl, $rrune, $rdir);
+if ($named_remote) {
+    # this will expand insteadOf and pushInsteadOf
+    ($rurl) = $git->remote("get-url", "--push", $remote);
+} else {
+    # this will expand insteadOf but not pushInsteadOf, which is the
+    # best we can do; see <https://stackoverflow.com/a/32991784>
+    ($rurl) = $git->ls_remote("--get-url", $remote);
+}
+if ($rurl =~ m#^ssh://([^:/]+)(?:\:(\w+))?#) {
+    $rdir  = $';
+    $rrune = "ssh ";
+    $rrune .= "-p $2 " if $2;
+    $rrune .= $1;
+} elsif ($rurl =~ m#^([-+_.0-9a-zA-Z\@]+):(?!//|:)#) {
+    $rdir  = $';
+    $rrune = "ssh $1";
+} elsif ($rurl =~ m#^[/.]#) {
+    $rdir = $rurl;
+}
+
+# If we don't prefix the patterns, we might match branches the user
+# doesn't intend.  E.g. 'foo' would match 'wip/foo'
+my @branch_pats = map { s|^|[r]efs/heads/|r } @patterns;
+
+# get lists of branches, prefixed with 'refs/heads/' in each case
+my (@source_branches, @dest_branches);
+my @local_branches = map {
+    my ($hash, undef, $ref) = split ' ';
+    { hash => $hash, ref => $ref }
+} $git->for_each_ref(@branch_pats);
+my @remote_branches = map {
+    my ($hash, $ref) = split ' ';
+    { hash => $hash, ref => $ref }
+} $git->ls_remote($remote, @branch_pats);
+if ($op eq 'put') {
+    @source_branches = @local_branches;
+    @dest_branches   = @remote_branches;
+} elsif ($op eq 'get') {
+    @source_branches = @remote_branches;
+    @dest_branches   = @local_branches;
+}
+
+# do we have anything to move?
+die "git-branchmove: nothing to do\n" unless @source_branches;
+
+# check for deleting the current branch on the source
+my $source_head;
+if ($op eq "put") {
+    my @lines = try { $git->symbolic_ref('-q', 'HEAD') };
+    $source_head = $lines[0] if @lines;    # the HEAD is not detached
+} elsif ($op eq "get") {
+    my @lines = try { $git->ls_remote('--symref', $remote, 'HEAD') };
+    if (@lines and $lines[0] =~ m|^ref: refs/heads/|) {
+        # the HEAD is not detached
+        (undef, $source_head) = split ' ', $lines[0];
+    }
+}
+if (defined $source_head and grep /^\Q$source_head\E$/,
+    map { $_->{ref} } @source_branches) {
+    if ($attempt_detach) {
+        if ($op eq 'put') {
+            $git->checkout('--detach');
+        } elsif ($op eq 'get') {
+            if (defined $rrune and defined $rdir) {
+                system "$rrune \"set -e; cd $rdir; git checkout --detach\"";
+                die "failed to detach remote HEAD" unless $? eq 0;
+            } elsif (!defined $rrune and defined $rdir) {
+                my $dest_git = Git::Wrapper->new($rdir);
+                $dest_git->checkout('--detach');
+            } else {
+                die "git-branchmove: don't know how to detach remote HEAD";
+            }
+        }
     } else {
-        die "git-branchmove: unsupported remote url \`$_'\''\n";
+        die "git-branchmove: would delete checked-out branch $source_head\n";
+    }
+}
+
+# check whether we would overwrite anything
+foreach my $source_branch (@source_branches) {
+    foreach my $dest_branch (@dest_branches) {
+        die "git-branchmove: would overwrite $source_branch->{ref}"
+          if (  $source_branch->{ref} eq $dest_branch->{ref}
+            and $source_branch->{hash} ne $dest_branch->{hash});
+    }
+}
+
+# time to actually move the branches
+my @refspecs      = map { "$_->{ref}:$_->{ref}" } @source_branches;
+my @nuke_refspecs = map { ":$_->{ref}" } @source_branches;
+if ($op eq 'put') {
+    $git->push('--no-follow-tags', $remote, @refspecs);
+    $git->update_ref('-m', "git-branchmove: moved to $remote ($rurl)",
+        '-d', $_->{ref}, $_->{hash})
+      for @source_branches;
+} elsif ($op eq 'get') {
+    $git->fetch('--no-tags', $remote, @refspecs);
+    $git->push('--no-follow-tags', $remote, @nuke_refspecs);
+}
+
+# if the remote is a named remote, rather than just a URI, update
+# remote-tracking branches
+if ($named_remote) {
+    foreach my $source_branch (@source_branches) {
+        my $branch       = $source_branch->{ref} =~ s|^refs/heads/||r;
+        my $tracking_ref = "refs/remotes/$remote/$branch";
+        if ($op eq 'put') {
+            $git->update_ref($tracking_ref, $source_branch->{hash});
+        } elsif ($op eq 'get') {
+            $git->update_ref('-d', $tracking_ref);
+        }
     }
-' "$remoteurl")"
-
-remote_path="${remote_spec%%|*}"
-remote_rune="${remote_spec#*|}"
-
-case $op in
-get)
-	src_rune="$remote_rune"
-	src_path="$remote_path"
-	dst_rune="sh -c"
-	dst_path=.
-	updatemsg="git-branchmove: moved to $remote ($remoteurl)"
-	push_fetch=fetch
-	;;
-put)
-	dst_rune="$remote_rune"
-	dst_path="$remote_path"
-	src_rune="sh -c"
-	src_path=.
-	updatemsg="git-branchmove; moved to `hostname -f` by `whoami`"
-	push_fetch=push
-	;;
-esac
-
-on_src () { $src_rune "set -e; cd $src_path; $*"; }
-on_dst () { $dst_rune "set -e; cd $dst_path; $*"; }
-
-
-#----- fetch the current refs from both sides -----
-
-branch_pats=''
-for branch_pat in "$@"; do
-	branch_pats+=" '[r]efs/heads/$branch_pat'"
-done
-
-get_branches_rune='
-	git for-each-ref --format="%(refname)=%(objectname)" '"$branch_pats"'
-'
-
-src_branches=( $(
-	on_src '
-		printf H
-		git symbolic-ref -q HEAD || test $? = 1
-		echo " "
-		'"$get_branches_rune"'
-	'	
-))
-
-src_head="${src_branches[0]}"
-unset src_branches[0]
-: "${src_branches[@]}"
-
-case "$src_head" in
-H) ;; # already detached
-*)
-	src_head="${src_head#H}"
-	for check in "${src_branches[@]}"; do
-		case "$check" in
-		"$src_head"=*)
-			fail "would delete checked-out branch $src_head"
-			;;
-		esac
-	done
-	;;
-esac
-
-
-if [ "${#src_branches[@]}" = 0 ]; then
-	echo >&2 "git-branchmove: nothing to do"
-	exit 1
-fi
-
-dst_branches=( $(on_dst "$get_branches_rune") )
-: "${dst_branches[@]}"
-
-
-#----- check for nonequal overlaps -----
-
-ok=true
-for dst_check in "${dst_branches[@]}"; do
-	dst_ref="${dst_check%=*}"
-	for src_check in "${src_branches[@]}"; do
-		case "$src_check" in
-		"$dst_check")	;;
-		"$dst_ref"=*)
-			ok=false
-			echo >&2 "src: $src_check   dst: $dst_check"
-			;;
-		esac
-	done
-done
-
-$ok || fail "would overwrite some destination branch(es)"
-
-
-#----- do the transfer -----
-
-refspecs=()
-for src_xfer in "${src_branches[@]}"; do
-	src_ref="${src_xfer%=*}"
-	refspecs+=("$src_ref:$src_ref")
-done
-
-case "$op" in
-put)	git push --no-follow-tags "$remote" "${refspecs[@]}"	;;
-get)	git fetch --no-tags "$remote" "${refspecs[@]}"	;;
-*)	fail "unknown $op ???"			;;
-esac
-
-
-#----- delete the refs on the source -----
-
-(
-	printf "%s\n" "$updatemsg"
-	for src_rm in "${src_branches[@]}"; do printf "%s\n" "$src_rm"; done
-) | on_src '
-	read updatemsg
-	while read src_rm; do
-		src_ref="${src_rm%=*}"
-		src_obj="${src_rm##*=}"
-		git update-ref -m "$updatemsg" -d "$src_ref" "$src_obj"
-		echo "moved: $src_ref"
-	done
-'
-
-#----- update the remote tracking branches -----
-
-if [ "x$remotename" != x ]; then
-	for src_rm in "${src_branches[@]}"; do
-		src_ref="${src_rm%=*}"
-		src_obj="${src_rm##*=}"
-
-		case "$src_ref" in
-		refs/heads/*) ;;
-		*) continue ;;
-		esac
-
-		branch="${src_ref#refs/heads/}"
-		track_ref="refs/remotes/$remotename/$branch"
-		case $op in
-		get)	git update-ref -d "$track_ref"	;;
-		put)	git update-ref "$track_ref" "$src_obj" ;;
-		*)	fail "unknown $op ???"
-		esac
-	done
-fi
-
-echo "git-repomove: moved ${#src_branches[@]} branches."
+}