Compare commits
19 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| d2e2298731 | |||
| 175343e0ed | |||
| 0f7d780db1 | |||
| 03c874d0c4 | |||
| c18c10c22f | |||
| cff2e7f558 | |||
| e33ffb906a | |||
| 7d8a5cd599 | |||
| ba5c97db99 | |||
| bf2c903524 | |||
| aa16ee10c8 | |||
| c0bfc3485b | |||
| 9f2e4b2bcc | |||
| f36cc5ad94 | |||
| d3b5fdf830 | |||
| 12788edc7b | |||
| 6b027534b9 | |||
| 135938f75a | |||
| 73084e69d9 |
@@ -7,6 +7,7 @@ procedure and through direct procedures.
|
||||
```racket
|
||||
(require git-cli)
|
||||
|
||||
(git 'init)
|
||||
(git 'status)
|
||||
(git 'log '-l '-5)
|
||||
(git 'fetch '--prune)
|
||||
@@ -22,7 +23,53 @@ procedure and through direct procedures.
|
||||
```
|
||||
|
||||
`git` is an ordinary procedure. The first argument is the Git command symbol
|
||||
and the remaining arguments are passed to that command.
|
||||
and the remaining arguments are passed to that command. Registered commands use
|
||||
their git-cli wrapper and can provide structured Racket results or additional
|
||||
behavior. Any other command is passed directly to the installed Git executable
|
||||
and handled with git-cli's standard command result processing.
|
||||
|
||||
For example, commands that do not have a dedicated wrapper can still be used:
|
||||
|
||||
```racket
|
||||
(git 'blame "main.rkt")
|
||||
(git* clean -n)
|
||||
(git* worktree list)
|
||||
(git* archive --format=zip HEAD)
|
||||
```
|
||||
|
||||
A successful fallback command returns `#t` after displaying normal Git output.
|
||||
A failing fallback command raises the same standard git-cli error as an ordinary
|
||||
pass-through wrapper.
|
||||
|
||||
`git*` is the compact command-style syntax. Bare arguments are converted to
|
||||
strings, so `(git* remote get-url origin)` is equivalent to
|
||||
`(git 'remote "get-url" "origin")`. A bare identifier is therefore command-line
|
||||
text, not the value of a Racket variable or procedure with the same name. Use
|
||||
`(eval expression)` when an argument must come from a Racket expression.
|
||||
|
||||
For example, `(git* switch branch)` passes the text `"branch"`, while
|
||||
`(git* switch (eval branch))` passes the value of the Racket variable `branch`.
|
||||
git-cli-specific wrappers should accept the textual arguments produced by
|
||||
`git*`; `new-version` accepts both symbols and text, so both
|
||||
`(git 'new-version 'min)` and `(git* new-version min)` work.
|
||||
|
||||
`gt` remains available as a compatibility alias for `git*`.
|
||||
|
||||
```racket
|
||||
(git* init)
|
||||
(git* remote -v)
|
||||
(git* switch main)
|
||||
(git* restore --staged main.rkt)
|
||||
(git* reset --hard HEAD)
|
||||
(git* revert HEAD)
|
||||
(git* rebase main)
|
||||
(git* merge feature)
|
||||
(git* cherry-pick abc1234)
|
||||
(git* mergetool)
|
||||
|
||||
(define branch "develop")
|
||||
(git* switch (eval branch))
|
||||
```
|
||||
|
||||
Several commands provide Racket-oriented output in addition to the normal Git
|
||||
behavior:
|
||||
@@ -30,6 +77,11 @@ behavior:
|
||||
- `git-status` uses Git's porcelain status and returns structured status items.
|
||||
- `git-log -l` / `git-log --list` returns `(commit subject)` items.
|
||||
- `git-tag -l` / `git-tag --list` returns tag names; with `-n` it returns `(tag subject)` items and `-n<number>` supports multiple content lines.
|
||||
- `git-branch -l` / `git-branch --list` returns `(current|local|remote branch)` items; `-a`, `-r`, and `--sort=` remain Git options.
|
||||
- `git-remote` returns remote names; `git-remote -v` / `git-remote --verbose` returns separate `(name url fetch|push)` items.
|
||||
- `git-stash list` returns `(stash-name description)` items; other stash subcommands keep Git's normal behavior.
|
||||
- `git-restore`, `git-reset`, `git-revert`, `git-rebase`, `git-merge`, and `git-cherry-pick` pass Git's command syntax through unchanged.
|
||||
- `git-mergetool` uses Git's mergetool interface and prefers a configured or well-known graphical merge tool.
|
||||
- `git-diff` renders HTML by default; `--output=-` selects stdout and
|
||||
`--output=string` returns a string.
|
||||
- `git-show` renders a commit and its diff as HTML by default. `-l` /
|
||||
@@ -41,15 +93,88 @@ credentials, SSH keys, pull strategy, and other repository configuration.
|
||||
|
||||
## Commands
|
||||
|
||||
The package currently registers commands including `status`, `add`, `commit`,
|
||||
`push`, `pull`, `fetch`, `branch`, `switch`, `clone`, `tag`, `log`,
|
||||
`rev-list`, `diff`, `show`, `grep`, `help`, `version`, and `new-version`.
|
||||
The package registers wrappers for commands where git-cli adds useful behavior,
|
||||
including `init`, `status`, `add`, `commit`, `push`, `pull`, `fetch`, `config`,
|
||||
`branch`, `remote`, `stash`, `restore`, `reset`, `revert`, `rebase`, `merge`,
|
||||
`cherry-pick`, `mergetool`, `switch`, `clone`, `tag`, `log`, `rev-list`, `diff`,
|
||||
`show`, `grep`, `help`, `version`, and `new-version`. Other Git commands do not
|
||||
need a wrapper and are passed directly to Git.
|
||||
|
||||
Most are also exported as direct procedures such as `git-status`, `git-add`,
|
||||
`git-fetch`, `git-switch`, `git-tag`, `git-log`, `git-diff`, and `git-show`.
|
||||
Most registered commands are also exported as direct procedures such as
|
||||
`git-init`, `git-status`, `git-add`, `git-fetch`, `git-config`, `git-switch`,
|
||||
`git-tag`, `git-log`, `git-diff`, and `git-show`.
|
||||
|
||||
See the Scribble documentation for command-specific behavior and return values.
|
||||
|
||||
## Git configuration
|
||||
|
||||
`git config` has a small Racket-oriented interface:
|
||||
|
||||
```racket
|
||||
(git 'config '--all)
|
||||
(git 'config 'get '--all)
|
||||
(git 'config '--global 'get '--all)
|
||||
(git 'config 'get '--global "user.email")
|
||||
(git 'config 'get '--all "credential.helper")
|
||||
(git 'config 'get "credential.helper")
|
||||
(git 'config 'set! "user.email" "hans@example.invalid")
|
||||
(git 'config '--global 'set! "user.email" "hans@example.invalid")
|
||||
(git 'config 'set! '--global "user.email" "hans@example.invalid")
|
||||
```
|
||||
|
||||
`get --all` without a key returns `(key value)` items. `get --all key`
|
||||
returns all values for one key. `get key` returns one string or `#f` when the
|
||||
key is absent. `set!` returns `#t` after a successful write.
|
||||
|
||||
|
||||
`config editor` is a git-cli configuration command rather than a Git
|
||||
configuration key. With no additional arguments it presents an interactive
|
||||
list of discovered GUI editors:
|
||||
|
||||
```racket
|
||||
(git* config editor)
|
||||
```
|
||||
|
||||
The non-interactive forms are:
|
||||
|
||||
```racket
|
||||
(git* config editor --list)
|
||||
(git* config editor --downloads)
|
||||
(git* config editor vscode)
|
||||
(git* config editor notepad++)
|
||||
(git* config editor auto)
|
||||
|
||||
(git 'config 'editor "C:\\Program Files\\MyEditor\\editor.exe --wait")
|
||||
```
|
||||
|
||||
`--list` returns `(name description command current?)` items and `--downloads`
|
||||
returns official download pointers for optional editors. A known editor name
|
||||
selects the matching detected editor. `auto` clears the explicit git-cli editor
|
||||
choice and returns to automatic detection. Any other single value is stored as
|
||||
the editor command. Changing the editor immediately updates `GIT_EDITOR` and
|
||||
`GIT_SEQUENCE_EDITOR` for subsequent Git commands.
|
||||
|
||||
On Windows, Notepad++ is detected both on `PATH` and in the normal Program Files
|
||||
locations. It is started with `-multiInst -nosession`, so Git waits for the
|
||||
separate editor instance to close.
|
||||
|
||||
|
||||
`config mergetool` uses the same git-cli configuration pattern:
|
||||
|
||||
```racket
|
||||
(git* config mergetool)
|
||||
(git* config mergetool --list)
|
||||
(git* config mergetool --downloads)
|
||||
(git* config mergetool winmerge)
|
||||
(git* config mergetool auto)
|
||||
```
|
||||
|
||||
`--list` returns `(name description path current?)` items. A known tool name
|
||||
selects the detected tool, while another single value is stored as the Git
|
||||
mergetool name. `auto` clears the explicit git-cli choice and returns to
|
||||
automatic detection. The interactive form also offers download/install
|
||||
suggestions.
|
||||
|
||||
## Low-level Git execution
|
||||
|
||||
`run-git` can be used when direct access to Git's stdin/stdout protocol is
|
||||
@@ -63,3 +188,68 @@ needed. Optional text can be supplied to Git with `#:input`.
|
||||
The result remains two values: Git's exit code and the ordered
|
||||
`(source line)` output items.
|
||||
|
||||
## Authentication retry
|
||||
|
||||
Authentication failures are recognized centrally after `run-git`. The
|
||||
recognizer covers common authentication/authorization errors, including HTTP
|
||||
401 and 403 responses.
|
||||
|
||||
`current-git-authentication-handler` defaults to
|
||||
`default-git-authentication-handler`. After an authentication failure the
|
||||
default handler rejects the failed credential first. If a Git credential
|
||||
helper exists, `git credential fill` is then tried so that helpers such as Git
|
||||
Credential Manager can obtain a replacement credential.
|
||||
|
||||
When no usable credential is returned, git-cli asks for a username and
|
||||
password/token using `input-prompt`. The `#:loop-until` callbacks validate the
|
||||
input and return the final value, as intended by `input-prompt`. If no
|
||||
credential helper is configured, git-cli configures the non-persistent `cache`
|
||||
helper locally before approving the supplied credential.
|
||||
|
||||
The original Git command is retried once. If authentication fails again, the
|
||||
credential used for that retry is rejected before the normal Git error is
|
||||
raised. This prevents a bad token from remaining in the credential cache.
|
||||
|
||||
A custom handler can still be installed through
|
||||
`current-git-authentication-handler`.
|
||||
|
||||
|
||||
## GUI editor and merge tool
|
||||
|
||||
When git-cli is loaded, it configures the current Racket process once for the
|
||||
Git commands it starts. `GIT_TERMINAL_PROMPT` is set to `0`. When a GUI editor
|
||||
is found, `GIT_EDITOR` and `GIT_SEQUENCE_EDITOR` are set to that editor command.
|
||||
`run-git` itself no longer copies or rewrites the process environment.
|
||||
|
||||
The editor can be inspected or configured explicitly:
|
||||
|
||||
```racket
|
||||
(find-editor)
|
||||
(find-editors)
|
||||
(set-editor! "code --wait")
|
||||
(set-editor-auto!)
|
||||
```
|
||||
|
||||
The editor search first checks `PATH` and then well-known platform locations.
|
||||
On Windows this includes the normal per-user and Program Files locations for
|
||||
VS Code and Notepad++, with Notepad as fallback. On macOS the standard Visual Studio Code
|
||||
application bundle and TextEdit are recognized. On Linux common `/usr`,
|
||||
`/usr/local`, and Snap locations are checked for VS Code, Kate, Gedit, and Xed.
|
||||
|
||||
`git-mergetool` stays on top of Git's own mergetool mechanism. If no tool is
|
||||
specified explicitly, git-cli prefers a configured or well-known graphical
|
||||
tool such as WinMerge, Meld, KDiff3, VS Code, TortoiseMerge, or opendiff.
|
||||
The finder checks `PATH` first and then common platform installation locations.
|
||||
`find-mergetool-path` can be used to inspect the executable that was found.
|
||||
If no tool is found, Git is left to select its own default.
|
||||
|
||||
```racket
|
||||
(find-mergetool)
|
||||
(find-mergetools)
|
||||
(find-mergetool-path)
|
||||
(mergetool-downloads)
|
||||
(set-mergetool! "winmerge")
|
||||
(set-mergetool-auto!)
|
||||
(git* mergetool)
|
||||
(git* mergetool --tool=meld)
|
||||
```
|
||||
|
||||
@@ -2,7 +2,7 @@
|
||||
|
||||
(define collection "git-cli")
|
||||
(define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command")
|
||||
(define version "0.4")
|
||||
(define version "0.4.2")
|
||||
(define pkg-authors '("Hans Dijkema"))
|
||||
(define license 'MIT)
|
||||
|
||||
@@ -12,12 +12,13 @@
|
||||
"simple-log"
|
||||
"racket-index"
|
||||
"scribble-lib"
|
||||
"racket-makefile"
|
||||
"package-zipper"))
|
||||
"net-lib"
|
||||
))
|
||||
|
||||
(define build-deps
|
||||
'("rackunit-lib"
|
||||
"racket-doc"))
|
||||
|
||||
(define scribblings
|
||||
'(("scribblings/git.scrbl" () ("Git"))))
|
||||
'(("scribblings/git-cli.scrbl" () ("git-cli"))))
|
||||
|
||||
@@ -4,14 +4,20 @@
|
||||
"private/git-commands.rkt"
|
||||
"private/config.rkt"
|
||||
"private/diff.rkt"
|
||||
"private/info.rkt"
|
||||
"private/info-handler.rkt"
|
||||
"private/utils.rkt"
|
||||
"private/find-editor.rkt"
|
||||
"private/find-mergetool.rkt"
|
||||
simple-log
|
||||
racket/string
|
||||
racket/list
|
||||
net/sendurl
|
||||
)
|
||||
|
||||
(provide git
|
||||
(provide gt
|
||||
git*
|
||||
git
|
||||
git-init
|
||||
git-add
|
||||
git-status
|
||||
git-commit
|
||||
@@ -20,9 +26,19 @@
|
||||
git-fetch
|
||||
git-switch
|
||||
git-tag
|
||||
git-config
|
||||
git-log
|
||||
git-grep
|
||||
git-branch
|
||||
git-remote
|
||||
git-stash
|
||||
git-restore
|
||||
git-reset
|
||||
git-revert
|
||||
git-rebase
|
||||
git-merge
|
||||
git-cherry-pick
|
||||
git-mergetool
|
||||
git-clone
|
||||
git-rev-list
|
||||
git-diff
|
||||
@@ -30,6 +46,25 @@
|
||||
git-help
|
||||
git-version
|
||||
git-new-version
|
||||
git-next-version
|
||||
find-editor
|
||||
find-editors
|
||||
editor-downloads
|
||||
set-editor!
|
||||
set-editor-auto!
|
||||
find-mergetool
|
||||
find-mergetools
|
||||
find-mergetool-path
|
||||
mergetool-downloads
|
||||
set-mergetool!
|
||||
set-mergetool-auto!
|
||||
default-git-authentication-handler
|
||||
current-git-authentication-handler
|
||||
exn:fail:git-auth?
|
||||
exn:fail:git-auth-command
|
||||
exn:fail:git-auth-args
|
||||
exn:fail:git-auth-exit-code
|
||||
exn:fail:git-auth-output
|
||||
(all-from-out "private/diff.rkt")
|
||||
)
|
||||
|
||||
@@ -43,18 +78,44 @@
|
||||
;; Command invocation using 'git'
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax git*-argument
|
||||
(syntax-rules (eval)
|
||||
((_ (eval expr))
|
||||
expr)
|
||||
((_ arg)
|
||||
(format "~a" 'arg))))
|
||||
|
||||
(define-syntax git*
|
||||
(syntax-rules ()
|
||||
((_ cmd arg ...)
|
||||
(git 'cmd (git*-argument arg) ...))))
|
||||
|
||||
(define-syntax gt
|
||||
(syntax-rules ()
|
||||
((_ cmd arg ...)
|
||||
(git* cmd arg ...))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Invoke a supported Git command through the command table.
|
||||
; pre : command is a registered Git command symbol.
|
||||
; post : The selected command has processed all supplied arguments.
|
||||
; result : The command-specific result.
|
||||
; goal : Invoke a Git command through a registered wrapper or direct fallback.
|
||||
; pre : command identifies a Git command and args contains its arguments.
|
||||
; post : Registered commands use their wrapper; other commands are passed to Git.
|
||||
; result : The command-specific result or the standard Git command result.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (git command . args)
|
||||
((hash-ref git-commands command
|
||||
(λ ()
|
||||
(error "Not a supported or recognized git command: " command)))
|
||||
args))
|
||||
(let ((cmd (hash-ref git-commands command #f)))
|
||||
(if cmd
|
||||
(cmd args)
|
||||
(let-values (((exit-code output)
|
||||
(run-git (cons command (flatten args)))))
|
||||
(let-values (((result out) (git-out command output)))
|
||||
(std-process-git-result
|
||||
command
|
||||
exit-code
|
||||
result
|
||||
output
|
||||
out
|
||||
(make-hash)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
@@ -69,6 +130,26 @@
|
||||
(define (git-prompt p)
|
||||
(input-prompt p))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Compare a Git argument independent of its Racket representation.
|
||||
; pre : arg and expected can be formatted as command-line arguments.
|
||||
; post : Neither value has been changed.
|
||||
; result : #t when both arguments have the same command-line text.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-argument=? arg expected)
|
||||
(string=? (format "~a" arg)
|
||||
(format "~a" expected)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Test whether a Git argument occurs in a set of accepted values.
|
||||
; pre : values is a list of Git argument representations.
|
||||
; post : arg and values have only been inspected.
|
||||
; result : #t when arg matches one of values.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-argument-member? arg values)
|
||||
(ormap (λ (value) (git-argument=? arg value))
|
||||
values))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Add --porcelain to a Git argument list when it is absent.
|
||||
; pre : args is a list and an optional transformation accepts a list.
|
||||
@@ -116,6 +197,454 @@
|
||||
(string-contains? line* "no changes added to commit"))))
|
||||
out))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Convert one git config --list output line to a key/value item.
|
||||
; pre : line is one line produced by git config --list.
|
||||
; post : line has only been inspected.
|
||||
; result : A list containing the configuration key and value.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (config-line->item line)
|
||||
(let ((m (regexp-match #px"^([^=]+)=(.*)$" line)))
|
||||
(if m
|
||||
(list (cadr m) (caddr m))
|
||||
(list line ""))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Translate the Racket-oriented config interface to git config arguments.
|
||||
; pre : args starts with get or set! and follows one of the supported forms.
|
||||
; post : info contains the config operation used to process Git's result.
|
||||
; result : Arguments accepted by git config.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return the editor description matching a configured editor name.
|
||||
; pre : name can be formatted as an editor name.
|
||||
; post : The editor list has only been inspected.
|
||||
; result : A (name description command) item, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-editor-by-name name)
|
||||
(let ((name* (string-downcase (format "~a" name))))
|
||||
(let loop ((editors (find-editors)))
|
||||
(cond
|
||||
((null? editors) #f)
|
||||
((string=? (string-downcase (car (car editors))) name*)
|
||||
(car editors))
|
||||
(else
|
||||
(loop (cdr editors)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return a Racket-oriented list of available GUI editors.
|
||||
; pre : The platform editor finder is available.
|
||||
; post : No editor has been started.
|
||||
; result : (name description command current?) items.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (available-editors)
|
||||
(let ((current (find-editor)))
|
||||
(map
|
||||
(λ (editor)
|
||||
(list (car editor)
|
||||
(cadr editor)
|
||||
(caddr editor)
|
||||
(and current
|
||||
(string=? current (caddr editor)))))
|
||||
(find-editors))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Display the interactive git-cli editor selection.
|
||||
; pre : editors contains the discovered editor descriptions.
|
||||
; post : The choices have been displayed.
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (display-editor-selection editors)
|
||||
(displayln "Available editors:")
|
||||
(newline)
|
||||
(let loop ((items editors)
|
||||
(index 1))
|
||||
(unless (null? items)
|
||||
(let* ((editor (car items))
|
||||
(current (find-editor))
|
||||
(current? (and current
|
||||
(string=? current (caddr editor)))))
|
||||
(displayln
|
||||
(format " ~a. ~a~a"
|
||||
index
|
||||
(cadr editor)
|
||||
(if current? " [current]" "")))
|
||||
(displayln (format " ~a" (caddr editor)))
|
||||
(newline)
|
||||
(loop (cdr items) (+ index 1)))))
|
||||
(displayln (format " ~a. Specify another editor command"
|
||||
(+ (length editors) 1)))
|
||||
(displayln (format " ~a. Automatic detection"
|
||||
(+ (length editors) 2)))
|
||||
(displayln (format " ~a. Download/install suggestions"
|
||||
(+ (length editors) 3)))
|
||||
(displayln " 0. Cancel")
|
||||
(newline))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Ask the user to choose or enter the editor used by git-cli.
|
||||
; pre : Standard input and output are available.
|
||||
; post : A selected editor has been stored and activated, or the operation was cancelled.
|
||||
; result : The selected editor command, or #f after cancellation.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (configure-editor-interactively)
|
||||
(let ((editors (find-editors)))
|
||||
(display-editor-selection editors)
|
||||
(let* ((custom-index (+ (length editors) 1))
|
||||
(auto-index (+ (length editors) 2))
|
||||
(downloads-index (+ (length editors) 3))
|
||||
(choice
|
||||
(input-prompt
|
||||
"Editor: "
|
||||
#:loop-until
|
||||
(λ (value)
|
||||
(cond
|
||||
((eof-object? value) 'cancel)
|
||||
(else
|
||||
(let ((n (string->number value)))
|
||||
(if (and n
|
||||
(integer? n)
|
||||
(<= 0 n downloads-index))
|
||||
n
|
||||
#f))))))))
|
||||
(cond
|
||||
((eq? choice 'cancel) #f)
|
||||
((= choice 0) #f)
|
||||
((<= choice (length editors))
|
||||
(set-editor! (caddr (list-ref editors (- choice 1)))))
|
||||
((= choice custom-index)
|
||||
(let ((command
|
||||
(input-prompt
|
||||
"Editor command: "
|
||||
#:loop-until
|
||||
(λ (value)
|
||||
(cond
|
||||
((eof-object? value) 'cancel)
|
||||
((string=? (string-trim value) "") #f)
|
||||
(else value))))))
|
||||
(if (eq? command 'cancel)
|
||||
#f
|
||||
(set-editor! command))))
|
||||
((= choice auto-index)
|
||||
(set-editor-auto!))
|
||||
((= choice downloads-index)
|
||||
(display-download-pointers
|
||||
"Suggested editors:"
|
||||
(editor-downloads)))
|
||||
(else #f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Process the git-cli-specific `config editor` command.
|
||||
; pre : args contains the arguments following `editor`.
|
||||
; post : The requested editor configuration action has been performed.
|
||||
; result : Editor data, the selected command, or #f after cancellation.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-config-editor args)
|
||||
(cond
|
||||
((null? args)
|
||||
(configure-editor-interactively))
|
||||
|
||||
((and (= (length args) 1)
|
||||
(git-argument=? (car args) '--list))
|
||||
(available-editors))
|
||||
|
||||
((and (= (length args) 1)
|
||||
(git-argument=? (car args) '--downloads))
|
||||
(editor-downloads))
|
||||
|
||||
((and (= (length args) 1)
|
||||
(git-argument=? (car args) 'auto))
|
||||
(set-editor-auto!))
|
||||
|
||||
((= (length args) 1)
|
||||
(let ((editor (find-editor-by-name (car args))))
|
||||
(if editor
|
||||
(set-editor! (caddr editor))
|
||||
(set-editor! (format "~a" (car args))))))
|
||||
|
||||
(else
|
||||
(error 'git-config "Expected config editor [--list|--downloads|auto|editor-name|editor-command]"))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Display official download pointers.
|
||||
; pre : items contains (name description url) items.
|
||||
; post : The pointers have been displayed.
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (display-download-pointers title items)
|
||||
(displayln title)
|
||||
(newline)
|
||||
(for-each
|
||||
(λ (item)
|
||||
(displayln (format " ~a" (cadr item)))
|
||||
(displayln (format " ~a" (caddr item)))
|
||||
(newline))
|
||||
items)
|
||||
(void))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return the merge tool description matching a configured tool name.
|
||||
; pre : name can be formatted as a merge tool name.
|
||||
; post : The merge tool list has only been inspected.
|
||||
; result : A (name description path) item, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-mergetool-by-name name)
|
||||
(let ((name* (string-downcase (format "~a" name))))
|
||||
(let loop ((tools (find-mergetools)))
|
||||
(cond
|
||||
((null? tools) #f)
|
||||
((string=? (string-downcase (car (car tools))) name*)
|
||||
(car tools))
|
||||
(else
|
||||
(loop (cdr tools)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return a Racket-oriented list of available merge tools.
|
||||
; pre : The platform merge tool finder is available.
|
||||
; post : No merge tool has been started.
|
||||
; result : (name description path current?) items.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (available-mergetools)
|
||||
(let ((current (find-mergetool)))
|
||||
(map
|
||||
(λ (tool)
|
||||
(list (car tool)
|
||||
(cadr tool)
|
||||
(caddr tool)
|
||||
(and current
|
||||
(string=? current (car tool)))))
|
||||
(find-mergetools))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Display the interactive git-cli merge tool selection.
|
||||
; pre : tools contains the discovered merge tool descriptions.
|
||||
; post : The choices have been displayed.
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (display-mergetool-selection tools)
|
||||
(displayln "Available merge tools:")
|
||||
(newline)
|
||||
(let loop ((items tools)
|
||||
(index 1))
|
||||
(unless (null? items)
|
||||
(let* ((tool (car items))
|
||||
(current (find-mergetool))
|
||||
(current? (and current
|
||||
(string=? current (car tool)))))
|
||||
(displayln
|
||||
(format " ~a. ~a~a"
|
||||
index
|
||||
(cadr tool)
|
||||
(if current? " [current]" "")))
|
||||
(displayln (format " ~a" (caddr tool)))
|
||||
(newline)
|
||||
(loop (cdr items) (+ index 1)))))
|
||||
(displayln (format " ~a. Specify another merge tool name"
|
||||
(+ (length tools) 1)))
|
||||
(displayln (format " ~a. Automatic detection"
|
||||
(+ (length tools) 2)))
|
||||
(displayln (format " ~a. Download/install suggestions"
|
||||
(+ (length tools) 3)))
|
||||
(displayln " 0. Cancel")
|
||||
(newline))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Ask the user to choose or enter the merge tool used by git-cli.
|
||||
; pre : Standard input and output are available.
|
||||
; post : A selected merge tool has been stored, automatic detection was restored,
|
||||
; download pointers were shown, or the operation was cancelled.
|
||||
; result : The selected merge tool name, #f after cancellation, or void after pointers.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (configure-mergetool-interactively)
|
||||
(let ((tools (find-mergetools)))
|
||||
(display-mergetool-selection tools)
|
||||
(let* ((custom-index (+ (length tools) 1))
|
||||
(auto-index (+ (length tools) 2))
|
||||
(downloads-index (+ (length tools) 3))
|
||||
(choice
|
||||
(input-prompt
|
||||
"Merge tool: "
|
||||
#:loop-until
|
||||
(λ (value)
|
||||
(cond
|
||||
((eof-object? value) 'cancel)
|
||||
(else
|
||||
(let ((n (string->number value)))
|
||||
(if (and n
|
||||
(integer? n)
|
||||
(<= 0 n downloads-index))
|
||||
n
|
||||
#f))))))))
|
||||
(cond
|
||||
((eq? choice 'cancel) #f)
|
||||
((= choice 0) #f)
|
||||
((<= choice (length tools))
|
||||
(set-mergetool! (car (list-ref tools (- choice 1)))))
|
||||
((= choice custom-index)
|
||||
(let ((tool
|
||||
(input-prompt
|
||||
"Merge tool name: "
|
||||
#:loop-until
|
||||
(λ (value)
|
||||
(cond
|
||||
((eof-object? value) 'cancel)
|
||||
((string=? (string-trim value) "") #f)
|
||||
(else value))))))
|
||||
(if (eq? tool 'cancel)
|
||||
#f
|
||||
(set-mergetool! tool))))
|
||||
((= choice auto-index)
|
||||
(set-mergetool-auto!))
|
||||
((= choice downloads-index)
|
||||
(display-download-pointers
|
||||
"Suggested merge tools:"
|
||||
(mergetool-downloads)))
|
||||
(else #f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Process the git-cli-specific `config mergetool` command.
|
||||
; pre : args contains the arguments following `mergetool`.
|
||||
; post : The requested merge tool configuration action has been performed.
|
||||
; result : Merge tool data, the selected tool name, download pointers, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-config-mergetool args)
|
||||
(cond
|
||||
((null? args)
|
||||
(configure-mergetool-interactively))
|
||||
|
||||
((and (= (length args) 1)
|
||||
(git-argument=? (car args) '--list))
|
||||
(available-mergetools))
|
||||
|
||||
((and (= (length args) 1)
|
||||
(git-argument=? (car args) '--downloads))
|
||||
(mergetool-downloads))
|
||||
|
||||
((and (= (length args) 1)
|
||||
(git-argument=? (car args) 'auto))
|
||||
(set-mergetool-auto!))
|
||||
|
||||
((= (length args) 1)
|
||||
(let ((tool (find-mergetool-by-name (car args))))
|
||||
(if tool
|
||||
(set-mergetool! (car tool))
|
||||
(set-mergetool! (format "~a" (car args))))))
|
||||
|
||||
(else
|
||||
(error 'git-config
|
||||
"Expected config mergetool [--list|--downloads|auto|tool-name]"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-config-args args info)
|
||||
(define (scope? x)
|
||||
(git-argument-member? x '(--global --local --system)))
|
||||
|
||||
(define (split-scope args)
|
||||
(cond
|
||||
((and (pair? args) (scope? (car args)))
|
||||
(values (car args) (cdr args)))
|
||||
(else
|
||||
(values #f args))))
|
||||
|
||||
(let-values (((scope args*) (split-scope args)))
|
||||
(cond
|
||||
;; Short form: (git 'config '--all)
|
||||
((and (not scope)
|
||||
(= (length args*) 1)
|
||||
(git-argument=? (car args*) '--all))
|
||||
(hash-set! info 'config-operation 'all)
|
||||
'(--list))
|
||||
|
||||
((null? args*)
|
||||
(error 'git-config "Expected get or set!"))
|
||||
|
||||
(else
|
||||
(let ((action (car args*))
|
||||
(rest (cdr args*)))
|
||||
(cond
|
||||
((git-argument=? action 'get)
|
||||
;; Also accept scope directly after get.
|
||||
(let-values (((scope* rest*) (split-scope rest)))
|
||||
(let ((effective-scope (or scope scope*)))
|
||||
(when (and scope scope*)
|
||||
(error 'git-config "Configuration scope specified twice"))
|
||||
(cond
|
||||
((null? rest*)
|
||||
(error 'git-config "Expected a configuration key or --all"))
|
||||
|
||||
((git-argument=? (car rest*) '--all)
|
||||
(cond
|
||||
((null? (cdr rest*))
|
||||
(hash-set! info 'config-operation 'all)
|
||||
(append (if effective-scope (list effective-scope) '())
|
||||
'(--list)))
|
||||
((null? (cddr rest*))
|
||||
(hash-set! info 'config-operation 'get-all)
|
||||
(append (if effective-scope (list effective-scope) '())
|
||||
(list '--get-all (cadr rest*))))
|
||||
(else
|
||||
(error 'git-config "Too many arguments for config get --all"))))
|
||||
|
||||
((null? (cdr rest*))
|
||||
(hash-set! info 'config-operation 'get)
|
||||
(append (if effective-scope (list effective-scope) '())
|
||||
(list '--get (car rest*))))
|
||||
|
||||
(else
|
||||
(error 'git-config "Too many arguments for config get"))))))
|
||||
|
||||
((git-argument=? action 'set!)
|
||||
;; Also accept scope directly after set!.
|
||||
(let-values (((scope* rest*) (split-scope rest)))
|
||||
(let ((effective-scope (or scope scope*)))
|
||||
(when (and scope scope*)
|
||||
(error 'git-config "Configuration scope specified twice"))
|
||||
(if (= (length rest*) 2)
|
||||
(begin
|
||||
(hash-set! info 'config-operation 'set)
|
||||
(append (if effective-scope (list effective-scope) '())
|
||||
rest*))
|
||||
(error 'git-config "Expected config set! [scope] key value")))))
|
||||
|
||||
(else
|
||||
(error 'git-config "Expected get or set!"))))))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Process the result of the Racket-oriented git config interface.
|
||||
; pre : info contains the operation selected by git-config-args.
|
||||
; post : Successful query output has been converted to Racket data.
|
||||
; result : Config data, #f for a missing single key, or #t after set!.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (process-git-config-result cmd exit-code result output out info)
|
||||
(let* ((operation (hash-ref info 'config-operation))
|
||||
(stdout (map cadr
|
||||
(filter (λ (entry) (eq? (car entry) 'stdout))
|
||||
output))))
|
||||
(cond
|
||||
((eq? operation 'all)
|
||||
(if (= exit-code 0)
|
||||
(map config-line->item stdout)
|
||||
(std-process-git-result cmd exit-code result output out info)))
|
||||
|
||||
((eq? operation 'get-all)
|
||||
(cond
|
||||
((= exit-code 0) stdout)
|
||||
((= exit-code 1) '())
|
||||
(else
|
||||
(std-process-git-result cmd exit-code result output out info))))
|
||||
|
||||
((eq? operation 'get)
|
||||
(cond
|
||||
((= exit-code 0)
|
||||
(if (null? stdout) #f (car stdout)))
|
||||
((= exit-code 1) #f)
|
||||
(else
|
||||
(std-process-git-result cmd exit-code result output out info))))
|
||||
|
||||
(else
|
||||
(std-process-git-result cmd exit-code result output out info)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Command definition macro
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@@ -170,6 +699,14 @@
|
||||
)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Create an empty Git repository or reinitialize an existing repository.
|
||||
; pre : The supplied arguments are valid for git init.
|
||||
; post : Git init has completed successfully or an exception was raised.
|
||||
; result : #t after a successful initialization.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-init cmd-git-init 'init)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Add file contents to the Git index.
|
||||
; pre : The supplied arguments are valid for git add.
|
||||
@@ -226,14 +763,259 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-fetch cmd-git-fetch 'fetch)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read or write Git configuration through a Racket-oriented interface.
|
||||
; pre : Arguments follow one of the supported get/set! forms.
|
||||
; post : Git config has completed or an exception has been raised.
|
||||
; result : Structured config data, #f for a missing key, or #t after set!.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-git-cmd-proxy cmd-git-config-git 'config
|
||||
git-config-args
|
||||
process-git-config-result)
|
||||
|
||||
(define (cmd-git-config args)
|
||||
(cond
|
||||
((and (pair? args)
|
||||
(git-argument=? (car args) 'editor))
|
||||
(git-config-editor (cdr args)))
|
||||
((and (pair? args)
|
||||
(git-argument=? (car args) 'mergetool))
|
||||
(git-config-mergetool (cdr args)))
|
||||
(else
|
||||
(cmd-git-config-git args))))
|
||||
|
||||
(define (git-config . args)
|
||||
(cmd-git-config args))
|
||||
|
||||
(hash-set! git-commands 'config cmd-git-config)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : List, create or delete branches.
|
||||
; pre : The supplied arguments are valid for git branch.
|
||||
; post : Git branch has completed successfully or an exception was raised.
|
||||
; result : #t after a successful branch command.
|
||||
; result : A structured branch list with --list/-l, otherwise #t.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-branch cmd-git-branch 'branch)
|
||||
(def-cmd git-branch cmd-git-branch 'branch
|
||||
(λ (args info)
|
||||
(let* ((split-id (format "git-cli-branch-split-~a-~a"
|
||||
(random 1000000000)
|
||||
(random 1000000000)))
|
||||
(list-output
|
||||
(ormap
|
||||
(λ (e)
|
||||
(let ((o (format "~a" e)))
|
||||
(or (string=? o "--list")
|
||||
(string=? o "-l"))))
|
||||
args)))
|
||||
(hash-set! info 'scheme-format list-output)
|
||||
(hash-set! info 'branch-split-id split-id)
|
||||
(if list-output
|
||||
(append args
|
||||
(list
|
||||
(format "--format=%(HEAD)~a%(refname)" split-id)))
|
||||
args)))
|
||||
(λ (cmd exit-code result output out info)
|
||||
(if (hash-ref info 'scheme-format #f)
|
||||
(if (and (= exit-code 0) result)
|
||||
(let ((split-id (hash-ref info 'branch-split-id)))
|
||||
(map
|
||||
(λ (line)
|
||||
(let* ((parts (string-split line split-id #:trim? #f))
|
||||
(head (car parts))
|
||||
(ref (if (null? (cdr parts)) "" (cadr parts))))
|
||||
(cond
|
||||
((string-prefix? ref "refs/heads/")
|
||||
(list (if (string=? head "*") 'current 'local)
|
||||
(substring ref (string-length "refs/heads/"))))
|
||||
((string-prefix? ref "refs/remotes/")
|
||||
(list 'remote
|
||||
(substring ref (string-length "refs/remotes/"))))
|
||||
(else
|
||||
(list 'branch ref)))))
|
||||
out))
|
||||
(std-process-git-result cmd exit-code result output out info))
|
||||
(std-process-git-result cmd exit-code result output out info)))
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : List, add, rename or remove remotes.
|
||||
; pre : The supplied arguments are valid for git remote.
|
||||
; post : Git remote has completed successfully or an exception was raised.
|
||||
; result : A structured remote list with --list/-l, otherwise #t.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-remote cmd-git-remote 'remote
|
||||
(λ (args info)
|
||||
(cond
|
||||
((null? args)
|
||||
(hash-set! info 'remote-operation 'list)
|
||||
args)
|
||||
|
||||
((and (= (length args) 1)
|
||||
(git-argument-member? (car args) '(-v --verbose)))
|
||||
(hash-set! info 'remote-operation 'verbose-list)
|
||||
args)
|
||||
|
||||
((git-argument=? (car args) 'get-url)
|
||||
(hash-set! info 'remote-operation
|
||||
(if (ormap (λ (arg) (git-argument=? arg '--all)) args)
|
||||
'get-url-all
|
||||
'get-url))
|
||||
args)
|
||||
|
||||
(else
|
||||
(hash-set! info 'remote-operation 'command)
|
||||
args)))
|
||||
|
||||
(λ (cmd exit-code result output out info)
|
||||
(let* ((operation (hash-ref info 'remote-operation 'command))
|
||||
(stdout (map cadr
|
||||
(filter (λ (entry) (eq? (car entry) 'stdout))
|
||||
output))))
|
||||
(cond
|
||||
((eq? operation 'list)
|
||||
(if (= exit-code 0)
|
||||
stdout
|
||||
(std-process-git-result cmd exit-code result output out info)))
|
||||
|
||||
((eq? operation 'verbose-list)
|
||||
(if (= exit-code 0)
|
||||
(map
|
||||
(λ (line)
|
||||
(let ((m (regexp-match
|
||||
#px"^([^\\s]+)\\s+(.+) \\((fetch|push)\\)$"
|
||||
line)))
|
||||
(if m
|
||||
(list (cadr m)
|
||||
(caddr m)
|
||||
(string->symbol (cadddr m)))
|
||||
(list line #f 'unknown))))
|
||||
stdout)
|
||||
(std-process-git-result cmd exit-code result output out info)))
|
||||
|
||||
((eq? operation 'get-url)
|
||||
(if (= exit-code 0)
|
||||
(if (null? stdout) #f (car stdout))
|
||||
(std-process-git-result cmd exit-code result output out info)))
|
||||
|
||||
((eq? operation 'get-url-all)
|
||||
(if (= exit-code 0)
|
||||
stdout
|
||||
(std-process-git-result cmd exit-code result output out info)))
|
||||
|
||||
(else
|
||||
(std-process-git-result cmd exit-code result output out info)))))
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Store, inspect or restore stashed working tree changes.
|
||||
; pre : The supplied arguments are valid for git stash.
|
||||
; post : Git stash has completed successfully or an exception was raised.
|
||||
; result : Structured stash entries for `stash list`, otherwise the normal result.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-stash cmd-git-stash 'stash
|
||||
(λ (args info)
|
||||
(let ((list-output
|
||||
(and (pair? args)
|
||||
(git-argument=? (car args) 'list)
|
||||
(not
|
||||
(ormap
|
||||
(λ (arg)
|
||||
(regexp-match?
|
||||
#px"^--(format|pretty)(=|$)"
|
||||
(format "~a" arg)))
|
||||
args)))))
|
||||
(hash-set! info 'stash-list list-output)
|
||||
(if list-output
|
||||
(append args
|
||||
'("--format=%gd%x00%gs"))
|
||||
args)))
|
||||
(λ (cmd exit-code result output out info)
|
||||
(if (hash-ref info 'stash-list #f)
|
||||
(if (= exit-code 0)
|
||||
(map
|
||||
(λ (line)
|
||||
(let ((parts (string-split line "\u0000" #:trim? #f)))
|
||||
(if (null? (cdr parts))
|
||||
(list (car parts) "")
|
||||
(list (car parts) (cadr parts)))))
|
||||
(map cadr
|
||||
(filter (λ (entry) (eq? (car entry) 'stdout))
|
||||
output)))
|
||||
(std-process-git-result cmd exit-code result output out info))
|
||||
(std-process-git-result cmd exit-code result output out info)))
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Restore working tree or index files from a Git source.
|
||||
; pre : The supplied arguments are valid for git restore.
|
||||
; post : Git restore has completed successfully or an exception was raised.
|
||||
; result : #t after a successful restore.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-restore cmd-git-restore 'restore)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Reset HEAD or selected paths according to Git reset semantics.
|
||||
; pre : The supplied arguments are valid for git reset.
|
||||
; post : Git reset has completed successfully or an exception was raised.
|
||||
; result : #t after a successful reset.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-reset cmd-git-reset 'reset)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Revert one or more commits using Git's revert command.
|
||||
; pre : The supplied arguments are valid for git revert.
|
||||
; post : Git revert has completed successfully or an exception was raised.
|
||||
; result : #t after a successful revert or sequencer command.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-revert cmd-git-revert 'revert)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Reapply commits on top of another base with Git rebase.
|
||||
; pre : The supplied arguments are valid for git rebase.
|
||||
; post : Git rebase has completed successfully or an exception was raised.
|
||||
; result : #t after a successful rebase or rebase control command.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-rebase cmd-git-rebase 'rebase)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Join development histories with Git merge.
|
||||
; pre : The supplied arguments are valid for git merge.
|
||||
; post : Git merge has completed successfully or an exception was raised.
|
||||
; result : #t after a successful merge or merge control command.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-merge cmd-git-merge 'merge)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Apply changes introduced by existing commits.
|
||||
; pre : The supplied arguments are valid for git cherry-pick.
|
||||
; post : Git cherry-pick has completed successfully or an exception was raised.
|
||||
; result : #t after a successful cherry-pick or sequencer command.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-cherry-pick cmd-git-cherry-pick 'cherry-pick)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve merge conflicts using a graphical Git merge tool.
|
||||
; pre : The supplied arguments are valid for git mergetool.
|
||||
; post : Git mergetool has completed successfully or an exception was raised.
|
||||
; result : #t after a successful mergetool command.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(def-cmd git-mergetool cmd-git-mergetool 'mergetool
|
||||
(λ (args info)
|
||||
(let ((tool-specified
|
||||
(ormap
|
||||
(λ (arg)
|
||||
(let ((value (format "~a" arg)))
|
||||
(or (string=? value "-t")
|
||||
(regexp-match? #px"^--tool=" value)
|
||||
(string=? value "--tool-help"))))
|
||||
args)))
|
||||
(if tool-specified
|
||||
args
|
||||
(let ((tool (find-mergetool)))
|
||||
(if tool
|
||||
(cons (format "--tool=~a" tool) args)
|
||||
args))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Switch branches.
|
||||
@@ -498,7 +1280,7 @@
|
||||
((string=? o "-c") (set! matches #t))
|
||||
((string=? o "-n") (set! line-nr #t))))
|
||||
e)
|
||||
(map (λ (x) (if (eq? x '-i) "-i" x)) args))))
|
||||
(map (λ (x) (if (git-argument=? x '-i) "-i" x)) args))))
|
||||
(when (eq? line-nr #f)
|
||||
(set! nargs (cons "-n" nargs))) ;; add line numbers / counts for pattern recognition
|
||||
(hash-set! info 'matches matches)
|
||||
@@ -569,7 +1351,7 @@
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Increment the package version in info.rkt.
|
||||
; pre : kind is 'maj, 'major, 'min, 'minor or 'patch.
|
||||
; pre : kind represents maj, major, min, minor or patch as symbol or text.
|
||||
; post : The version definition in info.rkt has been updated.
|
||||
; result : The new version as a list containing major, minor and patch.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@@ -578,19 +1360,36 @@
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Implement the registered new-version command.
|
||||
; pre : args contains a supported version kind.
|
||||
; pre : args contains a supported version kind as symbol or text.
|
||||
; post : The version definition in info.rkt has been updated.
|
||||
; result : The new version as a list containing major, minor and patch.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (cmd-git-new-version args)
|
||||
(when(null? args)
|
||||
(when (null? args)
|
||||
(error "git-new-version expects 'maj, 'major, 'min, 'minor or 'patch"))
|
||||
(let ((kind (car args)))
|
||||
(git-next-version kind ".")
|
||||
(info-next-version kind ".")
|
||||
(git-version)))
|
||||
|
||||
(hash-set! git-commands 'new-version cmd-git-new-version)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Implement the registered next-version command.
|
||||
; pre : args must be empty.
|
||||
; post : The version definition in info.rkt has been updated.
|
||||
; result : The new patch version.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-next-version . args)
|
||||
(cmd-git-next-version args))
|
||||
|
||||
(define (cmd-git-next-version args)
|
||||
(unless (null? args)
|
||||
(error "git-next-version expexts no arguments"))
|
||||
(let ((kind 'patch))
|
||||
(info-next-version kind ".")
|
||||
(git-version)))
|
||||
|
||||
(hash-set! git-commands 'next-version cmd-git-next-version)
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,273 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/path
|
||||
racket/string
|
||||
"config.rkt")
|
||||
|
||||
(provide find-editor
|
||||
find-editors
|
||||
editor-downloads
|
||||
configured-editor
|
||||
set-editor!
|
||||
set-editor-auto!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Quote an executable path for use as a Git editor command.
|
||||
; pre : p is a path to an executable.
|
||||
; post : p has only been converted to a string.
|
||||
; result : A quoted command path.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (quote-command-path p)
|
||||
(format "\"~a\"" (path->string p)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Build a path below an environment variable when it is defined.
|
||||
; pre : variable is an environment variable name.
|
||||
; post : The environment has only been inspected.
|
||||
; result : The constructed path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (environment-path variable . parts)
|
||||
(let ((base (getenv variable)))
|
||||
(if base
|
||||
(apply build-path base parts)
|
||||
#f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Make an editor description from an executable path.
|
||||
; pre : p is a path or #f; arguments contains any required wait arguments.
|
||||
; post : The filesystem has only been inspected.
|
||||
; result : (name description command), or #f when the executable does not exist.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (editor-at name description p arguments)
|
||||
(if (and p (file-exists? p))
|
||||
(list name
|
||||
description
|
||||
(string-append (quote-command-path p) arguments))
|
||||
#f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find an editor executable on PATH.
|
||||
; pre : executable is a pathless executable name.
|
||||
; post : PATH has only been inspected.
|
||||
; result : (name description command), or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (editor-on-path name description executable arguments)
|
||||
(let ((p (find-executable-path executable)))
|
||||
(editor-at name description p arguments)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Remove duplicate editor descriptions while preserving preference order.
|
||||
; pre : editors contains editor descriptions or #f values.
|
||||
; post : editors has only been inspected.
|
||||
; result : One editor description per editor name.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (unique-editors editors)
|
||||
(let loop ((remaining editors)
|
||||
(names '())
|
||||
(result '()))
|
||||
(cond
|
||||
((null? remaining)
|
||||
(reverse result))
|
||||
((not (car remaining))
|
||||
(loop (cdr remaining) names result))
|
||||
(else
|
||||
(let* ((editor (car remaining))
|
||||
(name (car editor)))
|
||||
(if (member name names)
|
||||
(loop (cdr remaining) names result)
|
||||
(loop (cdr remaining)
|
||||
(cons name names)
|
||||
(cons editor result))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return known GUI editors found on Windows.
|
||||
; pre : The current platform is Windows.
|
||||
; post : PATH and standard Windows installation locations were inspected.
|
||||
; result : A list of editor descriptions.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-windows-editors)
|
||||
(unique-editors
|
||||
(list
|
||||
(editor-on-path "vscode" "Visual Studio Code" "code.cmd" " --wait")
|
||||
(editor-on-path "vscode" "Visual Studio Code" "code.exe" " --wait")
|
||||
(editor-at
|
||||
"vscode"
|
||||
"Visual Studio Code"
|
||||
(environment-path "LOCALAPPDATA" "Programs" "Microsoft VS Code" "bin" "code.cmd")
|
||||
" --wait")
|
||||
(editor-at
|
||||
"vscode"
|
||||
"Visual Studio Code"
|
||||
(environment-path "ProgramFiles" "Microsoft VS Code" "bin" "code.cmd")
|
||||
" --wait")
|
||||
(editor-at
|
||||
"vscode"
|
||||
"Visual Studio Code"
|
||||
(environment-path "ProgramFiles(x86)" "Microsoft VS Code" "bin" "code.cmd")
|
||||
" --wait")
|
||||
(editor-on-path "notepad++"
|
||||
"Notepad++"
|
||||
"notepad++.exe"
|
||||
" -multiInst -nosession")
|
||||
(editor-at
|
||||
"notepad++"
|
||||
"Notepad++"
|
||||
(environment-path "ProgramFiles" "Notepad++" "notepad++.exe")
|
||||
" -multiInst -nosession")
|
||||
(editor-at
|
||||
"notepad++"
|
||||
"Notepad++"
|
||||
(environment-path "ProgramFiles(x86)" "Notepad++" "notepad++.exe")
|
||||
" -multiInst -nosession")
|
||||
(editor-on-path "notepad" "Notepad" "notepad.exe" "")
|
||||
(editor-at
|
||||
"notepad"
|
||||
"Notepad"
|
||||
(environment-path "SystemRoot" "System32" "notepad.exe")
|
||||
""))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return known GUI editors found on macOS.
|
||||
; pre : The current platform is macOS.
|
||||
; post : PATH and standard application locations were inspected.
|
||||
; result : A list of editor descriptions.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-macos-editors)
|
||||
(unique-editors
|
||||
(list
|
||||
(editor-on-path "vscode" "Visual Studio Code" "code" " --wait")
|
||||
(editor-at
|
||||
"vscode"
|
||||
"Visual Studio Code"
|
||||
(string->path
|
||||
"/Applications/Visual Studio Code.app/Contents/Resources/app/bin/code")
|
||||
" --wait")
|
||||
(let ((open
|
||||
(or (find-executable-path "open")
|
||||
(let ((p (string->path "/usr/bin/open")))
|
||||
(if (file-exists? p) p #f)))))
|
||||
(if open
|
||||
(list "textedit"
|
||||
"TextEdit"
|
||||
(format "~a -W -a TextEdit" (quote-command-path open)))
|
||||
#f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return known GUI editors found on Unix/Linux.
|
||||
; pre : The current platform is Unix.
|
||||
; post : PATH and common Linux installation locations were inspected.
|
||||
; result : A list of editor descriptions.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-unix-editors)
|
||||
(unique-editors
|
||||
(list
|
||||
(editor-on-path "vscode" "Visual Studio Code" "code" " --wait")
|
||||
(editor-on-path "kate" "Kate" "kate" " --block")
|
||||
(editor-on-path "gedit" "Gedit" "gedit" " --wait")
|
||||
(editor-on-path "xed" "Xed" "xed" " --wait")
|
||||
(editor-at "vscode" "Visual Studio Code" (string->path "/snap/bin/code") " --wait")
|
||||
(editor-at "vscode" "Visual Studio Code" (string->path "/usr/local/bin/code") " --wait")
|
||||
(editor-at "vscode" "Visual Studio Code" (string->path "/usr/bin/code") " --wait")
|
||||
(editor-at "kate" "Kate" (string->path "/usr/local/bin/kate") " --block")
|
||||
(editor-at "kate" "Kate" (string->path "/usr/bin/kate") " --block")
|
||||
(editor-at "gedit" "Gedit" (string->path "/usr/bin/gedit") " --wait")
|
||||
(editor-at "xed" "Xed" (string->path "/usr/bin/xed") " --wait"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Set the editor environment variables for Git commands started by git-cli.
|
||||
; pre : command is a valid Git editor command.
|
||||
; post : GIT_EDITOR and GIT_SEQUENCE_EDITOR contain command.
|
||||
; result : command.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (set-editor-environment! command)
|
||||
(putenv "GIT_EDITOR" command)
|
||||
(putenv "GIT_SEQUENCE_EDITOR" command)
|
||||
command)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return all well-known GUI editors found on the current platform.
|
||||
; pre : The platform and filesystem are available.
|
||||
; post : No editor has been started.
|
||||
; result : A list of (name description command) items.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-editors)
|
||||
(case (system-type 'os)
|
||||
((windows) (find-windows-editors))
|
||||
((macosx) (find-macos-editors))
|
||||
((unix) (find-unix-editors))
|
||||
(else '())))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return official download pointers for optional GUI editors.
|
||||
; pre : The current platform is known.
|
||||
; post : No network request has been made.
|
||||
; result : A list of (name description url) items.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (editor-downloads)
|
||||
(case (system-type 'os)
|
||||
((windows)
|
||||
'(("vscode" "Visual Studio Code" "https://code.visualstudio.com/download")
|
||||
("notepad++" "Notepad++" "https://notepad-plus-plus.org/downloads/")))
|
||||
((macosx)
|
||||
'(("vscode" "Visual Studio Code" "https://code.visualstudio.com/download")))
|
||||
((unix)
|
||||
'(("vscode" "Visual Studio Code" "https://code.visualstudio.com/download")))
|
||||
(else '())))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the editor explicitly configured for git-cli.
|
||||
; pre : The git-cli configuration is readable.
|
||||
; post : The configuration has not been changed.
|
||||
; result : The configured editor command, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (configured-editor)
|
||||
(let ((editor (cfg-get 'git 'editor #f)))
|
||||
(if (and (string? editor)
|
||||
(not (string=? (string-trim editor) "")))
|
||||
editor
|
||||
#f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Store and activate the editor command used by git-cli.
|
||||
; pre : command is a command string suitable for GIT_EDITOR.
|
||||
; post : The command has been stored and applied to the Git editor environment.
|
||||
; result : command.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (set-editor! command)
|
||||
(cfg-set! 'git 'editor command)
|
||||
(set-editor-environment! command))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return git-cli to automatic editor detection and activate that editor.
|
||||
; pre : A well-known GUI editor can be found on the current platform.
|
||||
; post : The explicit editor setting is cleared and the detected editor is active.
|
||||
; result : The automatically detected editor command.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (set-editor-auto!)
|
||||
(let ((editors (find-editors)))
|
||||
(if (null? editors)
|
||||
(error 'git-config "No well-known GUI editor found")
|
||||
(begin
|
||||
(cfg-set! 'git 'editor "")
|
||||
(set-editor-environment! (caddr (car editors)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the GUI editor that git-cli should offer to Git.
|
||||
; pre : The platform and git-cli configuration are available.
|
||||
; post : No editor has been started.
|
||||
; result : A configured or well-known GUI editor command, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-editor)
|
||||
(or (configured-editor)
|
||||
(let ((editors (find-editors)))
|
||||
(if (null? editors)
|
||||
#f
|
||||
(caddr (car editors))))))
|
||||
@@ -0,0 +1,306 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/path
|
||||
"config.rkt")
|
||||
|
||||
(provide find-mergetool
|
||||
find-mergetools
|
||||
find-mergetool-path
|
||||
mergetool-downloads
|
||||
configured-mergetool
|
||||
set-mergetool!
|
||||
set-mergetool-auto!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Build a path below an environment variable when it is defined.
|
||||
; pre : variable is an environment variable name.
|
||||
; post : The environment has only been inspected.
|
||||
; result : The constructed path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (environment-path variable . parts)
|
||||
(let ((base (getenv variable)))
|
||||
(if base
|
||||
(apply build-path base parts)
|
||||
#f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find one merge tool candidate on PATH or at a well-known path.
|
||||
; pre : candidate contains tool name, executable name and zero or more paths.
|
||||
; post : PATH and the filesystem have only been inspected.
|
||||
; result : A list containing tool name and executable path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-candidate candidate)
|
||||
(let* ((tool (car candidate))
|
||||
(executable (cadr candidate))
|
||||
(path-executable (find-executable-path executable)))
|
||||
(cond
|
||||
(path-executable
|
||||
(list tool path-executable))
|
||||
(else
|
||||
(let loop ((paths (cddr candidate)))
|
||||
(cond
|
||||
((null? paths) #f)
|
||||
((and (car paths)
|
||||
(file-exists? (car paths)))
|
||||
(list tool (car paths)))
|
||||
(else
|
||||
(loop (cdr paths)))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the first usable merge tool candidate.
|
||||
; pre : candidates contains merge tool candidate descriptions.
|
||||
; post : PATH and the filesystem have only been inspected.
|
||||
; result : A list containing tool name and executable path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-candidates candidates)
|
||||
(cond
|
||||
((null? candidates) #f)
|
||||
(else
|
||||
(let ((candidate (find-candidate (car candidates))))
|
||||
(if candidate
|
||||
candidate
|
||||
(find-candidates (cdr candidates)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return every usable merge tool candidate without duplicate tool names.
|
||||
; pre : candidates contains merge tool candidate descriptions.
|
||||
; post : PATH and the filesystem have only been inspected.
|
||||
; result : A list of (tool description path) items.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-all-candidates candidates)
|
||||
(let loop ((remaining candidates)
|
||||
(names '())
|
||||
(result '()))
|
||||
(cond
|
||||
((null? remaining)
|
||||
(reverse result))
|
||||
(else
|
||||
(let ((candidate (find-candidate (car remaining))))
|
||||
(cond
|
||||
((not candidate)
|
||||
(loop (cdr remaining) names result))
|
||||
((member (car candidate) names)
|
||||
(loop (cdr remaining) names result))
|
||||
(else
|
||||
(loop (cdr remaining)
|
||||
(cons (car candidate) names)
|
||||
(cons
|
||||
(list (car candidate)
|
||||
(mergetool-description (car candidate))
|
||||
(cadr candidate))
|
||||
result)))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return well-known graphical merge tool candidates for Windows.
|
||||
; pre : Windows environment variables may or may not be defined.
|
||||
; post : The environment has only been inspected.
|
||||
; result : Merge tool candidate descriptions in preference order.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return a display description for a known Git merge tool.
|
||||
; pre : tool is a Git merge tool name.
|
||||
; post : tool has only been inspected.
|
||||
; result : A human-readable description.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (mergetool-description tool)
|
||||
(cond
|
||||
((string=? tool "winmerge") "WinMerge")
|
||||
((string=? tool "vscode") "Visual Studio Code")
|
||||
((string=? tool "kdiff3") "KDiff3")
|
||||
((string=? tool "meld") "Meld")
|
||||
((string=? tool "tortoisemerge") "TortoiseMerge")
|
||||
((string=? tool "opendiff") "FileMerge / opendiff")
|
||||
(else tool)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return well-known graphical merge tool candidates for Windows.
|
||||
; pre : Windows environment variables may or may not be defined.
|
||||
; post : The environment has only been inspected.
|
||||
; result : Merge tool candidate descriptions in preference order.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (windows-mergetool-candidates)
|
||||
(list
|
||||
(list "winmerge" "WinMergeU.exe"
|
||||
(environment-path "ProgramFiles" "WinMerge" "WinMergeU.exe")
|
||||
(environment-path "ProgramFiles(x86)" "WinMerge" "WinMergeU.exe"))
|
||||
(list "vscode" "code.cmd"
|
||||
(environment-path "LOCALAPPDATA" "Programs" "Microsoft VS Code" "bin" "code.cmd")
|
||||
(environment-path "ProgramFiles" "Microsoft VS Code" "bin" "code.cmd")
|
||||
(environment-path "ProgramFiles(x86)" "Microsoft VS Code" "bin" "code.cmd"))
|
||||
(list "vscode" "code.exe"
|
||||
(environment-path "LOCALAPPDATA" "Programs" "Microsoft VS Code" "Code.exe")
|
||||
(environment-path "ProgramFiles" "Microsoft VS Code" "Code.exe")
|
||||
(environment-path "ProgramFiles(x86)" "Microsoft VS Code" "Code.exe"))
|
||||
(list "kdiff3" "kdiff3.exe"
|
||||
(environment-path "ProgramFiles" "KDiff3" "kdiff3.exe")
|
||||
(environment-path "ProgramFiles(x86)" "KDiff3" "kdiff3.exe"))
|
||||
(list "meld" "meld.exe"
|
||||
(environment-path "LOCALAPPDATA" "Programs" "Meld" "Meld.exe")
|
||||
(environment-path "ProgramFiles" "Meld" "Meld.exe")
|
||||
(environment-path "ProgramFiles(x86)" "Meld" "Meld.exe"))
|
||||
(list "tortoisemerge" "TortoiseMerge.exe"
|
||||
(environment-path "ProgramFiles" "TortoiseSVN" "bin" "TortoiseMerge.exe")
|
||||
(environment-path "ProgramFiles(x86)" "TortoiseSVN" "bin" "TortoiseMerge.exe"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return well-known graphical merge tool candidates for macOS.
|
||||
; pre : The current platform is macOS.
|
||||
; post : No program has been started.
|
||||
; result : Merge tool candidate descriptions in preference order.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (macos-mergetool-candidates)
|
||||
(list
|
||||
(list "opendiff" "opendiff"
|
||||
(string->path "/usr/bin/opendiff"))
|
||||
(list "vscode" "code"
|
||||
(string->path
|
||||
"/Applications/Visual Studio Code.app/Contents/Resources/app/bin/code"))
|
||||
(list "kdiff3" "kdiff3"
|
||||
(string->path "/Applications/kdiff3.app/Contents/MacOS/kdiff3"))
|
||||
(list "meld" "meld")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return well-known graphical merge tool candidates for Unix/Linux.
|
||||
; pre : The current platform is Unix.
|
||||
; post : No program has been started.
|
||||
; result : Merge tool candidate descriptions in preference order.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (unix-mergetool-candidates)
|
||||
(list
|
||||
(list "meld" "meld"
|
||||
(string->path "/usr/bin/meld")
|
||||
(string->path "/usr/local/bin/meld"))
|
||||
(list "kdiff3" "kdiff3"
|
||||
(string->path "/usr/bin/kdiff3")
|
||||
(string->path "/usr/local/bin/kdiff3"))
|
||||
(list "vscode" "code"
|
||||
(string->path "/snap/bin/code")
|
||||
(string->path "/usr/bin/code")
|
||||
(string->path "/usr/local/bin/code"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return merge tool candidates for the current platform.
|
||||
; pre : The current platform is supported by Racket.
|
||||
; post : No program has been started.
|
||||
; result : Merge tool candidate descriptions.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (mergetool-candidates)
|
||||
(case (system-type 'os)
|
||||
((windows) (windows-mergetool-candidates))
|
||||
((macosx) (macos-mergetool-candidates))
|
||||
((unix) (unix-mergetool-candidates))
|
||||
(else '())))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the automatically detected merge tool and executable path.
|
||||
; pre : Platform paths are accessible.
|
||||
; post : No merge tool has been started.
|
||||
; result : A list containing tool name and path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (detected-mergetool)
|
||||
(find-candidates (mergetool-candidates)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the merge tool explicitly configured for git-cli.
|
||||
; pre : The git-cli configuration is readable.
|
||||
; post : The configuration has not been changed.
|
||||
; result : The configured Git merge tool name, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return all well-known merge tools found on the current platform.
|
||||
; pre : The platform and filesystem are available.
|
||||
; post : No merge tool has been started.
|
||||
; result : A list of (name description path) items.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-mergetools)
|
||||
(find-all-candidates (mergetool-candidates)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return official download pointers for optional merge tools.
|
||||
; pre : The current platform is known.
|
||||
; post : No network request has been made.
|
||||
; result : A list of (name description url) items.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (mergetool-downloads)
|
||||
(case (system-type 'os)
|
||||
((windows)
|
||||
'(("winmerge" "WinMerge" "https://winmerge.org/downloads/")
|
||||
("kdiff3" "KDiff3" "https://apps.kde.org/kdiff3/")
|
||||
("meld" "Meld" "https://meldmerge.org/")
|
||||
("vscode" "Visual Studio Code" "https://code.visualstudio.com/download")))
|
||||
((macosx)
|
||||
'(("kdiff3" "KDiff3" "https://apps.kde.org/kdiff3/")
|
||||
("vscode" "Visual Studio Code" "https://code.visualstudio.com/download")))
|
||||
((unix)
|
||||
'(("meld" "Meld" "https://meldmerge.org/")
|
||||
("kdiff3" "KDiff3" "https://apps.kde.org/kdiff3/")
|
||||
("vscode" "Visual Studio Code" "https://code.visualstudio.com/download")))
|
||||
(else '())))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (configured-mergetool)
|
||||
(let ((tool (cfg-get 'git 'mergetool #f)))
|
||||
(if (and (string? tool)
|
||||
(not (string=? tool "")))
|
||||
tool
|
||||
#f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Store the Git merge tool name used by git-cli.
|
||||
; pre : tool is a Git mergetool name such as "winmerge" or "meld".
|
||||
; post : The tool name has been stored in the git-cli configuration.
|
||||
; result : The result returned by the configuration layer.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (set-mergetool! tool)
|
||||
(cfg-set! 'git 'mergetool tool))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return git-cli to automatic merge tool detection.
|
||||
; pre : A well-known merge tool can be found on the current platform.
|
||||
; post : The explicit merge tool setting is cleared.
|
||||
; result : The automatically detected Git merge tool name.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (set-mergetool-auto!)
|
||||
(let ((detected (detected-mergetool)))
|
||||
(if detected
|
||||
(begin
|
||||
(cfg-set! 'git 'mergetool "")
|
||||
(car detected))
|
||||
(error 'git-config "No well-known merge tool found"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the graphical merge tool that git-cli should prefer.
|
||||
; pre : The platform and git-cli configuration are available.
|
||||
; post : No merge tool has been started.
|
||||
; result : A configured or detected Git merge tool name, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-mergetool)
|
||||
(or (configured-mergetool)
|
||||
(let ((detected (detected-mergetool)))
|
||||
(if detected
|
||||
(car detected)
|
||||
#f))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the executable path belonging to the automatically detected merge tool.
|
||||
; pre : Platform paths are accessible.
|
||||
; post : No merge tool has been started.
|
||||
; result : The executable path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-mergetool-path)
|
||||
(let ((tool (find-mergetool)))
|
||||
(if tool
|
||||
(let loop ((tools (find-mergetools)))
|
||||
(cond
|
||||
((null? tools) #f)
|
||||
((string=? tool (car (car tools)))
|
||||
(caddr (car tools)))
|
||||
(else
|
||||
(loop (cdr tools)))))
|
||||
#f)))
|
||||
@@ -0,0 +1,287 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/string
|
||||
net/url
|
||||
"git-provider.rkt"
|
||||
"utils.rkt")
|
||||
|
||||
(provide exn:fail:git-auth?
|
||||
exn:fail:git-auth-command
|
||||
exn:fail:git-auth-args
|
||||
exn:fail:git-auth-exit-code
|
||||
exn:fail:git-auth-output
|
||||
authentication-failure?
|
||||
raise-git-auth-error
|
||||
default-git-authentication-handler
|
||||
reject-git-authentication
|
||||
current-git-authentication-handler)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Authentication exception
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(struct exn:fail:git-auth exn:fail
|
||||
(command args exit-code output)
|
||||
#:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the first value of a Git configuration key.
|
||||
; pre : key is a Git configuration key.
|
||||
; post : Git config has been queried without displaying its output.
|
||||
; result : The configured value, or #f when the key is absent.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-config-value key)
|
||||
(let-values (((exit-code output)
|
||||
(run-git (list 'config '--get key))))
|
||||
(if (= exit-code 0)
|
||||
(let ((stdout
|
||||
(map cadr
|
||||
(filter (λ (entry) (eq? (car entry) 'stdout))
|
||||
output))))
|
||||
(if (null? stdout) #f (car stdout)))
|
||||
#f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Determine the remote name used by the current branch.
|
||||
; pre : The current directory is a Git working tree.
|
||||
; post : Git branch/config have only been queried.
|
||||
; result : The configured remote name, or "origin" as fallback.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-current-remote)
|
||||
(let-values (((exit-code output)
|
||||
(run-git '(branch --show-current))))
|
||||
(if (= exit-code 0)
|
||||
(let ((stdout
|
||||
(map cadr
|
||||
(filter (λ (entry) (eq? (car entry) 'stdout))
|
||||
output))))
|
||||
(if (null? stdout)
|
||||
"origin"
|
||||
(let ((remote
|
||||
(git-config-value
|
||||
(format "branch.~a.remote" (car stdout)))))
|
||||
(if remote remote "origin"))))
|
||||
"origin")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Determine the remote URL relevant to the failed Git command.
|
||||
; pre : cmd and args belong to a failed authenticated Git command.
|
||||
; post : Git config has only been queried.
|
||||
; result : An HTTP(S) remote URL, or #f when it cannot be determined.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-authentication-url cmd args)
|
||||
(let* ((remote (git-current-remote))
|
||||
(url (git-config-value (format "remote.~a.url" remote))))
|
||||
(if url
|
||||
url
|
||||
(git-config-value "remote.origin.url"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Convert an HTTP(S) remote URL to Git credential input.
|
||||
; pre : value is a URL string.
|
||||
; post : value has only been parsed.
|
||||
; result : protocol, host and optional username, or #f values for unsupported URLs.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (url->credential-parts value)
|
||||
(with-handlers ((exn:fail? (λ (e) (values #f #f #f))))
|
||||
(let* ((u (string->url value))
|
||||
(protocol (url-scheme u))
|
||||
(host (url-host u))
|
||||
(user (url-user u)))
|
||||
(if (and (member protocol '("http" "https"))
|
||||
(string? host)
|
||||
(not (string=? host "")))
|
||||
(values protocol host user)
|
||||
(values #f #f #f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Build Git credential protocol input.
|
||||
; pre : protocol and host are strings; username and password may be #f.
|
||||
; post : Arguments have only been formatted.
|
||||
; result : A credential protocol string terminated by a blank line.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (credential-input protocol host username password)
|
||||
(string-append
|
||||
(format "protocol=~a\n" protocol)
|
||||
(format "host=~a\n" host)
|
||||
(if username (format "username=~a\n" username) "")
|
||||
(if password (format "password=~a\n" password) "")
|
||||
"\n"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Ask Git's configured credential helper for credentials.
|
||||
; pre : protocol and host identify the failed HTTP(S) remote.
|
||||
; post : The helper may have prompted or updated its own credential state.
|
||||
; result : #t when git credential fill succeeded, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-credential-fill protocol host username)
|
||||
(let-values (((exit-code output)
|
||||
(run-git '(credential fill)
|
||||
#:input (credential-input protocol host username #f))))
|
||||
(= exit-code 0)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Offer credentials to Git's configured credential helper.
|
||||
; pre : protocol, host, username and password describe a credential.
|
||||
; post : Git credential approve has been invoked.
|
||||
; result : #t when Git accepted the approve operation, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-credential-approve protocol host username password)
|
||||
(let-values (((exit-code output)
|
||||
(run-git '(credential approve)
|
||||
#:input (credential-input protocol host username password))))
|
||||
(= exit-code 0)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Reject credentials for an HTTP(S) remote through Git.
|
||||
; pre : protocol and host identify the credential; username may be #f.
|
||||
; post : Git credential reject has been invoked.
|
||||
; result : #t when Git accepted the reject operation, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-credential-reject protocol host username)
|
||||
(let-values (((exit-code output)
|
||||
(run-git '(credential reject)
|
||||
#:input (credential-input protocol host username #f))))
|
||||
(= exit-code 0)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Ensure a non-persistent credential helper exists for this repository.
|
||||
; pre : The current directory is inside a Git working tree.
|
||||
; post : credential.helper=cache is configured locally when no helper existed.
|
||||
; result : #t when a helper exists or was configured, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (ensure-credential-helper)
|
||||
(let ((helper (git-config-value "credential.helper")))
|
||||
(if helper
|
||||
#t
|
||||
(let-values (((exit-code output)
|
||||
(run-git '(config --local credential.helper cache))))
|
||||
(= exit-code 0)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Ask the user for credentials and approve them through Git.
|
||||
; pre : protocol and host identify an HTTP(S) remote.
|
||||
; post : Supplied credentials have been offered to Git's helper.
|
||||
; result : #t when credentials were approved, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (ask-and-approve-credential protocol host username)
|
||||
(let* ((username*
|
||||
(if username
|
||||
username
|
||||
(input-prompt
|
||||
(format "Username for ~a: " host)
|
||||
#:loop-until
|
||||
(λ (value)
|
||||
(cond
|
||||
((eof-object? value)
|
||||
(error 'git-authentication "Input cancelled"))
|
||||
((string=? (string-trim value) "")
|
||||
#f)
|
||||
(else
|
||||
(string-trim value)))))))
|
||||
(password
|
||||
(input-prompt
|
||||
(format "Password/token for ~a: " host)
|
||||
#:loop-until
|
||||
(λ (value)
|
||||
(cond
|
||||
((eof-object? value)
|
||||
(error 'git-authentication "Input cancelled"))
|
||||
((string=? value "")
|
||||
#f)
|
||||
(else
|
||||
value))))))
|
||||
(and (ensure-credential-helper)
|
||||
(git-credential-approve protocol host username* password))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Authentication handling
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Recognize output that indicates Git authentication failed.
|
||||
; pre : exit-code and output belong to a completed Git command.
|
||||
; post : output has only been inspected.
|
||||
; result : #t when a known authentication failure is present, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define auth-recognizer
|
||||
#px"(authentication failed|failed to authenticate|could not read (username|password)|access denied|terminal prompts disabled|requested url returned error: (401|403))")
|
||||
|
||||
(define (authentication-failure? exit-code output)
|
||||
(and (not (= exit-code 0))
|
||||
(ormap
|
||||
(λ (entry)
|
||||
(let ((line (string-downcase (format "~a" (cadr entry)))))
|
||||
(regexp-match? auth-recognizer line)))
|
||||
output)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Raise a Git authentication exception containing the failed invocation.
|
||||
; pre : cmd, args, exit-code and output describe a failed Git command.
|
||||
; post : An exn:fail:git-auth exception has been raised.
|
||||
; result : No normal return value.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (raise-git-auth-error cmd args exit-code output)
|
||||
(let ((msg (format "git ~a: authentication failed" cmd)))
|
||||
(raise
|
||||
(exn:fail:git-auth msg
|
||||
(current-continuation-marks)
|
||||
cmd
|
||||
args
|
||||
exit-code
|
||||
output))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Reject the credential associated with a failed Git command.
|
||||
; pre : cmd and args identify a failed authenticated Git invocation.
|
||||
; post : Git's credential helper has been asked to forget the credential.
|
||||
; result : #t when a credential could be identified and rejected, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (reject-git-authentication cmd args)
|
||||
(let ((url (git-authentication-url cmd args)))
|
||||
(if (not url)
|
||||
#f
|
||||
(let-values (((protocol host username)
|
||||
(url->credential-parts url)))
|
||||
(if protocol
|
||||
(git-credential-reject protocol host username)
|
||||
#f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve an authentication failure using Git first, then input-prompt.
|
||||
; pre : cmd, args and e describe one failed Git invocation.
|
||||
; post : Git's helper has been tried; a missing helper may be configured locally.
|
||||
; result : #t when retrying the original command is meaningful, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (default-git-authentication-handler cmd args e)
|
||||
(let ((url (git-authentication-url cmd args)))
|
||||
(if (not url)
|
||||
#f
|
||||
(let-values (((protocol host username)
|
||||
(url->credential-parts url)))
|
||||
(if (not protocol)
|
||||
#f
|
||||
(let ((helper (git-config-value "credential.helper")))
|
||||
(when helper
|
||||
(git-credential-reject protocol host username))
|
||||
(if (and helper
|
||||
(git-credential-fill protocol host username))
|
||||
#t
|
||||
(ask-and-approve-credential
|
||||
protocol host username))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Supply the callback that can resolve an authentication failure.
|
||||
; pre : The callback accepts command, arguments and an exn:fail:git-auth value.
|
||||
; post : The callback is used by command proxies before one authentication retry.
|
||||
; result : A parameter containing the current authentication callback.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define current-git-authentication-handler
|
||||
(make-parameter default-git-authentication-handler))
|
||||
@@ -1,6 +1,7 @@
|
||||
#lang racket/base
|
||||
|
||||
(require "git-provider.rkt"
|
||||
"git-auth.rkt"
|
||||
racket/string
|
||||
racket/list
|
||||
)
|
||||
@@ -9,6 +10,13 @@
|
||||
check-git-args
|
||||
has-git-arg?
|
||||
std-process-git-result
|
||||
default-git-authentication-handler
|
||||
current-git-authentication-handler
|
||||
exn:fail:git-auth?
|
||||
exn:fail:git-auth-command
|
||||
exn:fail:git-auth-args
|
||||
exn:fail:git-auth-exit-code
|
||||
exn:fail:git-auth-output
|
||||
)
|
||||
|
||||
|
||||
@@ -83,7 +91,8 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Define the internal proxy for a Git command.
|
||||
; pre : pre-code and process-result accept the command proxy arguments.
|
||||
; post : The proxy invokes Git without standard input and processes its result.
|
||||
; post : Authentication failures are offered once to the current authentication
|
||||
; handler before the Git command is retried.
|
||||
; result : A procedure named f accepting a list of Git arguments.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define-syntax def-git-cmd-proxy
|
||||
@@ -93,8 +102,27 @@
|
||||
(let* ((args (flatten args*))
|
||||
(info (make-hash))
|
||||
(nargs (pre-code args info)))
|
||||
(let retry ((authentication-retry? #t))
|
||||
(with-handlers
|
||||
((exn:fail:git-auth?
|
||||
(λ (e)
|
||||
(if authentication-retry?
|
||||
(if ((current-git-authentication-handler) cmd nargs e)
|
||||
(retry #f)
|
||||
(git-error cmd
|
||||
(format "Exitcode <> 0: ~a"
|
||||
(exn:fail:git-auth-exit-code e))
|
||||
(exn:fail:git-auth-output e)))
|
||||
(begin
|
||||
(reject-git-authentication cmd nargs)
|
||||
(git-error cmd
|
||||
(format "Exitcode <> 0: ~a"
|
||||
(exn:fail:git-auth-exit-code e))
|
||||
(exn:fail:git-auth-output e)))))))
|
||||
(let-values (((exit-code output) (run-git (cons cmd nargs))))
|
||||
(when (authentication-failure? exit-code output)
|
||||
(raise-git-auth-error cmd nargs exit-code output))
|
||||
(let-values (((result out) (git-out cmd output)))
|
||||
(process-result cmd exit-code result output out info))))))
|
||||
(process-result cmd exit-code result output out info))))))))
|
||||
)
|
||||
)
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
racket/contract
|
||||
racket/system
|
||||
"config.rkt"
|
||||
"find-editor.rkt"
|
||||
)
|
||||
|
||||
(provide git-exe
|
||||
@@ -94,8 +95,31 @@
|
||||
; read completely.
|
||||
; result : The exit code and ordered (source line) output items.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (run-git args #:input (input #f))
|
||||
; goal : Configure the process environment used by git-cli Git commands.
|
||||
; pre : The editor finder can inspect the current platform.
|
||||
; post : Terminal prompting is disabled and a detected GUI editor is made
|
||||
; available to Git and Git's sequence editor.
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (setup-git-environment!)
|
||||
(putenv "GIT_TERMINAL_PROMPT" "0")
|
||||
(let ((editor (find-editor)))
|
||||
(when editor
|
||||
(putenv "GIT_EDITOR" editor)
|
||||
(putenv "GIT_SEQUENCE_EDITOR" editor)))
|
||||
(void))
|
||||
|
||||
(setup-git-environment!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Run Git without allowing interactive terminal prompts.
|
||||
; pre : args contains the Git command and its arguments; input is #f or a string
|
||||
; that must be written to Git's standard input.
|
||||
; post : Optional input has been written and standard output and error have been
|
||||
; read completely.
|
||||
; result : The exit code and ordered (source line) output items.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (run-git args #:input (input #f))
|
||||
(let-values (((process stdout stdin stderr)
|
||||
(apply subprocess
|
||||
#f
|
||||
@@ -111,7 +135,7 @@
|
||||
(let ((output-channel (make-channel)))
|
||||
(define (read-output source port)
|
||||
(thread
|
||||
(lambda ()
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(let ((line (read-line port)))
|
||||
(channel-put output-channel (list source line))
|
||||
|
||||
@@ -6,7 +6,7 @@
|
||||
|
||||
(provide info-version
|
||||
set-info-version!
|
||||
git-next-version
|
||||
info-next-version
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@@ -70,23 +70,24 @@
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Increment a package version.
|
||||
; pre : kind is maj, major, min, minor or patch.
|
||||
; pre : kind represents maj, major, min, minor or patch as symbol or text.
|
||||
; post : The version definition in info.rkt has been updated.
|
||||
; result : #t after writing the new version.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-next-version kind . dir*)
|
||||
(define (info-next-version kind . dir*)
|
||||
(let ((dir (if (null? dir*)
|
||||
"."
|
||||
(car dir*))))
|
||||
(if (memq kind '(maj major min minor patch))
|
||||
(car dir*)))
|
||||
(kind* (string->symbol (format "~a" kind))))
|
||||
(if (memq kind* '(maj major min minor patch))
|
||||
(let ((v (info-version dir)))
|
||||
(cond
|
||||
((or (eq? kind 'maj)
|
||||
(eq? kind 'major))
|
||||
((or (eq? kind* 'maj)
|
||||
(eq? kind* 'major))
|
||||
(apply set-info-version! (cons dir
|
||||
(list (+ (car v) 1) 0 0))))
|
||||
((or (eq? kind 'min)
|
||||
(eq? kind 'minor))
|
||||
((or (eq? kind* 'min)
|
||||
(eq? kind* 'minor))
|
||||
(apply set-info-version! (cons dir
|
||||
(list (car v) (+ (cadr v) 1) 0))))
|
||||
(else
|
||||
+18
-1
@@ -6,6 +6,24 @@
|
||||
valid-http-or-file-url?
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Ask the user for input .
|
||||
; pre : p is a prompt.
|
||||
; post : It should give back the supplied input as string.
|
||||
; result : the return value of until.
|
||||
; internals:
|
||||
;
|
||||
; input-prompt displays the given prompt and reads a line
|
||||
; of text. After the user presses enter, this line is
|
||||
; fed to the until callback. If the until callback returns
|
||||
; #f, the prompt is displayed again. Otherwise, the value
|
||||
; of until is returned.
|
||||
;
|
||||
; The programmer must make sure the until returns whatever
|
||||
; format is appropriate. In general it will be a string.
|
||||
;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (input-prompt p #:loop-until [until (λ (x) x)])
|
||||
(let loop ()
|
||||
(display p)
|
||||
@@ -20,7 +38,6 @@
|
||||
)
|
||||
|
||||
|
||||
|
||||
(define (valid-http-or-file-url? value)
|
||||
(if (not (string? value))
|
||||
#f
|
||||
|
||||
@@ -0,0 +1,760 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
racket/contract
|
||||
"../main.rkt"))
|
||||
|
||||
@title[#:tag "top"]{git-cli}
|
||||
@author{Hans Dijkema}
|
||||
|
||||
@defmodule[git-cli]
|
||||
|
||||
The @racketmodname[git-cli] module provides a command-line-like Git interface
|
||||
implemented by invoking the @tt{git} executable. Commands do not allow Git to
|
||||
read credentials or other answers from the terminal.
|
||||
|
||||
@section{Command interface}
|
||||
|
||||
@defform[(git command argument ...)]{
|
||||
Runs a Git @racket[command]. When the command has a registered git-cli wrapper,
|
||||
that wrapper is used. Registered wrappers can provide structured Racket results,
|
||||
argument handling, or other command-specific behavior.
|
||||
|
||||
Registered command symbols include @racket['init], @racket['status],
|
||||
@racket['add], @racket['commit], @racket['push], @racket['pull],
|
||||
@racket['fetch], @racket['config], @racket['branch], @racket['remote],
|
||||
@racket['stash], @racket['restore], @racket['reset], @racket['revert],
|
||||
@racket['rebase], @racket['merge], @racket['cherry-pick],
|
||||
@racket['mergetool], @racket['switch], @racket['clone], @racket['tag],
|
||||
@racket['log], @racket['rev-list], @racket['diff], @racket['show],
|
||||
@racket['grep], @racket['help], @racket['version], and
|
||||
@racket['new-version].
|
||||
|
||||
When no wrapper is registered, the command and arguments are passed directly to
|
||||
the installed Git executable through @racket[run-git]. The result is handled by
|
||||
the same standard result processing used by ordinary pass-through wrappers:
|
||||
normal Git output is displayed and a successful command returns @racket[#t];
|
||||
a non-zero exit status raises a git-cli error.
|
||||
|
||||
This makes dedicated wrappers optional for Git commands where git-cli does not
|
||||
add useful behavior.
|
||||
|
||||
@racketblock[
|
||||
(git 'blame "main.rkt")
|
||||
(git* clean -n)
|
||||
(git* worktree list)
|
||||
(git* archive --format=zip HEAD)
|
||||
]
|
||||
|
||||
Some registered commands process the result into a Racket value, such as
|
||||
@racket['status], @racket['grep], @racket['log] with @tt{--list},
|
||||
@racket['version], and @racket['new-version].
|
||||
}
|
||||
|
||||
|
||||
@defform[(git* command argument ...)]{
|
||||
Provides compact command-style syntax for @racket[git]. The command name is
|
||||
used as a symbol. Other literal arguments are converted to strings.
|
||||
|
||||
@racketblock[
|
||||
(git* remote -v)
|
||||
(git* switch main)
|
||||
]
|
||||
|
||||
An argument written as @racket[(eval expression)] is evaluated instead of being
|
||||
converted from its literal syntax.
|
||||
|
||||
@racketblock[
|
||||
(define branch "develop")
|
||||
(git* switch (eval branch))
|
||||
]
|
||||
|
||||
@bold{Important:} bare arguments to @racket[git*] are command-line text, not
|
||||
Racket values. An identifier is quoted syntactically and converted to a string,
|
||||
even when that identifier is also bound to a Racket variable or procedure.
|
||||
|
||||
@racketblock[
|
||||
(define branch "develop")
|
||||
|
||||
(git* switch branch)
|
||||
; passes "branch"
|
||||
|
||||
(git* switch (eval branch))
|
||||
; passes "develop"
|
||||
]
|
||||
|
||||
This distinction matters most for git-cli commands whose arguments are not
|
||||
ordinary Git command-line strings. Such wrappers should accept the textual
|
||||
arguments produced by @racket[git*]. For example, @racket[git-new-version] now
|
||||
accepts both symbols and text:
|
||||
|
||||
@racketblock[
|
||||
(git 'new-version 'min)
|
||||
(git* new-version min)
|
||||
]
|
||||
|
||||
Because @racket[git] falls back to direct Git execution for commands without a
|
||||
registered wrapper, @racket[git*] can also be used with those commands.
|
||||
|
||||
@racket[gt] is retained as a compatibility alias for @racket[git*].
|
||||
}
|
||||
|
||||
@section{Provided commands}
|
||||
|
||||
@defproc[(git-init [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git init} with the supplied arguments and returns @racket[#t] when Git
|
||||
exits successfully.
|
||||
|
||||
@racketblock[
|
||||
(git-init)
|
||||
(git* init)
|
||||
(git* init --bare)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-status [argument any/c] ...) list?]{
|
||||
Runs @tt{git status --porcelain} with the supplied arguments.
|
||||
|
||||
Each result item has the form
|
||||
@racket[(index-status worktree-status file)]. The index status describes the
|
||||
change staged for the next commit. The worktree status describes the change in
|
||||
the working tree relative to the index.
|
||||
|
||||
Both statuses are one of @racket['unchanged], @racket['modified],
|
||||
@racket['type-changed], @racket['added], @racket['deleted], @racket['renamed],
|
||||
@racket['copied], @racket['unmerged], @racket['untracked], or
|
||||
@racket['ignored]. For an untracked file, Git reports @tt{??}, so both statuses
|
||||
are @racket['untracked].
|
||||
|
||||
@racketblock[
|
||||
'((modified unchanged "staged.rkt")
|
||||
(unchanged modified "working-tree.rkt")
|
||||
(modified modified "both.rkt")
|
||||
(renamed unchanged "old.rkt -> new.rkt")
|
||||
(untracked untracked "new.rkt"))
|
||||
]}
|
||||
|
||||
@defproc[(git-add [argument any/c] ...) boolean?]{
|
||||
Adds file contents to the index. Returns @racket[#t] when Git exits with status
|
||||
zero; otherwise an exception is raised.
|
||||
}
|
||||
|
||||
@defproc[(git-commit [argument any/c] ...) boolean?]{
|
||||
Creates a commit. When @tt{-m} is omitted, a commit message is requested before
|
||||
Git is started. A repository with nothing to commit returns @racket[#t]. Other
|
||||
non-zero exit statuses, including a rejected commit hook, raise an exception.
|
||||
}
|
||||
|
||||
@defproc[(git-push [argument any/c] ...) boolean?]{
|
||||
Pushes changes using @tt{--porcelain}. Returns @racket[#t] when Git exits with
|
||||
status zero; otherwise an exception is raised.
|
||||
}
|
||||
|
||||
@defproc[(git-pull [argument any/c] ...) boolean?]{
|
||||
Fetches and integrates changes. Normal progress written by Git to standard
|
||||
error is accepted when Git exits successfully.
|
||||
}
|
||||
|
||||
@defproc[(git-fetch [argument any/c] ...) boolean?]{
|
||||
Downloads refs and objects from a remote repository without integrating them
|
||||
into the current branch. Arguments are passed directly to @tt{git fetch}.
|
||||
|
||||
For example:
|
||||
|
||||
@racketblock[
|
||||
(git-fetch)
|
||||
(git-fetch '--prune)
|
||||
(git 'fetch '--prune)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-config [argument any/c] ...) any/c]{
|
||||
Provides a Racket-oriented interface to @tt{git config}. The same interface is
|
||||
available through @racket[git] with command @racket['config].
|
||||
|
||||
@racketblock[
|
||||
(git 'config '--all)
|
||||
(git 'config 'get '--all)
|
||||
(git 'config '--global 'get '--all)
|
||||
(git 'config 'get '--global '--all)
|
||||
]
|
||||
|
||||
returns all visible configuration entries as key/value items:
|
||||
|
||||
@racketblock[
|
||||
'(("user.name" "Hans Dijkema")
|
||||
("user.email" "hans@example.invalid")
|
||||
("credential.helper" "manager"))
|
||||
]
|
||||
|
||||
@racketblock[
|
||||
(git 'config 'get "credential.helper")
|
||||
]
|
||||
|
||||
returns one value as a string, or @racket[#f] when the key is absent.
|
||||
|
||||
@racketblock[
|
||||
(git 'config 'get '--all "credential.helper")
|
||||
]
|
||||
|
||||
returns all values for one key as a list. An absent key produces the empty
|
||||
list.
|
||||
|
||||
Configuration values can be written with @racket['set!]:
|
||||
|
||||
@racketblock[
|
||||
(git 'config 'set! "user.email" "hans@example.invalid")
|
||||
(git 'config '--global 'set! "user.email" "hans@example.invalid")
|
||||
(git 'config 'set! '--global "user.email" "hans@example.invalid")
|
||||
]
|
||||
|
||||
The optional scope can be @tt{--global}, @tt{--local}, or @tt{--system}. It may
|
||||
appear directly after @racket['config] or directly after @racket['get] /
|
||||
@racket['set!]. A successful write returns @racket[#t].
|
||||
}
|
||||
|
||||
@subsection{git-cli editor configuration}
|
||||
|
||||
The @racket[git-config] procedure also recognizes the git-cli-specific
|
||||
@tt{editor} operation. This does not write Git's @tt{core.editor}; it controls
|
||||
the editor command used by git-cli through @tt{GIT_EDITOR} and
|
||||
@tt{GIT_SEQUENCE_EDITOR}.
|
||||
|
||||
With no additional argument an interactive selection is displayed.
|
||||
|
||||
@racketblock[
|
||||
(git* config editor)
|
||||
]
|
||||
|
||||
The available editors can also be returned without prompting.
|
||||
|
||||
@racketblock[
|
||||
(git* config editor --list)
|
||||
(git* config editor --downloads)
|
||||
]
|
||||
|
||||
Each item contains the short editor name, description, command and a boolean
|
||||
indicating whether that command is currently selected.
|
||||
|
||||
A detected editor can be selected by its short name, or automatic detection can
|
||||
be restored.
|
||||
|
||||
@racketblock[
|
||||
(git* config editor vscode)
|
||||
(git* config editor notepad++)
|
||||
(git* config editor auto)
|
||||
]
|
||||
|
||||
An arbitrary editor command can be supplied using the ordinary procedure form.
|
||||
|
||||
@racketblock[
|
||||
(git 'config 'editor "C:\\Program Files\\MyEditor\\editor.exe --wait")
|
||||
]
|
||||
|
||||
Changing the editor updates both @tt{GIT_EDITOR} and
|
||||
@tt{GIT_SEQUENCE_EDITOR} immediately for subsequent Git commands.
|
||||
|
||||
@defproc[(find-editors) list?]{
|
||||
Returns all well-known GUI editors found on the current platform as
|
||||
@racket[(name description command)] items.
|
||||
}
|
||||
|
||||
@defproc[(set-editor-auto!) string?]{
|
||||
Clears the explicit git-cli editor selection, activates the first automatically
|
||||
detected editor and returns its command. An exception is raised when no
|
||||
well-known GUI editor can be found.
|
||||
}
|
||||
|
||||
@defproc[(editor-downloads) list?]{
|
||||
Returns official download pointers for optional GUI editors as
|
||||
@racket[(name description url)] items. No network request is performed.
|
||||
}
|
||||
|
||||
On Windows, Notepad++ is detected both on @tt{PATH} and in the normal Program
|
||||
Files locations. git-cli invokes it with @tt{-multiInst -nosession}.
|
||||
|
||||
@subsection{git-cli merge tool configuration}
|
||||
|
||||
The @racket[git-config] procedure also recognizes the git-cli-specific
|
||||
@tt{mergetool} operation.
|
||||
|
||||
@racketblock[
|
||||
(git* config mergetool)
|
||||
(git* config mergetool --list)
|
||||
(git* config mergetool --downloads)
|
||||
(git* config mergetool winmerge)
|
||||
(git* config mergetool auto)
|
||||
]
|
||||
|
||||
With no additional argument an interactive selection is displayed.
|
||||
@tt{--list} returns @racket[(name description path current?)] items and
|
||||
@tt{--downloads} returns official download pointers. A detected merge tool can
|
||||
be selected by its short Git tool name. @tt{auto} clears the explicit git-cli
|
||||
selection and restores automatic detection.
|
||||
|
||||
@defproc[(find-mergetools) list?]{
|
||||
Returns all well-known graphical merge tools found on the current platform as
|
||||
@racket[(name description path)] items.
|
||||
}
|
||||
|
||||
@defproc[(mergetool-downloads) list?]{
|
||||
Returns official download pointers for optional merge tools as
|
||||
@racket[(name description url)] items. No network request is performed.
|
||||
}
|
||||
|
||||
@defproc[(set-mergetool-auto!) string?]{
|
||||
Clears the explicit git-cli merge tool selection and returns the first
|
||||
automatically detected Git merge tool name. An exception is raised when no
|
||||
well-known merge tool can be found.
|
||||
}
|
||||
|
||||
@defproc[(git-branch [argument any/c] ...) (or/c boolean? list?)]{
|
||||
Runs @tt{git branch} with the supplied arguments. This can be used to list,
|
||||
create, rename, or delete branches according to the options supported by the
|
||||
installed Git executable.
|
||||
|
||||
With Git's @tt{-l} or @tt{--list} option, git-cli returns structured branch
|
||||
information. Each item starts with one of @racket['current], @racket['local],
|
||||
or @racket['remote], followed by the branch name.
|
||||
|
||||
@racketblock[
|
||||
(git-branch '-l)
|
||||
|
||||
'((current "main")
|
||||
(local "develop"))
|
||||
]
|
||||
|
||||
Git's normal branch selection and sorting options are passed through. For
|
||||
example, remote branches can be requested with @tt{-r}, all branches with
|
||||
@tt{-a}, and Git's @tt{--sort=<key>} option controls the returned order.
|
||||
|
||||
@racketblock[
|
||||
(git 'branch '-l '-a "--sort=refname")
|
||||
|
||||
'((current "main")
|
||||
(local "develop")
|
||||
(remote "origin/main"))
|
||||
]
|
||||
|
||||
Without @tt{-l} or @tt{--list}, normal Git output is displayed and the
|
||||
procedure returns @racket[#t] when Git exits successfully.
|
||||
}
|
||||
@defproc[(git-remote [argument any/c] ...) any/c]{
|
||||
Runs @tt{git remote} with the supplied arguments and keeps the command's own
|
||||
subcommand structure.
|
||||
|
||||
With no arguments, the remote names are returned as a Racket list.
|
||||
|
||||
@racketblock[
|
||||
(git-remote)
|
||||
|
||||
'("origin" "upstream")
|
||||
]
|
||||
|
||||
With top-level @tt{-v} or @tt{--verbose}, each line reported by Git is returned
|
||||
as a separate structured item containing the remote name, URL, and the
|
||||
@racket['fetch] or @racket['push] role.
|
||||
|
||||
@racketblock[
|
||||
(git-remote '-v)
|
||||
|
||||
'(("origin" "https://example.invalid/project.git" fetch)
|
||||
("origin" "https://example.invalid/project.git" push))
|
||||
]
|
||||
|
||||
The two Git lines are deliberately not merged. This keeps the result close to
|
||||
the output and semantics of @tt{git remote -v}.
|
||||
|
||||
For @tt{get-url}, one URL is returned as a string. With @tt{--all}, a list of
|
||||
URLs is returned.
|
||||
|
||||
@racketblock[
|
||||
(git 'remote 'get-url "origin")
|
||||
(git 'remote 'get-url '--all "origin")
|
||||
(git 'remote 'get-url '--push '--all "origin")
|
||||
]
|
||||
|
||||
Other forms, including @tt{add}, @tt{rename}, @tt{remove}, @tt{set-head},
|
||||
@tt{show}, @tt{prune}, @tt{update}, @tt{set-branches}, and @tt{set-url}, are
|
||||
passed to Git unchanged and use the normal git-cli command result processing.
|
||||
}
|
||||
@defproc[(git-stash [argument any/c] ...) (or/c boolean? list?)]{
|
||||
Runs @tt{git stash} with the supplied arguments. Calling it without a
|
||||
subcommand keeps Git's normal behavior, which is equivalent to
|
||||
@tt{git stash push}.
|
||||
|
||||
@tt{git stash list} is returned as structured Racket data. Each item contains
|
||||
the stash reference and Git's stash description.
|
||||
|
||||
@racketblock[
|
||||
(git-stash 'list)
|
||||
|
||||
'(("stash@{0}" "WIP on main: 1234567 Example")
|
||||
("stash@{1}" "On main: older work"))
|
||||
]
|
||||
|
||||
The structured form is only used when the caller has not supplied a
|
||||
@tt{--format} or @tt{--pretty} option. Explicit Git formatting is left
|
||||
unchanged.
|
||||
|
||||
Other stash subcommands, including @tt{push}, @tt{show}, @tt{pop},
|
||||
@tt{apply}, @tt{drop}, @tt{clear}, @tt{branch}, @tt{create}, @tt{store},
|
||||
@tt{export}, and @tt{import}, are passed to Git unchanged.
|
||||
}
|
||||
|
||||
@defproc[(git-restore [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git restore} with the supplied arguments. Git's path, source,
|
||||
@tt{--staged}, @tt{--worktree}, and patch semantics are preserved.
|
||||
|
||||
@racketblock[
|
||||
(git-restore "main.rkt")
|
||||
(git-restore '--staged "main.rkt")
|
||||
(git* restore --source=HEAD~1 main.rkt)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-reset [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git reset} with the supplied arguments. Modes such as @tt{--soft},
|
||||
@tt{--mixed}, @tt{--hard}, @tt{--merge}, and @tt{--keep}, as well as path
|
||||
forms, are passed through unchanged.
|
||||
|
||||
@racketblock[
|
||||
(git-reset '--hard 'HEAD)
|
||||
(git* reset --soft HEAD~1)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-revert [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git revert} with the supplied arguments. Sequencer controls such as
|
||||
@tt{--continue}, @tt{--skip}, @tt{--quit}, and @tt{--abort} are passed through
|
||||
unchanged.
|
||||
|
||||
@racketblock[
|
||||
(git-revert 'HEAD)
|
||||
(git* revert --abort)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-rebase [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git rebase} with the supplied arguments, including normal, interactive,
|
||||
and continuation/abort forms.
|
||||
|
||||
@racketblock[
|
||||
(git-rebase "main")
|
||||
(git* rebase --continue)
|
||||
(git* rebase --abort)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-merge [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git merge} with the supplied arguments and preserves Git's merge
|
||||
options and control forms.
|
||||
|
||||
@racketblock[
|
||||
(git-merge "feature")
|
||||
(git* merge --abort)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-cherry-pick [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git cherry-pick} with the supplied arguments. Sequencer controls such
|
||||
as @tt{--continue}, @tt{--skip}, @tt{--quit}, and @tt{--abort} are passed
|
||||
through unchanged.
|
||||
|
||||
@racketblock[
|
||||
(git-cherry-pick "abc1234")
|
||||
(git* cherry-pick --continue)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-mergetool [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git mergetool}. When the caller does not specify @tt{-t},
|
||||
@tt{--tool=<tool>}, or @tt{--tool-help}, git-cli first tries
|
||||
@racket[find-mergetool] and supplies the selected tool through Git's normal
|
||||
@tt{--tool=<tool>} option. If no known graphical tool is found, Git is allowed
|
||||
to choose its own default.
|
||||
|
||||
@racketblock[
|
||||
(git-mergetool)
|
||||
(git* mergetool --tool=meld)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(find-editor) (or/c string? #f)]{
|
||||
Returns the configured or detected GUI editor command. When git-cli is
|
||||
loaded, the detected editor is assigned once to @tt{GIT_EDITOR} and
|
||||
@tt{GIT_SEQUENCE_EDITOR}. The editor is not started by this procedure.
|
||||
}
|
||||
|
||||
@defproc[(set-editor! [command string?]) any/c]{
|
||||
Stores a git-cli-specific editor command.
|
||||
}
|
||||
|
||||
@defproc[(find-mergetool) (or/c string? #f)]{
|
||||
Returns the configured or detected Git merge tool name.
|
||||
}
|
||||
|
||||
@defproc[(find-mergetool-path) (or/c path? #f)]{
|
||||
Returns the executable path of an automatically detected merge tool. The finder
|
||||
checks @tt{PATH} first and then well-known platform installation locations.
|
||||
When the merge tool was configured explicitly by name, this procedure returns
|
||||
@racket[#f].
|
||||
}
|
||||
|
||||
@defproc[(set-mergetool! [tool string?]) any/c]{
|
||||
Stores the Git merge tool name preferred by git-cli.
|
||||
}
|
||||
|
||||
@defproc[(git-switch [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git switch} with the supplied arguments.
|
||||
|
||||
@racketblock[
|
||||
(git-switch "main")
|
||||
(git-switch '-c "feature")
|
||||
(git 'switch "main")
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-clone [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git clone} with the supplied arguments.
|
||||
}
|
||||
|
||||
@defproc[(git-tag [argument any/c] ...) (or/c boolean? list?)]{
|
||||
Runs @tt{git tag} with the supplied arguments. It can list, create, delete, or
|
||||
verify tags according to the options supported by Git.
|
||||
|
||||
When @tt{-l} or @tt{--list} is supplied, the matching tag names are returned
|
||||
as a Racket list. Git's sorting options are passed through unchanged, so the
|
||||
returned list keeps Git's order.
|
||||
|
||||
@racketblock[
|
||||
(git-tag '-l)
|
||||
(git-tag '--list "--sort=version:refname")
|
||||
(git-tag '--list "--sort=-creatordate")
|
||||
]
|
||||
|
||||
When @tt{-n} or @tt{-n1} is combined with @tt{-l} or @tt{--list}, each result
|
||||
item contains the tag name and the subject reported by Git.
|
||||
|
||||
@racketblock[
|
||||
(git-tag '-l '-n)
|
||||
|
||||
'(("v0.3.16" "Release 0.3.16")
|
||||
("v0.3.17" "Release 0.3.17"))
|
||||
]
|
||||
|
||||
With @tt{-n<number>} and a number greater than one, git-cli asks Git for that
|
||||
many content lines using @tt{%(contents:lines=<number>)}. The returned message
|
||||
is kept as one string, including embedded newlines.
|
||||
|
||||
For structured tag output git-cli asks Git for an explicit format using
|
||||
@tt{%(refname:strip=2)} and either @tt{%(contents:subject)} or
|
||||
@tt{%(contents:lines=<number>)}. Generated field and record delimiters are used
|
||||
to split the result safely.
|
||||
|
||||
Other forms keep the normal command behavior and return @racket[#t] when Git
|
||||
exits successfully. Git errors are handled by the standard git-cli result
|
||||
processor.
|
||||
}
|
||||
@defproc[(git-rev-list [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git rev-list} with the supplied arguments and displays Git's normal
|
||||
output. It returns @racket[#t] when Git exits successfully.
|
||||
}
|
||||
|
||||
@defproc[(git-diff [argument any/c] ...) (or/c boolean? string?)]{
|
||||
Shows differences between Git objects or the working tree and index.
|
||||
|
||||
By default a successful diff is rendered as HTML in the default browser. The
|
||||
git-cli-specific option @tt{--output=-} keeps Git's textual output on standard
|
||||
output. @tt{--output=string} returns the textual diff as a string.
|
||||
|
||||
@racketblock[
|
||||
(git-diff)
|
||||
(git-diff '--cached)
|
||||
(git-diff '--output=-)
|
||||
(git-diff '--output=string)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-log [argument any/c] ...) (or/c boolean? list?)]{
|
||||
Displays Git log output and returns @racket[#t] when Git exits successfully.
|
||||
|
||||
The git-cli-specific option @tt{--list}, or its short form @tt{-l}, changes the
|
||||
result to a Racket list. Internally this option is replaced by Git's
|
||||
@tt{--oneline} option. Each returned item contains the abbreviated commit id and
|
||||
the commit subject.
|
||||
|
||||
@racketblock[
|
||||
(git-log '--list '-5)
|
||||
|
||||
'(("003f371" "Diverse commando's toegevoegd. Ik weet nog niet of ik ze allemaal ga houden")
|
||||
("2cb7e93" "Small changes. git main function is now a real function, not syntax"))
|
||||
]
|
||||
|
||||
Other Git log options are still passed to Git. Consequently, options that add
|
||||
extra output lines can also influence how useful @tt{--list} is as a structured
|
||||
result.
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(git-show [argument any/c] ...) (or/c boolean? string? list?)]{
|
||||
Shows a Git object.
|
||||
|
||||
For a commit that includes a patch, the default git-cli output is HTML. The
|
||||
commit information is shown above the diff and the diff is rendered using the
|
||||
same Diff2Html presentation as @racket[git-diff].
|
||||
|
||||
The git-cli-specific output options are @tt{--output=html},
|
||||
@tt{--output=-}, and @tt{--output=string}. @tt{--output=html} explicitly
|
||||
selects the HTML presentation, @tt{--output=-} keeps Git's normal textual
|
||||
output, and @tt{--output=string} returns that textual output as a string.
|
||||
Options such as @tt{--stat}, @tt{--name-only}, @tt{--name-status}, and
|
||||
@tt{--no-patch} default to textual output because they do not normally contain
|
||||
a patch.
|
||||
|
||||
The git-cli-specific option @tt{--list}, or its short form @tt{-l}, returns a
|
||||
Racket value. Without another show-format option it implies @tt{--stat}.
|
||||
|
||||
@racketblock[
|
||||
(git-show '-l "9741b1c")
|
||||
]
|
||||
|
||||
The result of @tt{--stat --list} contains @racket['file] and
|
||||
@racket['total] items:
|
||||
|
||||
@racketblock[
|
||||
'((file "README.md" 67 "+++---")
|
||||
(file "main.rkt" 532 "++++-------------------------------------------")
|
||||
(total 9 124 823))
|
||||
]
|
||||
|
||||
With @tt{--name-only --list}, the result is a list of file names. With
|
||||
@tt{--name-status --list}, every result item is the tab-separated Git
|
||||
name-status record converted to a list of strings.
|
||||
|
||||
@tt{--list}/@tt{-l} cannot be combined with @tt{--output=...}. Only one of
|
||||
@tt{--stat}, @tt{--name-only}, and @tt{--name-status} can be used with
|
||||
@tt{--list}.
|
||||
}
|
||||
|
||||
@defproc[(git-grep [argument any/c] ...) list?]{
|
||||
Searches tracked files. Each result contains the file, optional line number,
|
||||
optional match count, and matched text. Exit status one means that no matches
|
||||
were found and returns an empty list.
|
||||
}
|
||||
|
||||
@defproc[(git-help [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git help} with the supplied arguments and returns @racket[#t] when Git
|
||||
exits successfully.
|
||||
}
|
||||
|
||||
@section{Package version}
|
||||
|
||||
@defproc[(git-version) list?]{
|
||||
Reads the package version from @filepath{info.rkt} and returns it as a list
|
||||
containing major, minor, and patch.
|
||||
}
|
||||
|
||||
|
||||
@defproc[(git-new-version [kind symbol?]) list?]{
|
||||
Updates the version in @filepath{info.rkt}. The kind is @racket['major],
|
||||
@racket['minor], or @racket['patch], with @racket['maj] and @racket['min] as
|
||||
abbreviations. The result is the new version as a list of three integers.
|
||||
}
|
||||
|
||||
@racketblock[
|
||||
(git-new-version 'min)
|
||||
(git 'new-version 'min)
|
||||
(git* new-version min)
|
||||
]
|
||||
|
||||
The version kind may be supplied as a symbol or string. This makes the command
|
||||
compatible with @racket[git*], whose bare arguments are converted to text.
|
||||
|
||||
|
||||
|
||||
@section{Low-level Git execution}
|
||||
|
||||
@defproc[(run-git [args list?]
|
||||
[#:input input (or/c #f string?) #f])
|
||||
(values exact-integer? list?)]{
|
||||
Runs Git without interactive terminal prompts. When @racket[input] is a string,
|
||||
it is written to Git's standard input before that input port is closed.
|
||||
|
||||
The procedure returns two values: Git's exit code and the ordered output items,
|
||||
where each item identifies either @racket['stdout] or @racket['stderr].
|
||||
|
||||
@racketblock[
|
||||
(run-git '(credential fill)
|
||||
#:input "protocol=https\nhost=git.dijkewijk.nl\n\n")
|
||||
]
|
||||
}
|
||||
|
||||
@section{Authentication retry}
|
||||
|
||||
Git commands recognize common authentication failures immediately after the
|
||||
Git process finishes and before command-specific result processing takes
|
||||
place. Such a failure is represented by @racket[exn:fail:git-auth?].
|
||||
|
||||
@defparam[current-git-authentication-handler handler procedure?]{
|
||||
Controls the callback used when an authentication failure is detected. The
|
||||
callback receives the Git command symbol, the processed Git argument list and
|
||||
the @racket[exn:fail:git-auth] exception.
|
||||
|
||||
The callback returns a true value when it has handled authentication and the
|
||||
original Git command should be tried again. A command is retried at most once.
|
||||
The default callback is @racket[default-git-authentication-handler].
|
||||
|
||||
@racketblock[
|
||||
(current-git-authentication-handler
|
||||
(lambda (cmd args e)
|
||||
;; Perform credential handling here.
|
||||
#t))
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(exn:fail:git-auth? [v any/c]) boolean?]{
|
||||
Recognizes the authentication exception used internally by git-cli.
|
||||
}
|
||||
|
||||
@defproc[(exn:fail:git-auth-command [e exn:fail:git-auth?]) symbol?]{
|
||||
Returns the Git command of the failed invocation.
|
||||
}
|
||||
|
||||
@defproc[(exn:fail:git-auth-args [e exn:fail:git-auth?]) list?]{
|
||||
Returns the processed Git arguments of the failed invocation.
|
||||
}
|
||||
|
||||
@defproc[(exn:fail:git-auth-exit-code [e exn:fail:git-auth?]) exact-integer?]{
|
||||
Returns Git's exit code.
|
||||
}
|
||||
|
||||
@defproc[(exn:fail:git-auth-output [e exn:fail:git-auth?]) list?]{
|
||||
Returns the ordered @racket['stdout]/@racket['stderr] output items from the
|
||||
failed Git process.
|
||||
}
|
||||
|
||||
|
||||
|
||||
@section{Authentication}
|
||||
|
||||
@defproc[(default-git-authentication-handler
|
||||
[cmd symbol?]
|
||||
[args list?]
|
||||
[e exn:fail:git-auth?])
|
||||
boolean?]{
|
||||
Handles one authentication failure. A credential that already failed is first
|
||||
rejected. An existing Git credential helper is then asked for a replacement
|
||||
credential. If that does not succeed, git-cli requests a username and
|
||||
password/token using @racket[input-prompt]. Its @racket[#:loop-until] callbacks
|
||||
both validate the input and return the value that is used. If no helper is
|
||||
configured, Git's non-persistent @tt{cache} helper is configured locally before
|
||||
the credential is approved. The original command is retried once; a credential
|
||||
that fails on the retry is rejected before the Git error is raised.
|
||||
}
|
||||
|
||||
@defparam[current-git-authentication-handler handler procedure?]{
|
||||
Contains the authentication callback used after a recognized authentication
|
||||
failure. Its default value is @racket[default-git-authentication-handler].
|
||||
}
|
||||
@@ -1,271 +0,0 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require (for-label racket/base
|
||||
racket/contract
|
||||
"../main.rkt"))
|
||||
|
||||
@title[#:tag "top"]{git-cli}
|
||||
@author{Hans Dijkema}
|
||||
|
||||
@defmodule[git-cli]
|
||||
|
||||
The @racketmodname[git-cli] module provides a command-line-like Git interface
|
||||
implemented by invoking the @tt{git} executable. Commands do not allow Git to
|
||||
read credentials or other answers from the terminal.
|
||||
|
||||
@section{Command interface}
|
||||
|
||||
@defform[(git command argument ...)]{
|
||||
Runs a registered Git @racket[command]. The arguments are passed to the command.
|
||||
Registered command symbols are @racket['status], @racket['add],
|
||||
@racket['commit], @racket['push], @racket['pull], @racket['fetch],
|
||||
@racket['branch], @racket['switch], @racket['clone], @racket['tag],
|
||||
@racket['log], @racket['rev-list], @racket['diff],
|
||||
@racket['show], @racket['grep], @racket['help], @racket['version], and
|
||||
@racket['new-version].
|
||||
|
||||
Most registered commands invoke the Git command with the same name. Some
|
||||
commands process the result into a Racket value, such as @racket['status],
|
||||
@racket['grep], @racket['log] with @tt{--list}, @racket['version], and
|
||||
@racket['new-version].
|
||||
}
|
||||
|
||||
@section{Provided commands}
|
||||
|
||||
@defproc[(git-status [argument any/c] ...) list?]{
|
||||
Runs @tt{git status --porcelain} with the supplied arguments.
|
||||
|
||||
Each result item has the form
|
||||
@racket[(index-status worktree-status file)]. The index status describes the
|
||||
change staged for the next commit. The worktree status describes the change in
|
||||
the working tree relative to the index.
|
||||
|
||||
Both statuses are one of @racket['unchanged], @racket['modified],
|
||||
@racket['type-changed], @racket['added], @racket['deleted], @racket['renamed],
|
||||
@racket['copied], @racket['unmerged], @racket['untracked], or
|
||||
@racket['ignored]. For an untracked file, Git reports @tt{??}, so both statuses
|
||||
are @racket['untracked].
|
||||
|
||||
@racketblock[
|
||||
'((modified unchanged "staged.rkt")
|
||||
(unchanged modified "working-tree.rkt")
|
||||
(modified modified "both.rkt")
|
||||
(renamed unchanged "old.rkt -> new.rkt")
|
||||
(untracked untracked "new.rkt"))
|
||||
]}
|
||||
|
||||
@defproc[(git-add [argument any/c] ...) boolean?]{
|
||||
Adds file contents to the index. Returns @racket[#t] when Git exits with status
|
||||
zero; otherwise an exception is raised.
|
||||
}
|
||||
|
||||
@defproc[(git-commit [argument any/c] ...) boolean?]{
|
||||
Creates a commit. When @tt{-m} is omitted, a commit message is requested before
|
||||
Git is started. A repository with nothing to commit returns @racket[#t]. Other
|
||||
non-zero exit statuses, including a rejected commit hook, raise an exception.
|
||||
}
|
||||
|
||||
@defproc[(git-push [argument any/c] ...) boolean?]{
|
||||
Pushes changes using @tt{--porcelain}. Returns @racket[#t] when Git exits with
|
||||
status zero; otherwise an exception is raised.
|
||||
}
|
||||
|
||||
@defproc[(git-pull [argument any/c] ...) boolean?]{
|
||||
Fetches and integrates changes. Normal progress written by Git to standard
|
||||
error is accepted when Git exits successfully.
|
||||
}
|
||||
|
||||
@defproc[(git-fetch [argument any/c] ...) boolean?]{
|
||||
Downloads refs and objects from a remote repository without integrating them
|
||||
into the current branch. Arguments are passed directly to @tt{git fetch}.
|
||||
|
||||
For example:
|
||||
|
||||
@racketblock[
|
||||
(git-fetch)
|
||||
(git-fetch '--prune)
|
||||
(git 'fetch '--prune)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-branch [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git branch} with the supplied arguments. This can be used to list,
|
||||
create, rename, or delete branches according to the options supported by the
|
||||
installed Git executable.
|
||||
}
|
||||
|
||||
@defproc[(git-switch [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git switch} with the supplied arguments.
|
||||
|
||||
@racketblock[
|
||||
(git-switch "main")
|
||||
(git-switch '-c "feature")
|
||||
(git 'switch "main")
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-clone [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git clone} with the supplied arguments.
|
||||
}
|
||||
|
||||
@defproc[(git-tag [argument any/c] ...) (or/c boolean? list?)]{
|
||||
Runs @tt{git tag} with the supplied arguments. It can list, create, delete, or
|
||||
verify tags according to the options supported by Git.
|
||||
|
||||
When @tt{-l} or @tt{--list} is supplied, the matching tag names are returned
|
||||
as a Racket list. Git's sorting options are passed through unchanged, so the
|
||||
returned list keeps Git's order.
|
||||
|
||||
@racketblock[
|
||||
(git-tag '-l)
|
||||
(git-tag '--list "--sort=version:refname")
|
||||
(git-tag '--list "--sort=-creatordate")
|
||||
]
|
||||
|
||||
When @tt{-n} or @tt{-n1} is combined with @tt{-l} or @tt{--list}, each result
|
||||
item contains the tag name and the subject reported by Git.
|
||||
|
||||
@racketblock[
|
||||
(git-tag '-l '-n)
|
||||
|
||||
'(("v0.3.16" "Release 0.3.16")
|
||||
("v0.3.17" "Release 0.3.17"))
|
||||
]
|
||||
|
||||
With @tt{-n<number>} and a number greater than one, git-cli asks Git for that
|
||||
many content lines using @tt{%(contents:lines=<number>)}. The returned message
|
||||
is kept as one string, including embedded newlines.
|
||||
|
||||
For structured tag output git-cli asks Git for an explicit format using
|
||||
@tt{%(refname:strip=2)} and either @tt{%(contents:subject)} or
|
||||
@tt{%(contents:lines=<number>)}. Generated field and record delimiters are used
|
||||
to split the result safely.
|
||||
|
||||
Other forms keep the normal command behavior and return @racket[#t] when Git
|
||||
exits successfully. Git errors are handled by the standard git-cli result
|
||||
processor.
|
||||
}
|
||||
@defproc[(git-rev-list [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git rev-list} with the supplied arguments and displays Git's normal
|
||||
output. It returns @racket[#t] when Git exits successfully.
|
||||
}
|
||||
|
||||
@defproc[(git-diff [argument any/c] ...) (or/c boolean? string?)]{
|
||||
Shows differences between Git objects or the working tree and index.
|
||||
|
||||
By default a successful diff is rendered as HTML in the default browser. The
|
||||
git-cli-specific option @tt{--output=-} keeps Git's textual output on standard
|
||||
output. @tt{--output=string} returns the textual diff as a string.
|
||||
|
||||
@racketblock[
|
||||
(git-diff)
|
||||
(git-diff '--cached)
|
||||
(git-diff '--output=-)
|
||||
(git-diff '--output=string)
|
||||
]
|
||||
}
|
||||
|
||||
@defproc[(git-log [argument any/c] ...) (or/c boolean? list?)]{
|
||||
Displays Git log output and returns @racket[#t] when Git exits successfully.
|
||||
|
||||
The git-cli-specific option @tt{--list}, or its short form @tt{-l}, changes the
|
||||
result to a Racket list. Internally this option is replaced by Git's
|
||||
@tt{--oneline} option. Each returned item contains the abbreviated commit id and
|
||||
the commit subject.
|
||||
|
||||
@racketblock[
|
||||
(git-log '--list '-5)
|
||||
|
||||
'(("003f371" "Diverse commando's toegevoegd. Ik weet nog niet of ik ze allemaal ga houden")
|
||||
("2cb7e93" "Small changes. git main function is now a real function, not syntax"))
|
||||
]
|
||||
|
||||
Other Git log options are still passed to Git. Consequently, options that add
|
||||
extra output lines can also influence how useful @tt{--list} is as a structured
|
||||
result.
|
||||
}
|
||||
|
||||
|
||||
|
||||
@defproc[(git-show [argument any/c] ...) (or/c boolean? string? list?)]{
|
||||
Shows a Git object.
|
||||
|
||||
For a commit that includes a patch, the default git-cli output is HTML. The
|
||||
commit information is shown above the diff and the diff is rendered using the
|
||||
same Diff2Html presentation as @racket[git-diff].
|
||||
|
||||
The git-cli-specific output options are @tt{--output=html},
|
||||
@tt{--output=-}, and @tt{--output=string}. @tt{--output=html} explicitly
|
||||
selects the HTML presentation, @tt{--output=-} keeps Git's normal textual
|
||||
output, and @tt{--output=string} returns that textual output as a string.
|
||||
Options such as @tt{--stat}, @tt{--name-only}, @tt{--name-status}, and
|
||||
@tt{--no-patch} default to textual output because they do not normally contain
|
||||
a patch.
|
||||
|
||||
The git-cli-specific option @tt{--list}, or its short form @tt{-l}, returns a
|
||||
Racket value. Without another show-format option it implies @tt{--stat}.
|
||||
|
||||
@racketblock[
|
||||
(git-show '-l "9741b1c")
|
||||
]
|
||||
|
||||
The result of @tt{--stat --list} contains @racket['file] and
|
||||
@racket['total] items:
|
||||
|
||||
@racketblock[
|
||||
'((file "README.md" 67 "+++---")
|
||||
(file "main.rkt" 532 "++++-------------------------------------------")
|
||||
(total 9 124 823))
|
||||
]
|
||||
|
||||
With @tt{--name-only --list}, the result is a list of file names. With
|
||||
@tt{--name-status --list}, every result item is the tab-separated Git
|
||||
name-status record converted to a list of strings.
|
||||
|
||||
@tt{--list}/@tt{-l} cannot be combined with @tt{--output=...}. Only one of
|
||||
@tt{--stat}, @tt{--name-only}, and @tt{--name-status} can be used with
|
||||
@tt{--list}.
|
||||
}
|
||||
|
||||
@defproc[(git-grep [argument any/c] ...) list?]{
|
||||
Searches tracked files. Each result contains the file, optional line number,
|
||||
optional match count, and matched text. Exit status one means that no matches
|
||||
were found and returns an empty list.
|
||||
}
|
||||
|
||||
@defproc[(git-help [argument any/c] ...) boolean?]{
|
||||
Runs @tt{git help} with the supplied arguments and returns @racket[#t] when Git
|
||||
exits successfully.
|
||||
}
|
||||
|
||||
@section{Package version}
|
||||
|
||||
@defproc[(git-version) list?]{
|
||||
Reads the package version from @filepath{info.rkt} and returns it as a list
|
||||
containing major, minor, and patch.
|
||||
}
|
||||
|
||||
|
||||
@defproc[(git-new-version [kind symbol?]) list?]{
|
||||
Updates the version in @filepath{info.rkt}. The kind is @racket['major],
|
||||
@racket['minor], or @racket['patch], with @racket['maj] and @racket['min] as
|
||||
abbreviations. The result is the new version as a list of three integers.
|
||||
}
|
||||
|
||||
|
||||
@section{Low-level Git execution}
|
||||
|
||||
@defproc[(run-git [args list?]
|
||||
[#:input input (or/c #f string?) #f])
|
||||
(values exact-integer? list?)]{
|
||||
Runs Git without interactive terminal prompts. When @racket[input] is a string,
|
||||
it is written to Git's standard input before that input port is closed.
|
||||
|
||||
The procedure returns two values: Git's exit code and the ordered output items,
|
||||
where each item identifies either @racket['stdout] or @racket['stderr].
|
||||
|
||||
@racketblock[
|
||||
(run-git '(credential fill)
|
||||
#:input "protocol=https\nhost=git.dijkewijk.nl\n\n")
|
||||
]
|
||||
}
|
||||
Reference in New Issue
Block a user