Merge branch 'wip/external-git-improvements'

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/canHandleUrlInternally..st

@@ -0,0 +1,3 @@
+git porcelain
+canHandleUrlInternally: aString
+	^ {'http://'. 'https://'} anySatisfy: [:each | aString beginsWith: each]

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/cloneExternalFrom..st

@@ -6,4 +6,7 @@ cloneExternalFrom: aStringOrUrl
 	(children isEmpty or: [children size = 1 and: [children first basename = '.git']])
 		ifFalse: [^ self error: 'Target directory is not empty'].
 	directory deleteAll.
-	self externalCommand: ('git clone "{1}" "{2}"' format: {aStringOrUrl. directory pathName}).
+	self externalCommand: ('{1} clone "{2}" "{3}"' format: {
+		self gitExecutable.
+		aStringOrUrl.
+		directory pathName}).

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/cloneFrom..st

@@ -1,11 +1,11 @@
 git porcelain
 cloneFrom: aStringOrUrl
-	GitFeatureFlags externalFetchAndPush
+	(self shouldHandleUrlExternally: aStringOrUrl)
 		ifTrue: [self cloneExternalFrom: aStringOrUrl]
 		ifFalse: [[self cloneInternalFrom: aStringOrUrl]
 					on: ConnectionClosed
 					do: [:exception |
 						self
 							handleConnectionClosed: exception
-							whileTryingTo: 'clone'
+							while: 'cloning'
 							ifRetry: [self cloneFrom: aStringOrUrl]]].

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/commandExists..st

@@ -1,3 +1,5 @@
 git porcelain - external
 commandExists: aString
-	^ (ShellSyntax new findExecutablePathFor: (aString copyUpTo: Character space) inDirectoryPath: nil) notNil
+	^ ((self osProcessClass: #ShellSyntax) new
+		findExecutablePathFor: (aString copyUpTo: Character space)
+		inDirectoryPath: nil) notNil

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/externalCommand..st

@@ -1,13 +1,23 @@
 git porcelain - external
 externalCommand: aString
-	| osProcess |
-	osProcess := (Smalltalk classNamed: #OSProcess) ifNil: [
-		(self confirm: 'OSProcess is not installed, but is needed to run git externally. Install it?') ifFalse: [^ self].
-		Installer ss project: 'OSProcess'; install: 'OSProcess'.
-		Installer ss project: 'CommandShell'; install: 'CommandShell'.
-		^ self externalCommand: aString].
+	| osProcess exitCodeReference exitCode errorMessage |
+	osProcess := self osProcess.
+	exitCodeReference := FileSystem disk referenceTo: self externalCommandExitCodePath.
+	exitCodeReference ensureDeleted.
 	UIManager default informUser: 'Running a git command in a terminal...' during: [
 		osProcess waitForCommand:
 			(osProcess isWindows
-				ifTrue: ['cmd.exe /c "{1} & pause"' format: {aString}]
-				ifFalse: [self terminalCommand: aString])].
+				ifTrue: [self windowsTerminalCommand: aString]
+				ifFalse: [self terminalCommand: aString])
+				squeakToUtf8.
+		[exitCodeReference exists] whileFalse: [0.1 seconds wait]].
+	exitCode := exitCodeReference contents asString withBlanksTrimmed asNumber.
+	exitCode = 0 ifTrue: [^ self].
+	errorMessage := 'An external git command failed.'.
+	(self confirm:
+		('{1} Please check its output before closing the terminal.
+		Do you want to run it again?'
+			withoutLineEndings withBlanksCondensed
+			format: {errorMessage}))
+		ifFalse: [self error: errorMessage]
+		ifTrue: [self externalCommand: aString].

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/externalCommandExitCodePath.st

@@ -0,0 +1,5 @@
+git porcelain - external
+externalCommandExitCodePath
+	| tempDirectory |
+	tempDirectory := self osProcess isWindows ifTrue: ['\Windows\Temp\'] ifFalse: ['/tmp/'].
+	^ tempDirectory, 'git-s-external-command-exit-code'

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/externalGitDo..st

@@ -1,3 +1,6 @@
 git porcelain - external
 externalGitDo: aCommandLineSuffix
-	self externalCommand: ('git -C "{1}" {2}' format: {repository workingDir pathName. aCommandLineSuffix}).
+	self externalCommand: ('{1} -C "{2}" {3}' format: {
+		self gitExecutable.
+		repository workingDir pathName.
+		aCommandLineSuffix}).

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/fetchFrom..st

@@ -7,5 +7,5 @@ fetchFrom: aRemoteName
 					do: [:exception |
 						self
 							handleConnectionClosed: exception
-							whileTryingTo: 'fetch'
+							while: 'fetching'
 							ifRetry: [self fetchFrom: aRemoteName]]].

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/fetchInternalFrom..st

