878 lines
36 KiB
Racket
878 lines
36 KiB
Racket
#lang racket/base
|
|
|
|
(require "private/git-provider.rkt"
|
|
"private/git-commands.rkt"
|
|
"private/config.rkt"
|
|
"private/diff.rkt"
|
|
"private/info-handler.rkt"
|
|
"private/utils.rkt"
|
|
simple-log
|
|
racket/string
|
|
net/sendurl
|
|
)
|
|
|
|
(provide gt
|
|
git
|
|
git-add
|
|
git-status
|
|
git-commit
|
|
git-pull
|
|
git-push
|
|
git-fetch
|
|
git-switch
|
|
git-tag
|
|
git-config
|
|
git-log
|
|
git-grep
|
|
git-branch
|
|
git-remote
|
|
git-clone
|
|
git-rev-list
|
|
git-diff
|
|
git-show
|
|
git-help
|
|
git-version
|
|
git-new-version
|
|
git-next-version
|
|
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")
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Internal variables
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define git-commands (make-hash))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Command invocation using 'git'
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax gt
|
|
(syntax-rules ()
|
|
((_ cmd a1 ...)
|
|
(git 'cmd 'a1 ...))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (git command . args)
|
|
((hash-ref git-commands command
|
|
(λ ()
|
|
(error "Not a supported or recognized git command: " command)))
|
|
args))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Read one line of input after displaying a prompt.
|
|
; pre : p can be displayed.
|
|
; post : The prompt has been flushed before input is read.
|
|
; result : The entered line or an EOF object.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-prompt p)
|
|
(input-prompt p))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Add --porcelain to a Git argument list when it is absent.
|
|
; pre : args is a list and an optional transformation accepts a list.
|
|
; post : Existing porcelain options have not been duplicated.
|
|
; result : The transformed Git argument list.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (add-porcelain args info . f)
|
|
(let ((m (has-git-arg? args #px"^[-][-]porcelain([=](.*))?"))
|
|
(g (if (null? f) (λ (x) x) (car f)))
|
|
)
|
|
(if m
|
|
(g args)
|
|
(g (cons '--porcelain args)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Convert one porcelain status character to a semantic symbol.
|
|
; pre : status is one Git porcelain v1 status character.
|
|
; post : Unknown status characters have raised an exception.
|
|
; result : The corresponding semantic status symbol.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (status->symbol status)
|
|
(cond
|
|
((string=? status " ") 'unchanged)
|
|
((string=? status "M") 'modified)
|
|
((string=? status "T") 'type-changed)
|
|
((string=? status "A") 'added)
|
|
((string=? status "D") 'deleted)
|
|
((string=? status "R") 'renamed)
|
|
((string=? status "C") 'copied)
|
|
((string=? status "U") 'unmerged)
|
|
((string=? status "?") 'untracked)
|
|
((string=? status "!") 'ignored)
|
|
(else (error 'git-status "Unexpected status: ~a" status))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Recognize Git output that reports there is nothing to commit.
|
|
; pre : out is a list of Git output lines.
|
|
; post : out has only been inspected.
|
|
; result : #t when a known nothing-to-commit message occurs, otherwise #f.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (nothing-to-commit? out)
|
|
(ormap (λ (line)
|
|
(let ((line* (string-downcase line)))
|
|
(or (string-contains? line* "nothing to commit")
|
|
(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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-config-args args info)
|
|
(define (scope? x)
|
|
(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)
|
|
(eq? (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
|
|
((eq? 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"))
|
|
|
|
((eq? (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"))))))
|
|
|
|
((eq? 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
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Define and register a public Git command procedure.
|
|
; pre : pre-code and process-result follow the command proxy interfaces.
|
|
; post : cmd-sym is registered in the generic git command table.
|
|
; result : Definitions for the public and internal command procedures.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define-syntax def-cmd
|
|
(syntax-rules ()
|
|
((_ cmd cmd* cmd-sym)
|
|
(def-cmd cmd cmd* cmd-sym (λ (args info) args) std-process-git-result))
|
|
((_ cmd cmd* cmd-sym pre-code)
|
|
(def-cmd cmd cmd* cmd-sym pre-code std-process-git-result))
|
|
((_ cmd cmd* cmd-sym pre-code process-result)
|
|
(begin
|
|
(def-git-cmd-proxy cmd* cmd-sym
|
|
pre-code
|
|
process-result)
|
|
(define (cmd . args) (cmd* args))
|
|
(hash-set! git-commands cmd-sym cmd*)))
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Typical git commands
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Return the complete Git index and worktree status for every reported file.
|
|
; pre : The current directory is inside a Git working tree.
|
|
; post : Git status has been invoked with --porcelain.
|
|
; result : A list containing (index-status worktree-status file) for every file.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-status cmd-git-status 'status
|
|
add-porcelain
|
|
(λ (cmd exit-code result output out info)
|
|
(dbg-git (format "~a" output))
|
|
(if (= exit-code 0)
|
|
(map (λ (line)
|
|
(if (< (string-length line) 3)
|
|
(git-error 'status "Unexpected output" line)
|
|
(list (status->symbol (substring line 0 1))
|
|
(status->symbol (substring line 1 2))
|
|
(substring line 3))))
|
|
(map cadr
|
|
(filter (λ (entry) (eq? (car entry) 'stdout)) output)))
|
|
(git-error 'status "Exitcode <> 0" (cons (format "~a\n" exit-code) output))
|
|
))
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Add file contents to the Git index.
|
|
; pre : The supplied arguments are valid for git add.
|
|
; post : Git add has completed successfully or an exception has been raised.
|
|
; result : #t after a successful Git command.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-add cmd-git-add 'add)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create a Git commit.
|
|
; pre : A commit message is supplied or can be requested from the user.
|
|
; post : The commit was created, nothing needed committing, or an exception was raised.
|
|
; result : #t after a commit or when the repository has nothing to commit.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-commit cmd-git-commit 'commit
|
|
(λ (args info)
|
|
(with-handlers ([exn:fail? (λ (e)
|
|
(let ((msg (string-trim (git-prompt "Commit message:\n>"))))
|
|
(if (string=? msg "")
|
|
(raise "A commit message is mandatory")
|
|
(cons '-m (cons msg args)))))])
|
|
(check-git-args 'commit args '((-m 1 "A commit message is mandatory")))))
|
|
(λ (cmd exit-code result output out info)
|
|
(cond
|
|
((and (= exit-code 1)
|
|
(nothing-to-commit? out))
|
|
(git-displ out)
|
|
#t)
|
|
(else
|
|
(std-process-git-result cmd exit-code result output out info))))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Push local changes to a remote repository.
|
|
; pre : The supplied arguments are valid for git push.
|
|
; post : Git push has completed successfully or an exception has been raised.
|
|
; result : #t after a successful push.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-push cmd-git-push 'push add-porcelain)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Fetch and integrate changes from a remote repository.
|
|
; pre : The supplied arguments are valid for git pull.
|
|
; post : Git pull has completed successfully or an exception has been raised.
|
|
; result : #t after a successful pull.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-pull cmd-git-pull 'pull)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Download refs and objects from a remote repository.
|
|
; pre : The supplied arguments are valid for git fetch.
|
|
; post : Git fetch has completed successfully or an exception has been raised.
|
|
; result : #t after a successful fetch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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-cmd git-config cmd-git-config 'config
|
|
git-config-args
|
|
process-git-config-result)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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 : A structured branch list with --list/-l, otherwise #t.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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)
|
|
(member (car args) '(-v --verbose)))
|
|
(hash-set! info 'remote-operation 'verbose-list)
|
|
args)
|
|
|
|
((eq? (car args) 'get-url)
|
|
(hash-set! info 'remote-operation
|
|
(if (member '--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 : Switch branches.
|
|
; pre : The supplied arguments are valid for git switch.
|
|
; post : Git switch has completed successfully or an exception has been raised.
|
|
; result : #t after a successful switch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-switch cmd-git-switch 'switch)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Clone a repository into a new directory.
|
|
; pre : The supplied arguments are valid for git clone.
|
|
; post : The clone exists or an exception was raised.
|
|
; result : #t after a successful clone.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-clone cmd-git-clone 'clone)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : List, create, delete or verify tags.
|
|
; pre : The supplied arguments are valid for git tag.
|
|
; post : Git tag has completed successfully or an exception has been raised.
|
|
; result : A list of tag names with --list/-l, a list of (tag annotation)
|
|
; items when -n is combined with --list/-l, otherwise #t.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-tag cmd-git-tag 'tag
|
|
(λ (args info)
|
|
(let* ((split-id (format "git-cli-tag-split-~a-~a"
|
|
(random 1000000000)
|
|
(random 1000000000)))
|
|
(record-id (format "git-cli-tag-record-~a-~a"
|
|
(random 1000000000)
|
|
(random 1000000000)))
|
|
(scheme-format #f)
|
|
(tag-lines #f))
|
|
(for-each
|
|
(λ (e)
|
|
(let* ((o (format "~a" e))
|
|
(m (regexp-match #px"^[-]n([0-9]+)?$" o)))
|
|
(when (or (string=? o "--list")
|
|
(string=? o "-l"))
|
|
(set! scheme-format #t))
|
|
(when m
|
|
(set! tag-lines
|
|
(if (cadr m)
|
|
(string->number (cadr m))
|
|
1)))))
|
|
args)
|
|
|
|
(hash-set! info 'scheme-format scheme-format)
|
|
(hash-set! info 'tag-lines tag-lines)
|
|
(hash-set! info 'tag-split-id split-id)
|
|
(hash-set! info 'tag-record-id record-id)
|
|
|
|
(map
|
|
(λ (e)
|
|
(let* ((o (format "~a" e))
|
|
(m (regexp-match #px"^[-]n([0-9]+)?$" o)))
|
|
(if (and scheme-format m)
|
|
(format "--format=%(refname:strip=2)~a~a~a"
|
|
split-id
|
|
(if (> tag-lines 1)
|
|
(format "%(contents:lines=~a)" tag-lines)
|
|
"%(contents:subject)")
|
|
record-id)
|
|
e)))
|
|
args)))
|
|
|
|
(λ (cmd exit-code result output out info)
|
|
(if (hash-ref info 'scheme-format #f)
|
|
(if (and (= exit-code 0) result)
|
|
(let ((tag-lines (hash-ref info 'tag-lines #f)))
|
|
(if tag-lines
|
|
(let* ((split-id (hash-ref info 'tag-split-id))
|
|
(record-id (hash-ref info 'tag-record-id))
|
|
(text (string-join out "\n"))
|
|
(records (string-split text record-id #:trim? #f)))
|
|
(map
|
|
(λ (record)
|
|
(string-split (string-trim record) split-id #:trim? #f))
|
|
(filter (λ (record)
|
|
(not (string=? (string-trim record) "")))
|
|
records)))
|
|
out))
|
|
(std-process-git-result cmd exit-code result output out info))
|
|
(std-process-git-result cmd exit-code result output out info)))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Display the Git commit log or return it as a Racket list.
|
|
; pre : The supplied arguments are valid for git log; --list and -l are git-cli options.
|
|
; post : Git log has completed successfully or an exception has been raised.
|
|
; result : A list of (commit subject) items with --list/-l, otherwise #t.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-log cmd-git-log 'log
|
|
(λ (args info)
|
|
(map (λ (e)
|
|
(let ((o (format "~a" e)))
|
|
(cond
|
|
((or
|
|
(string=? o "--list")
|
|
(string=? o "-l"))
|
|
(begin
|
|
(hash-set! info 'scheme-format #t)
|
|
"--oneline"))
|
|
(else e))))
|
|
args))
|
|
(λ (cmd exit-code result output out info)
|
|
(if (hash-ref info 'scheme-format #f)
|
|
(if (and (= exit-code 0) result)
|
|
(let ((re #px"([0-9a-f]+)\\s+(.*)"))
|
|
(map (λ (line)
|
|
(let ((m (regexp-match re line)))
|
|
(if m
|
|
(list (cadr m) (caddr m))
|
|
(list #f line))))
|
|
out))
|
|
#f)
|
|
(std-process-git-result cmd exit-code result output out info)))
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : List commit objects reachable from supplied revisions.
|
|
; pre : The supplied arguments are valid for git rev-list.
|
|
; post : Git rev-list has completed successfully or an exception was raised.
|
|
; result : #t after successfully displaying the result.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-rev-list cmd-git-rev-list 'rev-list)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Render a Git diff in the default browser.
|
|
; pre : The supplied arguments are valid for git diff or
|
|
; are special cases like --output=-, --output=string.
|
|
; post : A successful diff has been rendered as HTML or
|
|
; to stdout/string.
|
|
; result : #t or a string when a diff was rendered, otherwise #f.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-diff cmd-git-diff 'diff
|
|
(λ (args info)
|
|
(hash-set! info 'file-output (has-git-arg? args #px"^[-][-]output[=]"))
|
|
(hash-set! info 'stdout (has-git-arg? args #px"^[-][-]output[=][-]"))
|
|
(hash-set! info 'string (has-git-arg? args #px"^[-][-]output[=]string"))
|
|
(if (or (hash-ref info 'stdout #f) (hash-ref info 'string #f))
|
|
(filter (λ (e) (not (has-git-arg? (list e) #px"^[-][-]output[=]([-]|string)"))) args)
|
|
args))
|
|
(λ (cmd exit-code result output out info)
|
|
(if (and (zero? exit-code)
|
|
result)
|
|
(if (eq? (hash-ref info 'file-output #f) #f)
|
|
(let ((diff (string-join
|
|
(filter (λ (line)
|
|
(not (string-prefix? (string-downcase line) "warning:")))
|
|
out)
|
|
"\n")))
|
|
(diff->html diff)
|
|
#t)
|
|
(if (hash-ref info 'string #f)
|
|
(string-join out "\n")
|
|
(std-process-git-result cmd exit-code result output out info)))
|
|
(std-process-git-result cmd exit-code result output out info))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Show a Git object, render a commit diff as HTML or return structured output.
|
|
; pre : The supplied arguments are valid for git show; --list/-l and
|
|
; --output=html/--output=-/--output=string are git-cli options.
|
|
; post : Git show has completed successfully or an exception has been raised.
|
|
; result : Structured Racket data with --list/-l, a string with --output=string,
|
|
; otherwise #t.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-show cmd-git-show 'show
|
|
(λ (args info)
|
|
(let* ((list-output (ormap (λ (e) (member (format "~a" e) '("--list" "-l"))) args))
|
|
(output-html (has-git-arg? args #px"^[-][-]output[=]html$"))
|
|
(output-stdout (has-git-arg? args #px"^[-][-]output[=][-]$"))
|
|
(output-string (has-git-arg? args #px"^[-][-]output[=]string$"))
|
|
(name-only (has-git-arg? args #px"^[-][-]name-only$"))
|
|
(name-status (has-git-arg? args #px"^[-][-]name-status$"))
|
|
(stat (has-git-arg? args #px"^[-][-]stat([=](.*))?$"))
|
|
(no-patch (or (has-git-arg? args #px"^[-][-]no-patch$")
|
|
(has-git-arg? args "-s")))
|
|
(list-formats (filter (λ (x) x)
|
|
(list (if name-only 'name-only #f)
|
|
(if name-status 'name-status #f)
|
|
(if stat 'stat #f)))))
|
|
|
|
(when (and list-output (or output-html output-stdout output-string))
|
|
(error 'git-show "--list/-l cannot be combined with --output=..."))
|
|
(when (and list-output (> (length list-formats) 1))
|
|
(error 'git-show "--list/-l accepts only one of --stat, --name-only or --name-status"))
|
|
|
|
(hash-set! info 'scheme-format list-output)
|
|
(hash-set! info 'show-list-format (if (null? list-formats) 'stat (car list-formats)))
|
|
(hash-set! info 'show-output
|
|
(cond (output-html 'html)
|
|
(output-stdout 'stdout)
|
|
(output-string 'string)
|
|
((or stat name-only name-status no-patch) 'stdout)
|
|
(else 'html)))
|
|
|
|
(let ((nargs (filter (λ (e)
|
|
(not (member (format "~a" e)
|
|
'("--list" "-l"
|
|
"--output=html" "--output=-" "--output=string"))))
|
|
args)))
|
|
(if (and list-output (null? list-formats))
|
|
(cons '--stat nargs)
|
|
nargs))))
|
|
|
|
(λ (cmd exit-code result output out info)
|
|
(if (and (zero? exit-code) result)
|
|
(cond
|
|
((hash-ref info 'scheme-format #f)
|
|
(let ((lines (filter (λ (line) (not (string=? (string-trim line) ""))) out)))
|
|
(case (hash-ref info 'show-list-format 'stat)
|
|
((name-only) lines)
|
|
((name-status) (map (λ (line) (string-split line "\t")) lines))
|
|
((stat)
|
|
(let ((file-re #px"^\\s*(.*?)\\s+[|]\\s+([0-9]+)\\s+([+\\-]+)$")
|
|
(total-re #px"^([0-9]+) files? changed(, ([0-9]+) insertions?\\(\\+\\))?(, ([0-9]+) deletions?\\(-\\))?$"))
|
|
(map (λ (line)
|
|
(let* ((trimmed (string-trim line))
|
|
(fm (regexp-match file-re line))
|
|
(tm (regexp-match total-re trimmed)))
|
|
(cond
|
|
(fm (list 'file (cadr fm) (string->number (caddr fm)) (cadddr fm)))
|
|
(tm (list 'total
|
|
(string->number (cadr tm))
|
|
(if (cadddr tm) (string->number (cadddr tm)) 0)
|
|
(if (list-ref tm 5) (string->number (list-ref tm 5)) 0)))
|
|
(else (list 'info line)))))
|
|
lines))))))
|
|
((eq? (hash-ref info 'show-output 'html) 'string)
|
|
(string-join out "\n"))
|
|
((eq? (hash-ref info 'show-output 'html) 'html)
|
|
(show->html
|
|
(string-join
|
|
(filter (λ (line) (not (string-prefix? (string-downcase line) "warning:"))) out)
|
|
"\n"))
|
|
#t)
|
|
(else (std-process-git-result cmd exit-code result output out info)))
|
|
(std-process-git-result cmd exit-code result output out info))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Search tracked files for a pattern.
|
|
; pre : The supplied arguments are valid for git grep.
|
|
; post : Git grep has completed; exit code one is treated as no matches.
|
|
; result : A list containing file, line number, match count and matched text.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-grep cmd-git-grep 'grep
|
|
(λ (args info)
|
|
(let ((matches #f)
|
|
(line-nr #f)
|
|
)
|
|
|
|
(let ((nargs (map
|
|
(λ (e)
|
|
(let ((o (format "~a" e)))
|
|
(cond
|
|
((string=? o "-c") (set! matches #t))
|
|
((string=? o "-n") (set! line-nr #t))))
|
|
e)
|
|
(map (λ (x) (if (eq? 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)
|
|
(hash-set! info 'line-nr (if matches #f line-nr))
|
|
nargs)))
|
|
(λ (cmd exit-code result output out info)
|
|
(with-handlers ([exn:fail? (λ (e)
|
|
(err-git (string-join (map cadr output) "\n"))
|
|
(raise e))])
|
|
(if (and result
|
|
(or (= exit-code 0) (= exit-code 1)))
|
|
(let ((re #px"([^:]+)[:]([^:]+)([:](.*))?"))
|
|
(map (λ (line)
|
|
(let ((m (regexp-match re line)))
|
|
(let ((line-nr (if (hash-ref info 'line-nr #f)
|
|
(if (eq? m #f)
|
|
#f
|
|
(string->number (caddr m)))
|
|
#f))
|
|
(matches (if (hash-ref info 'matches #f)
|
|
(if (eq? m #f)
|
|
#f
|
|
(string->number (caddr m)))
|
|
#f))
|
|
)
|
|
(if m
|
|
(list (cadr m) line-nr matches (cadddr (cdr m)))
|
|
(list line #f #f #f)))))
|
|
out))
|
|
(begin
|
|
(err-git (string-join (map cadr output) "\n"))
|
|
#f))))
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Display help for Git or a Git command.
|
|
; pre : The supplied arguments are valid for git help.
|
|
; post : Git help has completed successfully or an exception was raised.
|
|
; result : #t after successfully displaying help.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-help cmd-git-help 'help)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Racket module versioning
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Return the package version from info.rkt.
|
|
; pre : No arguments are required.
|
|
; post : info.rkt has only been inspected.
|
|
; result : A list containing major, minor and patch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-version . args)
|
|
(cmd-git-version args))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Implement the registered version command.
|
|
; pre : args is the command argument list.
|
|
; post : info.rkt has only been inspected.
|
|
; result : A list containing major, minor and patch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (cmd-git-version args)
|
|
(info-version "."))
|
|
|
|
(hash-set! git-commands 'version cmd-git-version)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Increment the package version in info.rkt.
|
|
; pre : kind is 'maj, 'major, 'min, 'minor or 'patch.
|
|
; post : The version definition in info.rkt has been updated.
|
|
; result : The new version as a list containing major, minor and patch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-new-version . args)
|
|
(cmd-git-new-version args))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Implement the registered new-version command.
|
|
; pre : args contains a supported version kind.
|
|
; 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)
|
|
(error "git-new-version expects 'maj, 'major, 'min, 'minor or 'patch"))
|
|
(let ((kind (car args)))
|
|
(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)
|
|
|
|
|
|
|
|
|
|
|