650 lines
21 KiB
Racket
650 lines
21 KiB
Racket
#lang racket/base
|
|
|
|
(require ffi/unsafe
|
|
racket/list
|
|
racket/match
|
|
racket/path
|
|
racket/string
|
|
"credentials.rkt"
|
|
(except-in libgit2 git_remote_push)
|
|
(only-in libgit2/private/base
|
|
define-libgit2
|
|
_git_error_code/check))
|
|
|
|
(provide git
|
|
dgit
|
|
git-repository?
|
|
git-root
|
|
git-init
|
|
git-clone
|
|
(struct-out git-status-entry)
|
|
git-status
|
|
git-status-lines
|
|
git-clean?
|
|
git-add
|
|
git-config
|
|
git-config-get
|
|
git-config-set
|
|
git-commit
|
|
git-head
|
|
git-current-branch
|
|
git-branches
|
|
git-branch
|
|
git-branch-delete
|
|
git-checkout
|
|
git-checkout-new
|
|
git-tags
|
|
git-tag
|
|
git-tag-delete
|
|
(struct-out git-log-entry)
|
|
git-log
|
|
git-log-lines
|
|
git-remotes
|
|
git-remote-add
|
|
git-remote-url
|
|
git-fetch
|
|
git-pull
|
|
git-push
|
|
git-push-tag
|
|
git-credentials-init!
|
|
git-credentials-unlock!
|
|
git-credentials-lock!
|
|
git-credentials-unlocked?
|
|
git-credentials-unlock-expires
|
|
git-credentials-set!
|
|
git-credentials-ref
|
|
git-credentials-remove!)
|
|
|
|
(struct git-status-entry (path code flags) #:transparent)
|
|
(struct git-log-entry (id summary time) #:transparent)
|
|
|
|
;; The current Racket libgit2 package has an incorrect Scheme -> C
|
|
;; conversion for git_strarray pointers. Keep this tiny corrected binding
|
|
;; local to this module for push refspecs.
|
|
(define-cstruct _git_strarray/raw
|
|
([strings _pointer]
|
|
[count _size]))
|
|
|
|
(define-libgit2 git_remote_push/raw
|
|
(_fun _git_remote
|
|
_git_strarray/raw-pointer
|
|
_git_push_opts-pointer
|
|
-> (_git_error_code/check))
|
|
#:c-id git_remote_push)
|
|
|
|
(define zero-oid-string (make-string GIT_OID_HEXSZ #\0))
|
|
(define branch-prefix "refs/heads/")
|
|
(define tag-prefix "refs/tags/")
|
|
|
|
(define GIT-CREDTYPE-USERPASS-PLAINTEXT #x0001)
|
|
(define GIT-CREDTYPE-USERNAME #x0020)
|
|
(define GIT-PASSTHROUGH -30)
|
|
|
|
(define (git-credential-callback out url username-from-url allowed-types _payload)
|
|
(define saved (git-credentials-ref url))
|
|
(cond
|
|
[(not saved) GIT-PASSTHROUGH]
|
|
[else
|
|
(define username
|
|
(if (and username-from-url (not (string=? username-from-url "")))
|
|
username-from-url
|
|
(car saved)))
|
|
(define token (cdr saved))
|
|
(cond
|
|
[(not (zero? (bitwise-and allowed-types GIT-CREDTYPE-USERPASS-PLAINTEXT)))
|
|
(ptr-set! out _git_credential
|
|
(git_credential_userpass_plaintext_new username token))
|
|
0]
|
|
[(not (zero? (bitwise-and allowed-types GIT-CREDTYPE-USERNAME)))
|
|
(ptr-set! out _git_credential
|
|
(git_credential_username_new username))
|
|
0]
|
|
[else GIT-PASSTHROUGH])]))
|
|
|
|
(define (set-credential-callback! callbacks)
|
|
(set-git_remote_callbacks-credentials! callbacks git-credential-callback)
|
|
callbacks)
|
|
|
|
(define (make-fetch-options)
|
|
(define options
|
|
(cast (malloc _git_fetch_opts 'atomic) _pointer _git_fetch_opts-pointer))
|
|
(git_fetch_options_init options GIT_FETCH_OPTS_VERSION)
|
|
(set-credential-callback! (git_fetch_opts-callbacks options))
|
|
options)
|
|
|
|
(define (make-push-options)
|
|
(define options
|
|
(cast (malloc _git_push_opts 'atomic) _pointer _git_push_opts-pointer))
|
|
(git_push_options_init options GIT_PUSH_OPTS_VERSION)
|
|
(set-credential-callback! (git_push_opts-callbacks options))
|
|
options)
|
|
|
|
(define (make-clone-options)
|
|
(define options
|
|
(cast (malloc _git_clone_opts 'atomic) _pointer _git_clone_opts-pointer))
|
|
(git_clone_options_init options GIT_CLONE_OPTS_VERSION)
|
|
(set-credential-callback!
|
|
(git_fetch_opts-callbacks (git_clone_opts-fetch_opts options)))
|
|
options)
|
|
|
|
(define (blank-oid)
|
|
(git_oid_fromstr zero-oid-string))
|
|
|
|
(define (repository-path [start (current-directory)])
|
|
(or (git_repository_discover start)
|
|
(error 'git "not inside a Git repository: ~a" start)))
|
|
|
|
(define (open-repository [start (current-directory)])
|
|
(git_repository_open (repository-path start)))
|
|
|
|
(define (git-repository? [path (current-directory)])
|
|
(and (git_repository_discover path) #t))
|
|
|
|
(define (git-root [path (current-directory)])
|
|
(define repo (open-repository path))
|
|
(define root
|
|
(if (git_repository_is_bare repo)
|
|
(git_repository_path repo)
|
|
(git_repository_workdir repo)))
|
|
(simplify-path (string->path root)))
|
|
|
|
(define (git-init [path (current-directory)] #:bare? [bare? #f])
|
|
(git_repository_init path #:bare? bare?)
|
|
(git-root path))
|
|
|
|
(define (default-clone-directory url)
|
|
(define cleaned (regexp-replace #rx"/+$" url ""))
|
|
(define parts
|
|
(filter (lambda (s) (not (string=? s "")))
|
|
(regexp-split #rx"[/\\\\:]" cleaned)))
|
|
(unless (pair? parts)
|
|
(error 'git-clone "cannot derive a directory name from ~a" url))
|
|
(regexp-replace #rx"[.]git$" (last parts) ""))
|
|
|
|
(define git-clone
|
|
(case-lambda
|
|
[(url)
|
|
(git-clone url (default-clone-directory url))]
|
|
[(url path)
|
|
(git_clone url
|
|
(path->string (if (path? path) path (string->path path)))
|
|
(make-clone-options))
|
|
(git-root path)]))
|
|
|
|
(define (normalize-status-flags flags)
|
|
(cond
|
|
[(list? flags) flags]
|
|
[(symbol? flags)
|
|
(if (eq? flags 'GIT_STATUS_CURRENT) null (list flags))]
|
|
[else null]))
|
|
|
|
(define (has-status? flags flag)
|
|
(and (memq flag flags) #t))
|
|
|
|
(define (index-status-char flags)
|
|
(cond
|
|
[(has-status? flags 'GIT_STATUS_INDEX_NEW) #\A]
|
|
[(has-status? flags 'GIT_STATUS_INDEX_MODIFIED) #\M]
|
|
[(has-status? flags 'GIT_STATUS_INDEX_DELETED) #\D]
|
|
[(has-status? flags 'GIT_STATUS_INDEX_RENAMED) #\R]
|
|
[(has-status? flags 'GIT_STATUS_INDEX_TYPECHANGE) #\T]
|
|
[else #\space]))
|
|
|
|
(define (worktree-status-char flags)
|
|
(cond
|
|
[(has-status? flags 'GIT_STATUS_WT_MODIFIED) #\M]
|
|
[(has-status? flags 'GIT_STATUS_WT_DELETED) #\D]
|
|
[(has-status? flags 'GIT_STATUS_WT_RENAMED) #\R]
|
|
[(has-status? flags 'GIT_STATUS_WT_TYPECHANGE) #\T]
|
|
[(has-status? flags 'GIT_STATUS_WT_UNREADABLE) #\?]
|
|
[else #\space]))
|
|
|
|
(define (status-code flags)
|
|
(cond
|
|
[(has-status? flags 'GIT_STATUS_CONFLICTED) "UU"]
|
|
[(has-status? flags 'GIT_STATUS_IGNORED) "!!"]
|
|
[(has-status? flags 'GIT_STATUS_WT_NEW) "??"]
|
|
[else
|
|
(string (index-status-char flags)
|
|
(worktree-status-char flags))]))
|
|
|
|
(define (git-status)
|
|
(define repo (open-repository))
|
|
(define result null)
|
|
(git_status_foreach
|
|
repo
|
|
(lambda (path raw-flags _payload)
|
|
(define flags (normalize-status-flags raw-flags))
|
|
;; Match normal `git status`: ignored files are not shown unless
|
|
;; explicitly requested. git_status_foreach uses libgit2's defaults,
|
|
;; which may include them.
|
|
(unless (has-status? flags 'GIT_STATUS_IGNORED)
|
|
(set! result
|
|
(cons (git-status-entry path (status-code flags) flags)
|
|
result)))
|
|
0)
|
|
#"")
|
|
(sort result
|
|
(lambda (a b)
|
|
(string<? (git-status-entry-path a)
|
|
(git-status-entry-path b)))))
|
|
|
|
(define (git-status-lines [entries (git-status)])
|
|
(for/list ([entry (in-list entries)])
|
|
(format "~a ~a"
|
|
(git-status-entry-code entry)
|
|
(git-status-entry-path entry))))
|
|
|
|
(define (git-clean?)
|
|
(null? (git-status)))
|
|
|
|
(define (git-path-string path)
|
|
(regexp-replace* #rx"\\\\" (path->string path) "/"))
|
|
|
|
(define (relative-pathspec workdir path)
|
|
(define p0 (if (path? path) path (string->path path)))
|
|
;; A relative path supplied by the caller is relative to the caller's
|
|
;; current directory, not automatically to the repository root.
|
|
(define p (path->complete-path p0 (current-directory)))
|
|
(define rel (find-relative-path workdir p))
|
|
(define s (git-path-string rel))
|
|
(when (or (string=? s "..")
|
|
(string-prefix? s "../"))
|
|
(error 'git-add "path is outside the repository: ~a" path))
|
|
s)
|
|
|
|
(define (index-accept _path _matched-pathspec _payload)
|
|
0)
|
|
|
|
(define (git-add . paths)
|
|
(define repo (open-repository))
|
|
(define workdir (string->path (git_repository_workdir repo)))
|
|
(define index (git_repository_index repo))
|
|
(define pathspecs
|
|
(make-git_strarray
|
|
(for/list ([path (in-list paths)])
|
|
(relative-pathspec workdir path))))
|
|
;; update-all stages changes and removals of already tracked files;
|
|
;; add-all adds new files and updates existing files while respecting ignores.
|
|
(git_index_update_all index pathspecs index-accept #"")
|
|
(git_index_add_all index pathspecs 'GIT_INDEX_ADD_DEFAULT index-accept #"")
|
|
(git_index_write index)
|
|
(void))
|
|
|
|
(define (git-config-get key)
|
|
(define repo (open-repository))
|
|
(define config (git_repository_config repo))
|
|
;; git_config_get_string is incorrectly declared as an allocating wrapper
|
|
;; in the current Racket libgit2 package. The entry API has the correct
|
|
;; ownership model and works on normal repository config objects.
|
|
(define entry (git_config_get_entry config key))
|
|
(git_config_entry-value entry))
|
|
|
|
(define (git-config-set key value)
|
|
(define repo (open-repository))
|
|
(define config (git_repository_config repo))
|
|
(git_config_set_string config key value)
|
|
value)
|
|
|
|
(define git-config
|
|
(case-lambda
|
|
[(key) (git-config-get key)]
|
|
[(key value) (git-config-set key value)]))
|
|
|
|
(define (head-commit repo)
|
|
(cond
|
|
[(git_repository_is_empty repo) #f]
|
|
[(git_repository_head_unborn repo) #f]
|
|
[else
|
|
(define head (git_repository_head repo))
|
|
(git_commit_lookup repo (git_reference_target head))]))
|
|
|
|
(define (git-head)
|
|
(define repo (open-repository))
|
|
(define commit (head-commit repo))
|
|
(and commit (git_oid_fmt (git_commit_id commit))))
|
|
|
|
(define (git-commit message)
|
|
(define repo (open-repository))
|
|
(define index (git_repository_index repo))
|
|
(when (git_index_has_conflicts index)
|
|
(error 'git-commit "the index contains unresolved conflicts"))
|
|
|
|
(define tree-id (blank-oid))
|
|
(git_index_write_tree tree-id index)
|
|
(define tree (git_tree_lookup repo tree-id))
|
|
(define parent (head-commit repo))
|
|
|
|
(cond
|
|
[(and (not parent) (zero? (git_index_entrycount index)))
|
|
(error 'git-commit "nothing staged to commit")]
|
|
[(and parent (git_oid_equal tree-id (git_commit_tree_id parent)))
|
|
(error 'git-commit "nothing staged to commit")])
|
|
|
|
(define signature (git_signature_default repo))
|
|
(define commit-id (blank-oid))
|
|
(define result
|
|
(if parent
|
|
(git_commit_create_v commit-id repo "HEAD"
|
|
signature signature #f message tree 1 parent)
|
|
(git_commit_create_v commit-id repo "HEAD"
|
|
signature signature #f message tree 0)))
|
|
(unless (zero? result)
|
|
(error 'git-commit "libgit2 git_commit_create_v failed with code ~a" result))
|
|
(git_oid_fmt commit-id))
|
|
|
|
(define (git-current-branch)
|
|
(define repo (open-repository))
|
|
(cond
|
|
[(git_repository_head_detached repo) #f]
|
|
[(git_repository_head_unborn repo)
|
|
(define head (git_reference_lookup repo "HEAD"))
|
|
(define target (git_reference_symbolic_target head))
|
|
(and target
|
|
(string-prefix? target branch-prefix)
|
|
(substring target (string-length branch-prefix)))]
|
|
[else
|
|
(git_reference_shorthand (git_repository_head repo))]))
|
|
|
|
(define (git-branches)
|
|
(define repo (open-repository))
|
|
(define branches null)
|
|
(git_reference_foreach_name
|
|
repo
|
|
(lambda (name _payload)
|
|
(when (string-prefix? name branch-prefix)
|
|
(set! branches
|
|
(cons (substring name (string-length branch-prefix)) branches)))
|
|
0)
|
|
#"")
|
|
(sort branches string<?))
|
|
|
|
(define (create-branch name)
|
|
(define repo (open-repository))
|
|
(define commit (head-commit repo))
|
|
(unless commit
|
|
(error 'git-branch "cannot create a branch before the first commit"))
|
|
(git_branch_create repo name commit #f)
|
|
name)
|
|
|
|
(define git-branch
|
|
(case-lambda
|
|
[() (git-branches)]
|
|
[(name) (create-branch name)]))
|
|
|
|
(define (git-branch-delete name)
|
|
(define repo (open-repository))
|
|
(define ref (git_branch_lookup repo name 'GIT_BRANCH_LOCAL))
|
|
(git_branch_delete ref)
|
|
(void))
|
|
|
|
(define (git-checkout name)
|
|
(define repo (open-repository))
|
|
(cond
|
|
[(member name (git-branches))
|
|
(define refname (string-append branch-prefix name))
|
|
(define object (git_revparse_single repo (string-append refname "^{commit}")))
|
|
;; Checkout first: with default safe checkout, a dirty worktree aborts
|
|
;; before HEAD is changed.
|
|
(git_checkout_tree repo object #f)
|
|
(git_repository_set_head repo refname)]
|
|
[else
|
|
(define object (git_revparse_single repo (string-append name "^{commit}")))
|
|
(git_checkout_tree repo object #f)
|
|
(git_repository_set_head_detached repo (git_object_id object))])
|
|
(git-head))
|
|
|
|
(define (git-checkout-new name)
|
|
(git-branch name)
|
|
(git-checkout name))
|
|
|
|
(define (git-tags)
|
|
(define tags null)
|
|
(git_tag_foreach
|
|
(open-repository)
|
|
(lambda (name _oid _payload)
|
|
(set! tags
|
|
(cons (if (string-prefix? name tag-prefix)
|
|
(substring name (string-length tag-prefix))
|
|
name)
|
|
tags))
|
|
0)
|
|
#"")
|
|
(sort tags string<?))
|
|
|
|
(define (create-tag name)
|
|
(define repo (open-repository))
|
|
(unless (head-commit repo)
|
|
(error 'git-tag "cannot tag a repository without commits"))
|
|
(define target (git_revparse_single repo "HEAD^{commit}"))
|
|
(define tag-id (blank-oid))
|
|
(git_tag_create_lightweight tag-id repo name target #f)
|
|
(git_oid_fmt tag-id))
|
|
|
|
(define git-tag
|
|
(case-lambda
|
|
[() (git-tags)]
|
|
[(name) (create-tag name)]))
|
|
|
|
(define (git-tag-delete name)
|
|
(git_tag_delete (open-repository) name)
|
|
(void))
|
|
|
|
(define (git-log [max-count 20])
|
|
(unless (exact-nonnegative-integer? max-count)
|
|
(raise-argument-error 'git-log "exact-nonnegative-integer?" max-count))
|
|
(define repo (open-repository))
|
|
(cond
|
|
[(not (head-commit repo)) null]
|
|
[else
|
|
(define walk (git_revwalk_new repo))
|
|
(git_revwalk_sorting walk '(GIT_SORT_TOPOLOGICAL GIT_SORT_TIME))
|
|
(git_revwalk_push_head walk)
|
|
(let loop ([left max-count] [result null])
|
|
(cond
|
|
[(zero? left) (reverse result)]
|
|
[else
|
|
(define oid (git_revwalk_next walk))
|
|
(if oid
|
|
(let ([commit (git_commit_lookup repo oid)])
|
|
(loop (sub1 left)
|
|
(cons (git-log-entry (git_oid_fmt oid)
|
|
(or (git_commit_summary commit) "")
|
|
(git_commit_time commit))
|
|
result)))
|
|
(reverse result))]))]))
|
|
|
|
(define (git-log-lines [entries (git-log)])
|
|
(for/list ([entry (in-list entries)])
|
|
(format "~a ~a"
|
|
(substring (git-log-entry-id entry) 0 7)
|
|
(git-log-entry-summary entry))))
|
|
|
|
(define (git-remotes)
|
|
;; git_remote_list is affected by the same git_strarray wrapper problem as
|
|
;; git_tag_list in the current Racket bindings. Remote URLs are stored in
|
|
;; repository config, so enumerate those entries instead.
|
|
(define repo (open-repository))
|
|
(define config (git_repository_config repo))
|
|
(define remotes null)
|
|
(git_config_foreach
|
|
config
|
|
(lambda (entry _payload)
|
|
(define key (git_config_entry-name entry))
|
|
(define m (regexp-match #rx"^remote[.](.+)[.]url$" key))
|
|
(when m
|
|
(set! remotes (cons (cadr m) remotes)))
|
|
0)
|
|
#"")
|
|
(sort (remove-duplicates remotes) string<?))
|
|
|
|
(define (git-remote-add name url)
|
|
(git_remote_create (open-repository) name url)
|
|
name)
|
|
|
|
(define (git-remote-url [name "origin"])
|
|
(define remote (git_remote_lookup (open-repository) name))
|
|
(git_remote_url remote))
|
|
|
|
(define (git-fetch [name "origin"])
|
|
(define repo (open-repository))
|
|
(define remote (git_remote_lookup repo name))
|
|
(git_remote_fetch remote #f (make-fetch-options) (format "fetch ~a" name))
|
|
(void))
|
|
|
|
(define (git-pull [remote-name "origin"])
|
|
(define branch (git-current-branch))
|
|
(unless branch
|
|
(error 'git-pull "pull requires an attached local branch"))
|
|
|
|
(git-fetch remote-name)
|
|
|
|
(define repo (open-repository))
|
|
(define local-ref-name (string-append branch-prefix branch))
|
|
(define local-ref (git_reference_lookup repo local-ref-name))
|
|
(define local-id (git_reference_target local-ref))
|
|
(define remote-spec
|
|
(format "refs/remotes/~a/~a^{commit}" remote-name branch))
|
|
(define remote-object (git_revparse_single repo remote-spec))
|
|
(define remote-id (git_object_id remote-object))
|
|
|
|
(cond
|
|
[(git_oid_equal local-id remote-id) #f]
|
|
[(git_graph_descendant_of repo remote-id local-id)
|
|
;; Update the worktree safely before moving the branch reference.
|
|
(git_checkout_tree repo remote-object #f)
|
|
(git_reference_set_target
|
|
local-ref remote-id (format "pull: fast-forward from ~a" remote-name))
|
|
(git_oid_fmt remote-id)]
|
|
[else
|
|
(error 'git-pull
|
|
"non-fast-forward pull is not supported; merge or rebase explicitly")]))
|
|
|
|
(define (push-refspec remote-name refspec)
|
|
(define repo (open-repository))
|
|
(define remote (git_remote_lookup repo remote-name))
|
|
(define options (make-push-options))
|
|
(define strings
|
|
(cast (list refspec) (_list i _string interior) _gcpointer))
|
|
(define refspecs (make-git_strarray/raw strings 1))
|
|
(git_remote_push/raw remote refspecs options)
|
|
;; Keep the C string-pointer array alive through the foreign call.
|
|
(void strings)
|
|
(void))
|
|
|
|
(define git-push
|
|
(case-lambda
|
|
[()
|
|
(define branch (git-current-branch))
|
|
(unless branch
|
|
(error 'git-push "push requires an attached local branch"))
|
|
(git-push "origin" branch)]
|
|
[(remote-name)
|
|
(define branch (git-current-branch))
|
|
(unless branch
|
|
(error 'git-push "push requires an attached local branch"))
|
|
(git-push remote-name branch)]
|
|
[(remote-name branch)
|
|
(push-refspec
|
|
remote-name
|
|
(format "refs/heads/~a:refs/heads/~a" branch branch))]))
|
|
|
|
(define git-push-tag
|
|
(case-lambda
|
|
[(tag) (git-push-tag tag "origin")]
|
|
[(tag remote-name)
|
|
(push-refspec
|
|
remote-name
|
|
(format "refs/tags/~a:refs/tags/~a" tag tag))]))
|
|
|
|
(define (git command . args)
|
|
(unless (symbol? command)
|
|
(raise-argument-error 'git "symbol?" command))
|
|
(case command
|
|
[(init) (apply git-init args)]
|
|
[(clone) (apply git-clone args)]
|
|
[(status) (apply git-status args)]
|
|
[(add) (apply git-add args)]
|
|
[(config) (apply git-config args)]
|
|
[(commit) (apply git-commit args)]
|
|
[(branch)
|
|
(match args
|
|
[(list '-d name) (git-branch-delete name)]
|
|
[_ (apply git-branch args)])]
|
|
[(checkout)
|
|
(match args
|
|
[(list '-b name) (git-checkout-new name)]
|
|
[_ (apply git-checkout args)])]
|
|
[(tag)
|
|
(match args
|
|
[(list '-d name) (git-tag-delete name)]
|
|
[_ (apply git-tag args)])]
|
|
[(log) (apply git-log args)]
|
|
[(remote)
|
|
(match args
|
|
['() (git-remotes)]
|
|
[(list 'add name url) (git-remote-add name url)]
|
|
[(list 'get-url name) (git-remote-url name)]
|
|
[_ (error 'git "invalid remote arguments: ~e" args)])]
|
|
[(fetch) (apply git-fetch args)]
|
|
[(pull) (apply git-pull args)]
|
|
[(push) (apply git-push args)]
|
|
[(push-tag) (apply git-push-tag args)]
|
|
[(credentials)
|
|
(match args
|
|
[(list 'init password) (git-credentials-init! password)]
|
|
[(list 'unlock password) (git-credentials-unlock! password)]
|
|
[(list 'unlock password seconds)
|
|
(git-credentials-unlock! password #:for seconds)]
|
|
[(list 'lock) (git-credentials-lock!)]
|
|
[(list 'unlocked?) (git-credentials-unlocked?)]
|
|
[(list 'set remote username token)
|
|
(git-credentials-set! remote username token)]
|
|
[(list 'remove remote) (git-credentials-remove! remote)]
|
|
[_ (error 'git "invalid credentials arguments: ~e" args)])]
|
|
[else (error 'git "unknown command: ~a" command)]))
|
|
|
|
(define (status-description entry)
|
|
(define flags (git-status-entry-flags entry))
|
|
(cond
|
|
[(has-status? flags 'GIT_STATUS_CONFLICTED) "Conflicted"]
|
|
[(has-status? flags 'GIT_STATUS_WT_NEW) "New"]
|
|
[(or (has-status? flags 'GIT_STATUS_INDEX_RENAMED)
|
|
(has-status? flags 'GIT_STATUS_WT_RENAMED)) "Renamed"]
|
|
[(or (has-status? flags 'GIT_STATUS_INDEX_DELETED)
|
|
(has-status? flags 'GIT_STATUS_WT_DELETED)) "Deleted"]
|
|
[(has-status? flags 'GIT_STATUS_INDEX_NEW) "Added"]
|
|
[(or (has-status? flags 'GIT_STATUS_INDEX_TYPECHANGE)
|
|
(has-status? flags 'GIT_STATUS_WT_TYPECHANGE)) "Type changed"]
|
|
[(or (has-status? flags 'GIT_STATUS_INDEX_MODIFIED)
|
|
(has-status? flags 'GIT_STATUS_WT_MODIFIED)) "Modified"]
|
|
[(has-status? flags 'GIT_STATUS_WT_UNREADABLE) "Unreadable"]
|
|
[else (git-status-entry-code entry)]))
|
|
|
|
(define (pad-right value width)
|
|
(define text (format "~a" value))
|
|
(string-append text (make-string (max 0 (- width (string-length text))) #\space)))
|
|
|
|
(define (display-git-result command result [out (current-output-port)])
|
|
(cond
|
|
[(eq? command 'status)
|
|
(for ([entry (in-list result)])
|
|
(fprintf out "~a - ~a\n"
|
|
(pad-right (status-description entry) 12)
|
|
(git-status-entry-path entry)))]
|
|
[(eq? command 'log)
|
|
(for ([entry (in-list result)])
|
|
(fprintf out "~a ~a\n"
|
|
(substring (git-log-entry-id entry) 0 7)
|
|
(git-log-entry-summary entry)))]
|
|
[(list? result)
|
|
(for ([item (in-list result)])
|
|
(displayln item out))]
|
|
[(void? result) (void)]
|
|
[else (displayln result out)]))
|
|
|
|
(define (dgit command . args)
|
|
(define result (apply git command args))
|
|
(display-git-result command result)
|
|
result)
|