@@ -3,6 +3,7 @@ fetchInternalFrom: aRemoteName
 	| remote url fetchSpec packFile protocol remoteRefs wantRefs wantSignatures packFileData |
 	remote := self unitOfWork remoteNamed: aRemoteName.
 	url := remote url ifNil: [(GitRemoteUndefined remote: remote) signal: 'No URL configured.'].
+	(self shouldHandleUrlExternally: url) ifTrue: [^ self fetchAllExternalFrom: aRemoteName].
 	fetchSpec := remote fetchSpecs
 		ifEmpty: [GitFetchSpec
 					fromString: '+refs/heads/*:refs/remotes/', aRemoteName, '/*'

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/gitExecutable.st

@@ -0,0 +1,15 @@
+git porcelain - external
+gitExecutable
+	| exec |
+	exec := GitFeatureFlags externalGitExecutable.
+	(self commandExists: exec) ifTrue: [^ exec].
+	exec := UIManager default
+		request:
+			('Git could not be found at the path below.
+			Please install it or provide a path to the git executable. {1}'
+				withoutLineEndings withBlanksCondensed
+				format: {self suggestWSLGitInstallation})
+		initialAnswer: exec.
+	exec isEmptyOrNil ifTrue: [^ self error: 'Missing external git installation'].
+	GitFeatureFlags externalGitExecutable: exec.
+	^ self gitExecutable

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/handleConnectionClosed.while.ifRetry..st

@@ -0,0 +1,7 @@
+git porcelain
+handleConnectionClosed: aConnectionClosed while: aString ifRetry: aBlock
+	(self requestToEnableExternalFetchAndPushBecause:
+		('{1} failed with the internal git implementation.'
+			format: {aString capitalized}))
+		ifFalse: [aConnectionClosed pass]
+		ifTrue: [aBlock value].

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/handleTerminalCommandTemplateCharacter.from.into.withCommand..st

@@ -5,7 +5,9 @@ handleTerminalCommandTemplateCharacter: aCharacter from: aReadStream into: aWrit
 	aReadStream peek = ${ ifTrue: [^ aWriteStream nextPut: aReadStream next].
 	replacements := (aReadStream upTo: $}) splitBy: ','.
 	command := aString.
+	command := command, '; code=$?'.
 	(replacements includes: 'no-key') ifFalse: [command := command, '; read -n 1 -p "Press any key to continue..."'].
+	command := command, '; echo $code > ', self externalCommandExitCodePath.
 	command := 'sh -c ', (GSTextUtilities quote: command).
 	replacements do: [:each |
 		command := self performTerminalCommandTemplateReplacement: each in: command].

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/knownTerminalCommands.st

@@ -16,11 +16,7 @@ knownTerminalCommands
 		{
 			'osascript -e ''tell app "Terminal"'.
 			'activate'.
-			'set w to do script "{":\",'':''"''"''}"'.
-			'repeat'.
-			'delay 0.1'.
-			'if not busy of w then exit repeat'.
-			'end repeat'.
+			'do script "{":\",'':''"''"''}"'.
 			'end tell'''.
 		} joinSeparatedBy: String crlf.
 		'st -e {}'.

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/osProcess.st

@@ -0,0 +1,3 @@
+git porcelain - external
+osProcess
+	^ self osProcessClass: #OSProcess

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/osProcessClass..st

@@ -0,0 +1,8 @@
+git porcelain - external
+osProcessClass: aSymbol
+	(Smalltalk classNamed: aSymbol) ifNotNil: [:class | ^ class].
+	(self confirm: 'OSProcess is not installed, but is needed to run git externally. Install it?')
+		ifFalse: [^ self error: 'OSProcess is needed to run git externally.'].
+	Installer ss project: 'OSProcess'; install: 'OSProcess'.
+	Installer ss project: 'CommandShell'; install: 'CommandShell'.
+	^ Smalltalk classNamed: aSymbol

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/push.toRemote.force..st

@@ -17,7 +17,7 @@ push: aCollectionOfBranchNamesAndAssociations toRemote: remoteName force: forceB
 					do: [:exception |
 						self
 							handleConnectionClosed: exception
-							whileTryingTo: 'push'
+							while: 'pushing'
 							ifRetry: [self
 										push: aCollectionOfBranchNamesAndAssociations
 										toRemote: remoteName

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/pushToRemote.update.deleteRemoteBranches.force..st

@@ -3,6 +3,11 @@ pushToRemote: remoteName update: aCollectionOfBranchNamesAndAssociations deleteR
 	| remote url protocol updateRefs deleteRefs pushBlock report |
 	remote := self unitOfWork remoteNamed: remoteName.
 	url := remote url.
+	(self shouldHandleUrlExternally: url) ifTrue: [
+		^ self
+			externalPush: aCollectionOfBranchNamesAndAssociations
+			toRemote: remoteName
+			force: forceBoolean].
 	updateRefs := aCollectionOfBranchNamesAndAssociations collect: [:each |
 		each value == each
 			ifTrue: [(self unitOfWork expandRef: each) -> (self unitOfWork objectReferenced: each)]

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/requestToEnableExternalFetchAndPushBecause..st

@@ -0,0 +1,17 @@
+git porcelain
+requestToEnableExternalFetchAndPushBecause: aString
+	| preference answer |
+	preference := Preferences
+						pragmaPreferenceFor: GitFeatureFlags
+						getter: #externalFetchAndPush.
+	answer := (self confirm:
+		('{1} Do you want to automatically use the git commandline?
+		This will enable {2} to remember your decision.'
+			withoutLineEndings withBlanksCondensed asText
+			format: {
+				aString.
+				('a preference' asText
+					addAttribute: (PluggableTextAttribute evalBlock: [preference open]);
+					yourself)})).
+	answer ifTrue: [preference preferenceValue: true].
+	^ answer

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/shouldHandleUrlExternally..st

@@ -0,0 +1,9 @@
+git porcelain
+shouldHandleUrlExternally: aString
+	| errorMessage |
+	GitFeatureFlags externalFetchAndPush ifTrue: [^ true].
+	(self canHandleUrlInternally: aString) ifTrue: [^ false].
+	errorMessage := 'The url {1} cannot be handled by the internal git implementation.'
+						format: {aString printString}.
+	(self requestToEnableExternalFetchAndPushBecause: errorMessage) ifTrue: [^ true].
+	self error: errorMessage.

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/suggestWSLGitInstallation.st

@@ -0,0 +1,4 @@
+git porcelain - external
+suggestWSLGitInstallation
+	(self osProcess isWindows and: [self commandExists: 'wsl']) ifFalse: [^ ''].
+	^ 'If git is installed in WSL, you can also enter ''wsl git''.'

src/FileSystem-Git.package/FileSystemGitRepository.class/instance/windowsTerminalCommand..st

@@ -0,0 +1,4 @@
+git porcelain - external
+windowsTerminalCommand: aString
+	^ 'cmd.exe /v:on /c "{1} & set Code=!ErrorLevel!& pause & echo !Code!> {2}"'
+		format: {aString. self externalCommandExitCodePath}

src/FileSystem-Git.package/FileSystemGitRepository.class/methodProperties.json

@@ -6,38 +6,43 @@
 		"branchNamed:" : "jr 3/2/2020 22:13",
 		"branchNames" : "jr 3/3/2020 21:45",
 		"branches" : "jr 3/4/2020 00:46",
-		"cloneExternalFrom:" : "mad 5/23/2024 21:12",
-		"cloneFrom:" : "mad 5/23/2024 18:12",
+		"canHandleUrlInternally:" : "mad 11/10/2024 15:41",
+		"cloneExternalFrom:" : "mad 11/10/2024 16:45",
+		"cloneFrom:" : "mad 11/10/2024 15:45",
 		"cloneInternalFrom:" : "mad 5/23/2024 18:11",
-		"commandExists:" : "mad 4/3/2024 15:10",
+		"commandExists:" : "mad 11/10/2024 17:23",
 		"commitNamed:" : "jr 8/13/2020 23:08",
 		"createBranchNamed:at:" : "jr 3/4/2020 00:47",
 		"detectTerminalCommand" : "mad 10/31/2024 17:49",
 		"expandRemoteRef:" : "pre 6/15/2018 16:04",
-		"externalCommand:" : "mad 11/4/2024 12:53",
-		"externalGitDo:" : "mad 5/22/2024 13:29",
+		"externalCommand:" : "mad 11/10/2024 19:06",
+		"externalCommandExitCodePath" : "mad 11/10/2024 18:14",
+		"externalGitDo:" : "mad 11/10/2024 16:44",
 		"externalPush:toRemote:force:" : "mad 5/18/2024 12:26",
 		"fetchAllExternalFrom:" : "mad 5/23/2024 18:46",
-		"fetchFrom:" : "mad 5/23/2024 18:10",
+		"fetchFrom:" : "mad 11/10/2024 15:45",
 		"fetchFromAll:" : "mad 4/22/2024 17:25",
-		"fetchInternalFrom:" : "mad 4/22/2024 17:24",
+		"fetchInternalFrom:" : "mad 11/10/2024 15:36",
 		"filesystemOn:" : "CamilloBruni 8/30/2012 14:06",
 		"flushCaches" : "jr 7/2/2017 19:12",
+		"gitExecutable" : "mad 11/10/2024 17:04",
 		"gitStoreOn:" : "CamilloBruni 9/2/2012 12:33",
-		"handleConnectionClosed:whileTryingTo:ifRetry:" : "mad 4/22/2024 17:21",
-		"handleTerminalCommandTemplateCharacter:from:into:withCommand:" : "mad 10/9/2024 15:07",
+		"handleConnectionClosed:while:ifRetry:" : "mad 11/10/2024 15:48",
+		"handleTerminalCommandTemplateCharacter:from:into:withCommand:" : "mad 11/10/2024 17:44",
 		"head" : "jr 8/13/2020 23:10",
 		"headReference" : "jr 3/4/2020 00:47",
 		"initializeOn:" : "MaxLeske 7/23/2010 09:59",
-		"knownTerminalCommands" : "mad 10/31/2024 17:31",
+		"knownTerminalCommands" : "mad 11/10/2024 18:30",
 		"orphanedHead" : "jr 1/29/2017 22:52",
+		"osProcess" : "mad 11/10/2024 17:29",
+		"osProcessClass:" : "mad 11/10/2024 17:24",
 		"performTerminalCommandTemplateReplacement:in:" : "mad 10/9/2024 15:07",
 		"pruneRefs:keep:" : "mad 4/7/2024 14:44",
 		"push:toRemote:" : "mad 5/18/2024 11:30",
-		"push:toRemote:force:" : "mad 5/18/2024 11:30",
+		"push:toRemote:force:" : "mad 11/10/2024 15:45",
 		"pushToRemote:deleteRemoteBranches:" : "jr 1/2/2017 10:18",
 		"pushToRemote:update:deleteRemoteBranches:" : "mad 5/18/2024 11:28",
-		"pushToRemote:update:deleteRemoteBranches:force:" : "mad 5/18/2024 11:27",
+		"pushToRemote:update:deleteRemoteBranches:force:" : "mad 11/10/2024 15:34",
 		"pushToUpstreamBranchOf:ifNone:" : "jr 3/4/2020 00:49",
 		"recursivelyCollectCommits:into:limit:" : "jr 3/2/2017 10:39",
 		"refsChangedExternally" : "mad 5/18/2024 11:48",
@@ -47,6 +52,9 @@
 		"removeRemoteNamed:" : "jr 3/4/2020 00:49",
 		"repository" : "CamilloBruni 6/22/2011 05:08",
 		"requestTerminalCommand" : "mad 10/31/2024 17:50",
+		"requestToEnableExternalFetchAndPushBecause:" : "mad 11/10/2024 15:51",
+		"shouldHandleUrlExternally:" : "mad 11/10/2024 15:48",
+		"suggestWSLGitInstallation" : "mad 11/10/2024 17:29",
 		"tagNamed:" : "MCGitRepositoryTest 3/3/2020 23:40",
 		"tagNames" : "MCGitRepositoryTest 3/3/2020 23:42",
 		"tags" : "jr 3/4/2020 00:49",
@@ -57,4 +65,5 @@
 		"validate" : "MCGitRepositoryTest 3/3/2020 23:40",
 		"validateReferenceName:" : "pre 6/15/2018 16:06",
 		"versions" : "jr 3/4/2020 00:50",
+		"windowsTerminalCommand:" : "mad 11/10/2024 18:15",
 		"withUnitOfWork:" : "jr 2/29/2020 21:43" } }

src/FileSystem-Git.package/GitFeatureFlags.class/class/externalGitExecutable..st

@@ -0,0 +1,3 @@
+accessing
+externalGitExecutable: aString
+	ExternalGitExecutable := aString

src/FileSystem-Git.package/GitFeatureFlags.class/class/externalGitExecutable.st

@@ -0,0 +1,5 @@
+accessing
+externalGitExecutable
+	<preference: 'External git executable' categoryList: #('Git expert settings') description: 'A replacement for ''git'' in commands like ''git fetch''. Can be a path to an executable or something like ''wsl git'' to use the git installation in wsl. Spaces (in paths) are not escaped to support the latter use case.' type: #String>
+
+	^ ExternalGitExecutable ifNil: ['git']

src/FileSystem-Git.package/GitFeatureFlags.class/methodProperties.json

@@ -7,6 +7,8 @@
 		"evictFromObjectCacheForTests:" : "jr 4/20/2020 23:33",
 		"externalFetchAndPush" : "tobe 10/15/2022 07:17",
 		"externalFetchAndPush:" : "tobe 10/15/2022 07:17",
+		"externalGitExecutable" : "mad 11/10/2024 16:52",
+		"externalGitExecutable:" : "mad 11/10/2024 16:52",
 		"pruneWhenFetching" : "mad 4/7/2024 18:31",
 		"pruneWhenFetching:" : "mad 4/7/2024 14:46",
 		"warnAboutUseOfDeprecatedMethods" : "jr 9/21/2020 23:10",

src/FileSystem-Git.package/GitFeatureFlags.class/properties.json

@@ -6,6 +6,7 @@
 		"CustomTerminalCommandForExternalCommands",
 		"EvictFromObjectCache",
 		"ExternalFetchAndPush",
+		"ExternalGitExecutable",
 		"PruneWhenFetching",
 		"UseUnitOfWorkInterface",
 		"WarnAboutUseOfDeprecatedMethods" ],

src/GitS-Core.package/GSGitWorkingCopy.class/class/nameFromURL..st

@@ -1,9 +1,7 @@
 instance creation
 nameFromURL: aString
-	| url path name |
-	url := Url absoluteFromText: aString.
-	path := url path.
-	path ifEmpty: [^ self requestUnregisteredName].
+	| path name |
+	path := aString splitBy: '/'.
 	name := (path
 				reversed
 				collect: [:each | self withoutGitSuffix: each])

src/GitS-Core.package/GSGitWorkingCopy.class/methodProperties.json

@@ -11,7 +11,7 @@
 		"initializeLastImageHash" : "mad 11/28/2023 19:18",
 		"lastImageHash" : "mad 11/28/2023 19:20",
 		"lastImageHash:" : "mad 11/28/2023 19:24",
-		"nameFromURL:" : "mad 4/10/2024 19:40",
+		"nameFromURL:" : "mad 11/10/2024 15:19",
 		"newFromUserAndRegister" : "mad 10/22/2023 00:12",
 		"onFSGitRepository:named:" : "mad 9/19/2023 11:53",
 		"onFSReference:named:" : "mad 9/19/2023 11:53",

src/GitS-Core.package/GSRemoteDialog.class/instance/buildRemoteUrlInput..st

@@ -5,5 +5,5 @@ buildRemoteUrlInput: builder
 		getText: #remoteUrl;
 		editText: #remoteUrl:;
 		setText: #remoteUrl:;
-		help: 'URL (https)';
+		help: 'URL';
 		yourself

src/GitS-Core.package/GSRemoteDialog.class/methodProperties.json

@@ -15,7 +15,7 @@
 		"buildLayout:" : "mad 9/21/2023 18:18",
 		"buildOkButton:" : "mad 9/21/2023 17:47",
 		"buildRemoteNameInput:" : "mad 9/21/2023 18:20",
-		"buildRemoteUrlInput:" : "mad 10/16/2023 20:16",
+		"buildRemoteUrlInput:" : "mad 11/10/2024 18:53",
 		"buildWith:" : "mad 9/21/2023 17:48",
 		"checkValidRemoteName" : "mad 10/16/2023 20:20",
 		"close" : "mad 9/21/2023 17:43",