From f3261c4500524a5f11a04fbcce194c74bcde8934 Mon Sep 17 00:00:00 2001
From: "Kyle J. McKay" <mackyle@gmail.com>
Date: Thu, 1 Jul 2021 19:07:41 -0700
Subject: [PATCH] Girocco/Util.pm: add get_project_from_dir function

Provide functionality similar to shlib.sh's v_get_proj_from_dir
function via a new get_project_from_dir subroutine.

Signed-off-by: Kyle J. McKay <mackyle@gmail.com>
---
 Girocco/Util.pm | 112 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 111 insertions(+), 1 deletion(-)

diff --git a/Girocco/Util.pm b/Girocco/Util.pm
index a82132c..5becd2f 100644
--- a/Girocco/Util.pm
+++ b/Girocco/Util.pm
@@ -30,7 +30,7 @@ BEGIN {
 			 is_shellish read_HEAD_ref git_add_config to_json
 			 json_bool from_json ref_indicator get_token_key
 			 get_timed_token get_token_field check_timed_token
-			 valid_branch_name);
+			 valid_branch_name get_project_from_dir);
 }
 
 BEGIN {require "Girocco/extra/capture_command.pl"}
@@ -1481,4 +1481,114 @@ sub check_timed_token {
 	return verify_timed_token($token, $tk, $extra, $duration, $start);
 }
 
+# similar to the shlib.sh function v_get_proj_from_dir but different details
+# attempt to convert the first argument interpreted as a full path name to
+# a Girocco project name.  Unlike v_get_proj_from_dir, there's no magic
+# "_external/..." name fallback if not found.
+# $_[0] -> directory name to translate, relative to getcwd if not absolute
+# Returns name of existing Girocco project on success, undef on failure
+# Minor quibbles are handled (e.g. trailing '.git' omitted and shouldn't have been)
+# If the resolved absolute path ends with "/.git" and that's a "gitdir: " file
+# that will be followed too.
+# And finally, if we seem to have ended up in a worktree, that will be handled too
+sub get_project_from_dir {
+	use Cwd qw(realpath);
+	use File::Basename qw(dirname);
+	require Girocco::Project;
+	my $path = shift;
+	defined($path) && $path ne "" or $path = ".";
+	$path =~ s{/+$}{}; $path ne "" or $path = "/";
+	my $fallback = sub {
+		my $fallback = $path;
+		# if a top-level working tree directory was specified
+		# take that to mean its associated .git dir otherwise
+		# if a sibling directory with a ".git" extension exists
+		# such as where forked projects are involved, try that
+		if ($path !~ /\/\.git$/ && -e "$fallback/.git") {
+			$fallback .= "/.git";
+		} else {
+			(my $test = $path) =~ s/\.$//;
+			if ($test !~ /\.git$/ && -d "$test.git") {
+				# project fork directory trees always
+				# use bare repositories; do NOT check
+				# for a "$test.git/.git" here;
+				# but a 2nd fallback round will!
+				$fallback = "$test.git";
+			}
+		}
+		$fallback ne $path && -e $fallback or return undef;
+		return get_project_from_dir($fallback);
+	};
+	my $rpath = realpath($path);
+	defined($rpath) && -e $rpath or return &$fallback;
+	if ($rpath =~ /\/\.git$/ && -f $rpath && -s _) {
+		# grumble
+		# see if it's a gitdir: link (allowing relative ones)
+		# and pick up its destination
+		# no fallbacks in here since an existing ".git"
+		# was found and it was a file not a dir
+		open my $gdf, '<', $rpath or return undef;
+		my $gdline = <$gdf>;
+		close $gdf;
+		defined($gdline) && $gdline =~ /^gitdir:\s*([^\s].*)$/
+			or return undef;
+		(my $gitdir = $1) =~ s/\s+$//;
+		if (substr($gitdir, 0, 1) ne "/") {
+			# it's relative
+			$gitdir = dirname($rpath)."/".$gitdir;
+		}
+		-e $gitdir or return undef;
+		$gitdir = realpath($gitdir);
+		# a gitdir: link must point to a real directory
+		defined($gitdir) && -d $gitdir or return undef;
+		$rpath = $gitdir;
+	}
+	# an existing directory is required at this point
+	# if it's an existing not-a-directory, no fallback
+	-d $rpath or return undef;
+	if (!is_git_dir($rpath)) {
+		# grumble
+		# see if it might be a worktree
+		if (-f "$rpath/HEAD" && -s _ && -f "$rpath/commondir" && -s _) {
+			open my $cdf, '<', "$rpath/commondir" or return &$fallback;
+			my $cdl = <$cdf>;
+			close $cdf;
+			defined($cdl) && $cdl ne "" or return &$fallback;
+			$cdl =~ s/^\s+//; $cdl =~ s/\s+$//;
+			$cdl ne "" or return &$fallback;
+			# for now require "../.." for safety
+			$cdl eq "../.." or return &$fallback;
+			$rpath = dirname(dirname($rpath));
+			is_git_dir($rpath) or return &$fallback;
+		} else {
+			return &$fallback; # yes, try a ".git" suffix fallback
+		}
+	}
+	# at this point $rpath is a "realpath" to an existing directory
+	# that appears to be a non-worktree $GIT_DIR -- no more fallbacks
+	# try the quick check first
+	my $rrr = realpath($Girocco::Config::reporoot);
+	defined($rrr) && $rrr ne "" or return undef;
+	if ($rpath =~ m{^\Q$rrr\E/(.+)$}) {
+		(my $proj = $1) =~ s/\.git$//;
+		return $proj ne "" && Girocco::Project::does_exist($proj, 1)
+			? $proj : undef;
+	}
+	# finally, attempt to look up the path in gitdir.list if all else fails
+	my $gdlp = "$Girocco::Config::projlist_cache_dir/gitdir.list";
+	-f $gdlp && -s _ or return undef;
+	my $projname = undef;
+	open my $gdlf, '<', $gdlp or return undef;
+	while (<$gdlf>) {
+		/^([^\s]+)\s+([^\s].*)$/ or next;
+		$2 eq $rpath or next;
+		$projname = $1;
+		last;
+	}
+	close $gdlf;
+	defined($projname) && $projname ne "" && Girocco::Project::does_exist($projname, 1)
+		or $projname = undef;
+	return $projname;
+}
+
 1;
-- 
2.11.4.GIT